From 7a5c6862f40ba1c478e845c74e6cf333ce241e18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ole=20Sch=C3=BCtt?= Date: Wed, 15 Jul 2026 13:25:49 +0200 Subject: [PATCH 01/30] Increase development version after 2026.2 release (#5593) --- CMakeLists.txt | 2 +- docs/changelog.md | 6 +----- docs/versions.md | 1 + src/cp2k_info.F | 2 +- 4 files changed, 4 insertions(+), 7 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 4da6a195e7..075f91973c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ project( cp2k DESCRIPTION "CP2K" HOMEPAGE_URL "https://www.cp2k.org" - VERSION "2026.1" + VERSION "2026.2" LANGUAGES Fortran C CXX) list(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/cmake/modules") diff --git a/docs/changelog.md b/docs/changelog.md index 7c52cfc20c..ead18e18fa 100644 --- a/docs/changelog.md +++ b/docs/changelog.md @@ -1,6 +1,6 @@ # Changelog -## 2026.2 (Draft) +## 2026.2 (July 15, 2026) ### New Features @@ -41,7 +41,6 @@ - Per-thermal-region function for rescaling temperatures in MD (independent of thermostats) ([#5002](https://github.com/cp2k/cp2k/pull/5002)) - Cell optimization with fixed volume ([#5086](https://github.com/cp2k/cp2k/pull/5086)) -- **TODO** ### New Libraries @@ -53,7 +52,6 @@ - Reintegrate with LIBXS, LIBXSTREAM, and LIBXSMM ([#5343](https://github.com/cp2k/cp2k/pull/5343)) - Add libGint for Hartree–Fock exchange with CUDA acceleration ([#5446](https://github.com/cp2k/cp2k/pull/5446)) -- **TODO** ### Breaking Changes @@ -67,14 +65,12 @@ - An implementation of the FFTW3 interface may be turned into a hard dependency in a later release. Please consider compiling and CP2K with FFTW3, MKL, AOCL or any other library implementing this interface if you have not used it until now. ([#5454](https://github.com/cp2k/cp2k/pull/5454)) -- **TODO** ### Fixes - Fix issues in the native DFT-D4 implementation. ([#5030](https://github.com/cp2k/cp2k/pull/5030)) - Analytical periodic-subspace stress for 2D systems with ANALYTIC/MT ([#5282](https://github.com/cp2k/cp2k/pull/5282)) -- **TODO** ______________________________________________________________________ diff --git a/docs/versions.md b/docs/versions.md index 48f5f78b15..923bdbb73d 100644 --- a/docs/versions.md +++ b/docs/versions.md @@ -5,6 +5,7 @@ maxdepth: 1 titlesonly: --- +2026.2 2026.1 2025.2 2025.1 diff --git a/src/cp2k_info.F b/src/cp2k_info.F index afd451a01d..cc90bc1d31 100644 --- a/src/cp2k_info.F +++ b/src/cp2k_info.F @@ -46,7 +46,7 @@ MODULE cp2k_info #endif !!! Keep version in sync with CMakeLists.txt !!! - CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.1 (Development Version)" + CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.2 (Development Version)" CHARACTER(LEN=*), PARAMETER :: cp2k_year = "2026" CHARACTER(LEN=*), PARAMETER :: cp2k_home = "https://www.cp2k.org/" From ea663e99cfdb430c52ec736bcd617acc89ea2698 Mon Sep 17 00:00:00 2001 From: HE Zilong <159878975+he-zilong@users.noreply.github.com> Date: Wed, 15 Jul 2026 19:35:03 +0800 Subject: [PATCH 02/30] Address issues #1498 and #4023 (#5588) --- src/auto_basis.F | 26 ++++++++++++++++++++++---- src/cp_control_utils.F | 32 +++++++++++++++++++++++++++++--- src/input_cp2k_dft.F | 10 ++++++++-- src/input_cp2k_properties_dft.F | 9 +++++++-- 4 files changed, 66 insertions(+), 11 deletions(-) diff --git a/src/auto_basis.F b/src/auto_basis.F index 94bccf5995..23546df6e7 100644 --- a/src/auto_basis.F +++ b/src/auto_basis.F @@ -61,7 +61,7 @@ CONTAINS INTEGER, INTENT(IN), OPTIONAL :: basis_sort CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname + CHARACTER(LEN=default_string_length) :: bsname, kname INTEGER :: i, j, jj, l, laux, linc, lmax, lval, lx, & nsets, nx, z INTEGER, DIMENSION(0:18) :: nval @@ -84,7 +84,7 @@ CONTAINS 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp] ! CPASSERT(.NOT. ASSOCIATED(ri_aux_basis_set)) - NULLIFY (orb_basis_set) + NULLIFY (orb_basis_set, econf) IF (.NOT. PRESENT(basis_type)) THEN CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") ELSE @@ -106,6 +106,15 @@ CONTAINS CALL init_orbital_pointers(2*lmax) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) + IF (.NOT. ASSOCIATED(econf)) THEN + CALL get_qs_kind(qs_kind, name=kname) + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS RI_AUX cannot process atom kind "// & + "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & + "definition of potential or electron configuration; "// & + "consider setting keyword ELEC_CONF explicitly for "// & + "GHOST atom kind that has assigned a basis set") + END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) @@ -236,7 +245,7 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: exact_1c_terms, tda_kernel CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname + CHARACTER(LEN=default_string_length) :: bsname, kname INTEGER :: i, j, l, laux, linc, lm, lmax, lval, n1, & n2, nsets, z INTEGER, DIMENSION(0:18) :: nval @@ -267,12 +276,21 @@ CONTAINS END IF ! CPASSERT(.NOT. ASSOCIATED(lri_aux_basis_set)) - NULLIFY (orb_basis_set) + NULLIFY (orb_basis_set, econf) CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") IF (ASSOCIATED(orb_basis_set)) THEN CALL get_basis_keyfigures(orb_basis_set, lmax, zmin, zmax, zeff) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) + IF (.NOT. ASSOCIATED(econf)) THEN + CALL get_qs_kind(qs_kind, name=kname) + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS LRI_AUX cannot process atom kind "// & + "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & + "definition of potential or electron configuration; "// & + "consider setting keyword ELEC_CONF explicitly for "// & + "GHOST atom kind that has assigned a basis set") + END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index 3a2478e19e..23cc7d56b5 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -242,7 +242,18 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - isize = -1 + SELECT CASE (tmpstringlist(1)) + CASE ("X") + ! Do nothing + CASE DEFAULT + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS: the size is invalid for the "// & + "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & + "use one of SMALL, MEDIUM, LARGE, HUGE for "// & + "the size. The syntax AUTO_BASIS X X is a "// & + "reserved case for using NO automatically "// & + "generated basis sets.") + END SELECT CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -648,7 +659,11 @@ CONTAINS END IF ! periodic fields don't work with RTP - CPASSERT(.NOT. do_rtp) + IF (do_rtp) & + CALL cp_abort(__LOCATION__, & + "Periodic efield cannot be used with RTP. When restarting a "// & + "run with periodic efield, set RESTART_RTP under &EXT_RESTART "// & + "section to .FALSE. explicitly if RESTART_DEFAULT is .TRUE.") IF (dft_control%period_efield%displacement_field) THEN CALL cite_reference(Stengel2009) ELSE @@ -2122,7 +2137,18 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - isize = -1 + SELECT CASE (tmpstringlist(1)) + CASE ("X") + ! Do nothing + CASE DEFAULT + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS: the size is invalid for the "// & + "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & + "use one of SMALL, MEDIUM, LARGE, HUGE for "// & + "the size. The syntax AUTO_BASIS X X is a "// & + "reserved case for using NO automatically "// & + "generated basis sets.") + END SELECT CASE ("SMALL") isize = 0 CASE ("MEDIUM") diff --git a/src/input_cp2k_dft.F b/src/input_cp2k_dft.F index 082cc27f4b..74c65fff9f 100644 --- a/src/input_cp2k_dft.F +++ b/src/input_cp2k_dft.F @@ -250,8 +250,14 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify size of automatically generated auxiliary (RI) basis sets: "// & - "Options={small,medium,large,huge}", & + description="Specify type and size of automatically generated auxiliary "// & + "(RI) basis sets. Exactly two arguments are required for this option. "// & + "The first argument of basis type should be one of the following: "// & + "`RI_AUX`, `AUX_FIT`, `LRI_AUX`, `P_LRI_AUX`, `RI_HXC`, `RI_XAS`, or "// & + "`RI_HFX`. The second argument of basis size should be one of the "// & + "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & + "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & + "as written here).", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index e120efee04..68a5a348e7 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -1803,8 +1803,13 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify size of automatically generated auxiliary basis sets: "// & - "Options={small,medium,large,huge}", & + description="Specify type and size of automatically generated auxiliary "// & + "(RI) basis sets. Exactly two arguments are required for this option. "// & + "The first argument of basis type should be one of the following: "// & + "`P_LRI_AUX`. The second argument of basis size should be one of the "// & + "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & + "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & + "as written here).", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) From 39fe4c47c6ffbb58ee35c86b875c1acad04cd37b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franz=20P=C3=B6schel?= Date: Wed, 15 Jul 2026 13:48:13 +0200 Subject: [PATCH 03/30] Gauxc object caching (#5340) Co-authored-by: Thomas D. Kuehne Co-authored-by: Thomas Kuehne --- src/CMakeLists.txt | 1 + src/qs_environment_types.F | 7 + src/qs_ks_methods.F | 27 +- src/qs_vxc_atom.F | 20 +- src/skala_gpw_functional.F | 10 +- src/torch_c_api.cpp | 34 + src/xc/xc_derivatives.F | 169 ++++- src/xc/xc_gauxc_cache.F | 430 +++++++++++++ src/xc/xc_gauxc_functional.F | 397 +++++------- src/xc/xc_gauxc_interface.F | 18 +- src/xc/xc_libxc.F | 66 +- tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md | 12 + tests/QS/regtest-acc-1/TEST_FILES.toml | 6 + .../QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp | 63 ++ .../h2o-uzh-gapw-stress-debug-1.inp | 60 ++ .../h2o-uzh-gth-gapw-force-1.inp | 67 ++ .../h2o-uzh-gth-gapw-stress-debug-1.inp | 64 ++ .../h2o-uzh-gth-gapw_xc-force-1.inp | 69 ++ .../h2o-uzh-gth-gapw_xc-stress-debug-1.inp | 66 ++ .../QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp | 62 ++ .../regtest-ecp/ICl_lanl2dz_gapw_stress.inp | 59 ++ .../regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp | 64 ++ .../ICl_lanl2dz_gapw_xc_stress.inp | 61 ++ tests/QS/regtest-ecp/TEST_FILES.toml | 4 + tests/QS/regtest-gauxc-api/TEST_FILES.toml | 4 +- tests/QS/regtest-gauxc-cdft/TEST_FILES.toml | 6 +- .../QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml | 10 +- .../regtest-gauxc-gapw-gth-kp/TEST_FILES.toml | 6 +- .../QS/regtest-gauxc-gapw-gth/TEST_FILES.toml | 6 +- .../stage6/gauxc-1.1-skala-cp2k-fixes.patch | 606 +++++++++++++++++- 30 files changed, 2146 insertions(+), 328 deletions(-) create mode 100644 src/xc/xc_gauxc_cache.F create mode 100644 tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp create mode 100644 tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp create mode 100644 tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp create mode 100644 tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp create mode 100644 tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp create mode 100644 tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp create mode 100644 tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp create mode 100644 tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp create mode 100644 tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp create mode 100644 tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 21439a11e8..a31daadb31 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1378,6 +1378,7 @@ list( xc/xc.F xc/xc_functionals_utilities.F xc/xc_fxc_kernel.F + xc/xc_gauxc_cache.F xc/xc_gauxc_functional.F xc/xc_gauxc_interface.F xc/xc_hcth.F diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index ac6c8fa2a6..a7391d5956 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -163,6 +163,8 @@ MODULE qs_environment_types USE wannier_states_types, ONLY: wannier_centres_type USE xas_env_types, ONLY: xas_env_release,& xas_environment_type + USE xc_gauxc_cache, ONLY: cp_gauxc_cache_type,& + gauxc_cache_release #include "./base/base_uses.f90" IMPLICIT NONE @@ -322,6 +324,7 @@ MODULE qs_environment_types TYPE(mo_set_type), DIMENSION(:), POINTER :: mos_last_converged => NULL() ! tblite TYPE(tblite_type), POINTER :: tb_tblite => Null() + TYPE(cp_gauxc_cache_type) :: gauxc_cache END TYPE qs_environment_type CONTAINS @@ -1680,6 +1683,8 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF + CALL gauxc_cache_release(qs_env%gauxc_cache) + END SUBROUTINE qs_env_release ! ************************************************************************************************** @@ -1904,6 +1909,8 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF + CALL gauxc_cache_release(qs_env%gauxc_cache) + END SUBROUTINE qs_env_part_release END MODULE qs_environment_types diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index 652655dae1..9f6a420799 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -143,6 +143,7 @@ MODULE qs_ks_methods get_gauxc_section,& xc_section_uses_native_skala_grid USE smeagol_interface, ONLY: smeagol_shift_v_hartree + USE string_utilities, ONLY: uppercase USE surface_dipole, ONLY: calc_dipsurf_potential USE tblite_ks_matrix, ONLY: build_tblite_ks_matrix USE virial_types, ONLY: virial_type @@ -199,14 +200,15 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_build_kohn_sham_matrix' - CHARACTER(len=default_string_length) :: name + CHARACTER(len=default_string_length) :: gauxc_model_name, name INTEGER :: ace_rebuild_frequency, atom_a, handle, & iatom, ikind, img, ispin, natom, & nimages, nspins, output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of LOGICAL :: ace_active, do_adiabatic_rescaling, do_ddapc, do_hfx, do_kpoints, do_ppl, dokp, & - gapw, gapw_xc, just_energy_xc, lrigpw, my_print, native_grid_diagnostics, & - native_grid_use_cuda, native_skala_restore_exc, rigpw, use_gauxc_matrix, use_virial + gapw, gapw_xc, gauxc_model_none, just_energy_xc, lrigpw, my_print, & + native_grid_diagnostics, native_grid_use_cuda, native_skala_restore_exc, rigpw, & + use_gauxc_matrix, use_virial LOGICAL, SAVE :: native_grid_cpu_kpoints_warned = .FALSE. REAL(KIND=dp) :: ecore_ppl, edisp, ee_ener, ekin_mol, & mulliken_order_p, & @@ -922,12 +924,19 @@ CONTAINS NULLIFY (rho1) IF (dft_control%use_gauxc .AND. (gapw .OR. gapw_xc) .AND. & .NOT. xc_section_uses_native_skala_grid(xc_section)) THEN - ! Molecular GauXC evaluates the XC term outside xc_derivatives. - ! The accurate-XCINT force correction would otherwise try to - ! evaluate the GAUXC section through CP2K's local functional path. - ! Native-grid SKALA can provide this correction through the - ! CP2K grid path and needs it for GAPW_XC force consistency. - CONTINUE + gauxc_model_none = .FALSE. + gauxc_section => get_gauxc_section(xc_section) + IF (ASSOCIATED(gauxc_section)) THEN + CALL section_vals_val_get(gauxc_section, "MODEL", c_val=gauxc_model_name) + gauxc_model_name = ADJUSTL(gauxc_model_name) + CALL uppercase(gauxc_model_name) + gauxc_model_none = (TRIM(gauxc_model_name) == "" .OR. & + TRIM(gauxc_model_name) == "NONE") + END IF + IF (gauxc_model_none .AND. & + (gapw_xc .OR. gauxc_gapw_has_paw_pseudopotentials(qs_kind_set))) THEN + CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) + END IF ELSE CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) END IF diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index 77ca466195..84b2bd4516 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -15,6 +15,8 @@ MODULE qs_vxc_atom USE basis_set_types, ONLY: get_gto_basis_set,& gto_basis_set_type USE cp_control_types, ONLY: dft_control_type + USE external_potential_types, ONLY: gth_potential_type,& + sgp_potential_type USE input_constants, ONLY: xc_none USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type,& @@ -120,14 +122,16 @@ CONTAINS INTEGER :: bo(2), gapw_density_partition, handle, & iat, iatom, idir, ikind, ir, jdir, & - myfun, na, natom, nr, nspins, num_pe + myfun, na, natom, nr, nspins, num_pe, & + zatom INTEGER, DIMENSION(2, 3) :: bounds INTEGER, DIMENSION(:), POINTER :: atom_list LOGICAL :: accint, donlcc, evaluate_hard, evaluate_soft, gradient_f, lsd, & my_calculate_forces, nlcc, paw_atom, skala_atom_grid, tau_f, use_virial REAL(dp) :: agr, alpha, density_cut, exc_h, exc_s, & gradient_cut, & - my_adiabatic_rescale_factor, tau_cut + my_adiabatic_rescale_factor, tau_cut, & + zeff REAL(dp), DIMENSION(1, 1, 1) :: tau_d REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d REAL(dp), DIMENSION(3) :: skala_atom_force_h, skala_atom_force_s @@ -140,6 +144,7 @@ CONTAINS TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(dft_control_type), POINTER :: dft_control TYPE(grid_atom_type), POINTER :: grid_atom + TYPE(gth_potential_type), POINTER :: gth_potential TYPE(gto_basis_set_type), POINTER :: basis_1c TYPE(harmonics_atom_type), POINTER :: harmonics TYPE(mp_para_env_type), POINTER :: para_env @@ -151,6 +156,7 @@ CONTAINS TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set TYPE(rho_atom_type), POINTER :: rho_atom TYPE(section_vals_type), POINTER :: input, my_xc_section, xc_fun_section + TYPE(sgp_potential_type), POINTER :: sgp_potential TYPE(tau_basis_cache_type) :: tau_basis_cache TYPE(virial_type), POINTER :: virial TYPE(xc_derivative_set_type) :: deriv_set @@ -165,6 +171,7 @@ CONTAINS NULLIFY (my_kind_set) NULLIFY (atomic_kind_set) NULLIFY (grid_atom) + NULLIFY (gth_potential) NULLIFY (force) NULLIFY (harmonics) NULLIFY (input) @@ -173,6 +180,7 @@ CONTAINS NULLIFY (rho_atom) NULLIFY (my_rho_atom_set) NULLIFY (rho_nlcc) + NULLIFY (sgp_potential) NULLIFY (virial) my_calculate_forces = .FALSE. IF (PRESENT(calculate_forces)) my_calculate_forces = calculate_forces @@ -250,11 +258,17 @@ CONTAINS DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom) + NULLIFY (gth_potential, sgp_potential) CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, & - harmonics=harmonics, grid_atom=grid_atom) + gth_potential=gth_potential, harmonics=harmonics, & + grid_atom=grid_atom, sgp_potential=sgp_potential, & + zatom=zatom, zeff=zeff) CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C") IF (.NOT. paw_atom) CYCLE + IF (skala_atom_grid .AND. & + (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. & + ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE nr = grid_atom%nr na = grid_atom%ng_sphere diff --git a/src/skala_gpw_functional.F b/src/skala_gpw_functional.F index ea71c9ead5..212747e875 100644 --- a/src/skala_gpw_functional.F +++ b/src/skala_gpw_functional.F @@ -109,7 +109,7 @@ CONTAINS END FUNCTION xc_section_uses_native_skala_grid ! ************************************************************************************************** -!> \brief Return true if the GAUXC subsection requests a Skala-style model. +!> \brief Return true if the GAUXC subsection requests a model evaluation. !> \param xc_section ... !> \return ... ! ************************************************************************************************** @@ -117,16 +117,20 @@ CONTAINS TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section LOGICAL :: uses_gauxc_model - CHARACTER(len=default_path_length) :: model_key, model_name + CHARACTER(len=default_path_length) :: model_key, model_name, xc_key, xc_name TYPE(section_vals_type), POINTER :: gauxc_section uses_gauxc_model = .FALSE. gauxc_section => get_gauxc_section(xc_section) IF (ASSOCIATED(gauxc_section)) THEN CALL section_vals_val_get(gauxc_section, "MODEL", c_val=model_name) + CALL section_vals_val_get(gauxc_section, "FUNCTIONAL", c_val=xc_name) model_key = ADJUSTL(model_name) + xc_key = ADJUSTL(xc_name) CALL uppercase(model_key) - uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") + CALL uppercase(xc_key) + uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & + TRIM(model_key) /= TRIM(xc_key)) END IF END FUNCTION xc_section_uses_gauxc_model diff --git a/src/torch_c_api.cpp b/src/torch_c_api.cpp index 9349653ebf..9293fd6425 100644 --- a/src/torch_c_api.cpp +++ b/src/torch_c_api.cpp @@ -7,6 +7,7 @@ #if defined(__LIBTORCH) +#include #include #include #include @@ -16,6 +17,7 @@ #include #include +#include #include #include #include @@ -47,7 +49,38 @@ private: ******************************************************************************/ static bool use_cuda_if_available = true; +static bool get_positive_int_env(const char *name, int &value) { + const char *raw = std::getenv(name); + if (raw == nullptr || raw[0] == '\0') { + return false; + } + char *end = nullptr; + const long parsed = std::strtol(raw, &end, 10); + if (end == raw || *end != '\0' || parsed <= 0 || parsed > INT_MAX) { + return false; + } + value = static_cast(parsed); + return true; +} + +static void initialize_torch_threads_from_env() { + static bool initialized = false; + if (initialized) { + return; + } + initialized = true; + + int num_threads = 0; + if (get_positive_int_env("CP2K_TORCH_NUM_THREADS", num_threads)) { + at::set_num_threads(num_threads); + } + if (get_positive_int_env("CP2K_TORCH_NUM_INTEROP_THREADS", num_threads)) { + at::set_num_interop_threads(num_threads); + } +} + static torch::Device get_device() { + initialize_torch_threads_from_env(); if (!use_cuda_if_available || !torch::cuda::is_available()) { return torch::kCPU; } @@ -107,6 +140,7 @@ static torch_c_tensor_t *tensor_from_array(const torch::Dtype dtype, const bool req_grad, const int ndims, const int64_t sizes[], void *source) { + initialize_torch_threads_from_env(); const auto opts = torch::TensorOptions().dtype(dtype).requires_grad(req_grad); const auto sizes_ref = c10::IntArrayRef(sizes, ndims); return new torch_c_tensor_t(torch::from_blob(source, sizes_ref, opts)); diff --git a/src/xc/xc_derivatives.F b/src/xc/xc_derivatives.F index 431bb25b6e..846f254921 100644 --- a/src/xc/xc_derivatives.F +++ b/src/xc/xc_derivatives.F @@ -11,7 +11,9 @@ MODULE xc_derivatives USE input_section_types, ONLY: section_vals_get_subs_vals2,& section_vals_type,& section_vals_val_get - USE kinds, ONLY: dp + USE kinds, ONLY: default_string_length,& + dp + USE string_utilities, ONLY: uppercase USE xc_b97, ONLY: b97_lda_eval,& b97_lda_info,& b97_lsd_eval,& @@ -281,9 +283,14 @@ CONTAINS CALL pbe_lda_info(functional, reference, shortform, needs, max_deriv) END IF CASE ("GAUXC") - CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) - ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F - ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) + IF (gauxc_model_none_selected(functional)) THEN + CALL gauxc_model_none_xc_info(functional, lsd, reference, shortform, & + needs, max_deriv, print_warn) + ELSE + CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) + ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F + ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) + END IF CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_info(reference, shortform, needs, max_deriv) @@ -507,7 +514,11 @@ CONTAINS CALL pbe_lda_eval(rho_set, deriv_set, deriv_order, functional) END IF CASE ("GAUXC") - CPABORT(abort_message_skala) + IF (gauxc_model_none_selected(functional)) THEN + CALL gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) + ELSE + CPABORT(abort_message_skala) + END IF CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_eval(rho_set, deriv_set, deriv_order, functional) @@ -552,6 +563,154 @@ CONTAINS CALL timestop(handle) END SUBROUTINE xc_functional_eval +! ************************************************************************************************** +!> \brief true for GAUXC sections that wrap a conventional LibXC functional +!> \param functional the GAUXC section +!> \return whether MODEL NONE is active +! ************************************************************************************************** + FUNCTION gauxc_model_none_selected(functional) + TYPE(section_vals_type), POINTER :: functional + LOGICAL :: gauxc_model_none_selected + + CHARACTER(LEN=default_string_length) :: model_key, model_name, xc_fun_name, & + xc_key + + CALL section_vals_val_get(functional, "MODEL", c_val=model_name) + CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) + model_key = ADJUSTL(model_name) + xc_key = ADJUSTL(xc_fun_name) + CALL uppercase(model_key) + CALL uppercase(xc_key) + gauxc_model_none_selected = (TRIM(model_key) == "" .OR. TRIM(model_key) == "NONE" .OR. & + TRIM(model_key) == TRIM(xc_key)) + END FUNCTION gauxc_model_none_selected + +! ************************************************************************************************** +!> \brief map GAUXC MODEL NONE shorthand names to LibXC exchange/correlation components +!> \param functional the GAUXC section +!> \param xc_fun_name the GAUXC FUNCTIONAL value +!> \param libxc_names LibXC section names to evaluate and add +!> \param nfunc number of LibXC components +! ************************************************************************************************** + SUBROUTINE gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) + TYPE(section_vals_type), POINTER :: functional + CHARACTER(LEN=*), INTENT(OUT) :: xc_fun_name + CHARACTER(LEN=*), DIMENSION(:), INTENT(OUT) :: libxc_names + INTEGER, INTENT(OUT) :: nfunc + + CHARACTER(LEN=default_string_length) :: xc_key + + CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) + xc_key = ADJUSTL(xc_fun_name) + CALL uppercase(xc_key) + libxc_names(:) = "" + SELECT CASE (TRIM(xc_key)) + CASE ("LDA", "PADE") + nfunc = 2 + libxc_names(1) = "LDA_X" + libxc_names(2) = "LDA_C_PW" + CASE ("VWN") + nfunc = 2 + libxc_names(1) = "LDA_X" + libxc_names(2) = "LDA_C_VWN" + CASE ("PBE") + nfunc = 2 + libxc_names(1) = "GGA_X_PBE" + libxc_names(2) = "GGA_C_PBE" + CASE ("BLYP") + nfunc = 2 + libxc_names(1) = "GGA_X_B88" + libxc_names(2) = "GGA_C_LYP" + CASE ("BP") + nfunc = 2 + libxc_names(1) = "GGA_X_B88" + libxc_names(2) = "GGA_C_P86" + CASE ("TPSS") + nfunc = 2 + libxc_names(1) = "MGGA_X_TPSS" + libxc_names(2) = "MGGA_C_TPSS" + CASE ("R2SCAN") + nfunc = 2 + libxc_names(1) = "MGGA_X_R2SCAN" + libxc_names(2) = "MGGA_C_R2SCAN" + CASE DEFAULT + nfunc = 1 + libxc_names(1) = TRIM(xc_key) + END SELECT + END SUBROUTINE gauxc_model_none_libxc_names + +! ************************************************************************************************** +!> \brief needs information for GAUXC MODEL NONE one-center GAPW corrections +!> \param functional the GAUXC section +!> \param lsd whether spin-polarized derivatives are needed +!> \param reference reference string for the wrapped functional +!> \param shortform short name for printout +!> \param needs density ingredients needed by the wrapped functional +!> \param max_deriv maximum implemented derivative order +!> \param print_warn whether LibXC should print development warnings +! ************************************************************************************************** + SUBROUTINE gauxc_model_none_xc_info(functional, lsd, reference, shortform, & + needs, max_deriv, print_warn) + TYPE(section_vals_type), POINTER :: functional + LOGICAL, INTENT(in) :: lsd + CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform + TYPE(xc_rho_cflags_type), INTENT(inout), OPTIONAL :: needs + INTEGER, INTENT(out), OPTIONAL :: max_deriv + LOGICAL, INTENT(IN), OPTIONAL :: print_warn + + CHARACTER(LEN=default_string_length) :: libxc_names(2), xc_fun_name + INTEGER :: ifunc, max_deriv_i, max_deriv_min, nfunc + + CALL gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) + max_deriv_min = HUGE(max_deriv_min) + DO ifunc = 1, nfunc + IF (lsd) THEN + CALL libxc_lsd_info(functional, needs=needs, max_deriv=max_deriv_i, & + print_warn=print_warn, & + func_name_override=TRIM(libxc_names(ifunc))) + ELSE + CALL libxc_lda_info(functional, needs=needs, max_deriv=max_deriv_i, & + print_warn=print_warn, & + func_name_override=TRIM(libxc_names(ifunc))) + END IF + max_deriv_min = MIN(max_deriv_min, max_deriv_i) + END DO + IF (PRESENT(max_deriv)) max_deriv = max_deriv_min + IF (PRESENT(reference)) & + reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" + IF (PRESENT(shortform)) shortform = "GAUXC ("//TRIM(xc_fun_name)//")" + END SUBROUTINE gauxc_model_none_xc_info + +! ************************************************************************************************** +!> \brief one-center GAPW correction evaluation for GAUXC MODEL NONE +!> \param functional the GAUXC section +!> \param lsd whether spin-polarized derivatives are evaluated +!> \param rho_set density ingredients +!> \param deriv_set derivative accumulator +!> \param deriv_order derivative order to evaluate +! ************************************************************************************************** + SUBROUTINE gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) + TYPE(section_vals_type), POINTER :: functional + LOGICAL, INTENT(in) :: lsd + TYPE(xc_rho_set_type), INTENT(IN) :: rho_set + TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set + INTEGER, INTENT(IN) :: deriv_order + + CHARACTER(LEN=default_string_length) :: libxc_names(2), xc_fun_name + INTEGER :: ifunc, nfunc + + CALL gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) + DO ifunc = 1, nfunc + IF (lsd) THEN + CALL libxc_lsd_eval(rho_set, deriv_set, deriv_order, functional, & + func_name_override=TRIM(libxc_names(ifunc))) + ELSE + CALL libxc_lda_eval(rho_set, deriv_set, deriv_order, functional, & + func_name_override=TRIM(libxc_names(ifunc))) + END IF + END DO + END SUBROUTINE gauxc_model_none_xc_eval + ! ************************************************************************************************** !> \brief ... !> \param functionals a section containing the functional combination to be diff --git a/src/xc/xc_gauxc_cache.F b/src/xc/xc_gauxc_cache.F new file mode 100644 index 0000000000..5da9d0aee3 --- /dev/null +++ b/src/xc/xc_gauxc_cache.F @@ -0,0 +1,430 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +#ifdef __GAUXC +#include "gauxc/gauxc_config.f" +#endif + +MODULE xc_gauxc_cache + + USE iso_c_binding, ONLY: c_double + USE kinds, ONLY: default_path_length,& + default_string_length + USE message_passing, ONLY: mp_comm_self,& + mp_para_env_type + USE particle_types, ONLY: particle_type + USE qs_kind_types, ONLY: qs_kind_type + USE xc_gauxc_interface, ONLY: & + cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & + cp_gauxc_molecule_type, cp_gauxc_status_type, gauxc_check_status, gauxc_create_basisset, & + gauxc_create_grid, gauxc_create_integrator, gauxc_create_molecule, gauxc_destroy_basisset, & + gauxc_destroy_grid, gauxc_destroy_integrator, gauxc_destroy_molecule +#include "../base/base_uses.f90" + + IMPLICIT NONE + PRIVATE + + TYPE cp_gauxc_cache_params + INTEGER :: natom = -1 + INTEGER :: nspins = -1 + INTEGER :: batch_size = -1 + REAL(c_double) :: device_runtime_fill_fraction = 0.0_c_double + CHARACTER(LEN=default_string_length) :: xc_fun_name = "" + CHARACTER(LEN=default_string_length) :: grid_type = "" + CHARACTER(LEN=default_string_length) :: radial_quadrature = "" + CHARACTER(LEN=default_string_length) :: pruning_scheme = "" + CHARACTER(LEN=default_string_length) :: lb_exec_space = "" + CHARACTER(LEN=default_string_length) :: int_exec_space = "" + CHARACTER(LEN=default_path_length) :: model_eval_name = "" + CHARACTER(len=default_string_length) :: lwd_kernel = "" + LOGICAL :: use_mpi_runtime = .FALSE. + LOGICAL :: use_gradient_mpi_runtime = .FALSE. + LOGICAL :: use_self_runtime = .FALSE. + LOGICAL :: use_gradient_self_runtime = .FALSE. + LOGICAL :: use_fd_gradient = .FALSE. + LOGICAL :: use_gauxc_model = .FALSE. + END TYPE cp_gauxc_cache_params + + TYPE, extends(cp_gauxc_cache_params) :: cp_gauxc_cache_type + TYPE(cp_gauxc_molecule_type) :: molecule + TYPE(cp_gauxc_basisset_type) :: basisset + TYPE(cp_gauxc_grid_type) :: grid + TYPE(cp_gauxc_grid_type) :: gradient_grid + TYPE(cp_gauxc_integrator_type) :: integrator + TYPE(cp_gauxc_integrator_type) :: gradient_integrator + INTEGER :: mpi_comm + LOGICAL :: is_init = .FALSE. + REAL(c_double), DIMENSION(:, :), ALLOCATABLE :: last_positions + + CONTAINS + + PROCEDURE, PUBLIC :: needs_gradient_grid => gauxc_cache_type_needs_gradient_grid + PROCEDURE, PUBLIC :: max_l => gauxc_cache_type_max_l + END TYPE cp_gauxc_cache_type + + PUBLIC :: & + cp_gauxc_cache_type, & + gauxc_cache_init, & + gauxc_cache_is_valid, & + gauxc_cache_release, cp_gauxc_cache_params + +CONTAINS + +! ************************************************************************************************** +!> \brief ... +!> \param this ... +!> \return ... +! ************************************************************************************************** + FUNCTION gauxc_cache_type_needs_gradient_grid(this) RESULT(res) + class(cp_gauxc_cache_type) :: this + LOGICAL :: res + + res = this%use_gradient_self_runtime + END FUNCTION gauxc_cache_type_needs_gradient_grid + +! ************************************************************************************************** +!> \brief ... +!> \param this ... +!> \return ... +! ************************************************************************************************** + FUNCTION gauxc_cache_type_max_l(this) RESULT(res) + class(cp_gauxc_cache_type) :: this + INTEGER :: res + + res = this%basisset%max_l + END FUNCTION gauxc_cache_type_max_l + +! ************************************************************************************************** +!> \brief ... +!> \param cache ... +!> \param params ... +!> \param para_env ... +!> \param particle_set ... +!> \param qs_kind_set ... +!> \param status ... +! ************************************************************************************************** + SUBROUTINE gauxc_cache_init( & + cache, & + params, & + para_env, & + particle_set, & + qs_kind_set, & + status) + + TYPE(cp_gauxc_cache_type), INTENT(inout) :: cache + TYPE(cp_gauxc_cache_params), INTENT(inout) :: params + TYPE(mp_para_env_type), INTENT(in), POINTER :: para_env + TYPE(particle_type), DIMENSION(:), INTENT(in), & + POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), INTENT(in), & + POINTER :: qs_kind_set + TYPE(cp_gauxc_status_type), INTENT(inout) :: status + +#ifdef __GAUXC + IF (gauxc_cache_is_valid( & + cache, & + params, & + para_env, & + particle_set)) THEN + status%status%code = 0 + RETURN + END IF + + CALL gauxc_cache_release(cache) + + cache%molecule = gauxc_create_molecule( & + particle_set, & + status) + IF (status%status%code /= 0) GO TO 100 + + cache%basisset = gauxc_create_basisset( & + qs_kind_set, & + particle_set, & + status) + IF (status%status%code /= 0) GO TO 200 + + params%use_fd_gradient = & + params%use_fd_gradient .AND. (cache%max_l() > 3) + params%use_gradient_mpi_runtime = & + params%use_gradient_mpi_runtime .AND. .NOT. params%use_fd_gradient + params%use_gradient_self_runtime = & + params%use_gradient_self_runtime .AND. .NOT. params%use_gradient_mpi_runtime + + IF (params%use_fd_gradient .AND. para_env%mepos == 0) THEN + CALL cp_warn( & + __LOCATION__, & + "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & + "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & + "not yet reliable for this case.") + END IF + IF (params%use_self_runtime .OR. .NOT. params%use_gauxc_model) THEN + ! SKALA currently needs a replicated molecular runtime for reproducible + ! open-shell densities across CP2K MPI ranks. + ! Conventional GauXC also uses a replicated runtime here: CP2K has + ! already allreduced the dense AO density matrix on every rank. + cache%grid = gauxc_create_grid( & + cache%molecule, & + cache%basisset, & + params%grid_type, & + params%radial_quadrature, & + params%pruning_scheme, & + params%lb_exec_space, & + params%batch_size, & + params%device_runtime_fill_fraction, & + status, & + mpi_comm=mp_comm_self%get_handle(), & + force_new_runtime=.TRUE.) + ELSE + ! Use the QS force-evaluation communicator rather than GauXC's global + ! runtime. In mixed CDFT the diabatic states can be built on disjoint + ! MPI subgroups; using the global communicator would make GauXC wait + ! for ranks that are working on another state. + cache%grid = gauxc_create_grid( & + cache%molecule, & + cache%basisset, & + params%grid_type, & + params%radial_quadrature, & + params%pruning_scheme, & + params%lb_exec_space, & + params%batch_size, & + params%device_runtime_fill_fraction, & + status, & + mpi_comm=para_env%get_handle()) + END IF + IF (status%status%code /= 0) GO TO 300 + + cache%integrator = gauxc_create_integrator( & + TRIM(params%xc_fun_name), & + cache%grid, & + params%int_exec_space, & + params%lwd_kernel, & + params%nspins, & + status) + IF (status%status%code /= 0) GO TO 400 + + IF (params%use_gradient_self_runtime) THEN + ! Upstream GauXC does not yet support OneDFT/SKALA nuclear gradients + ! on an MPI runtime. Keep the energy/VXC path on the normal MPI + ! runtime and use an isolated runtime only for the replicated gradient. + cache%gradient_grid = gauxc_create_grid( & + cache%molecule, & + cache%basisset, & + params%grid_type, & + params%radial_quadrature, & + params%pruning_scheme, & + params%lb_exec_space, & + params%batch_size, & + params%device_runtime_fill_fraction, & + status, & + mpi_comm=mp_comm_self%get_handle(), & + force_new_runtime=.TRUE.) + IF (status%status%code /= 0) GO TO 500 + cache%gradient_integrator = gauxc_create_integrator( & + TRIM(params%xc_fun_name), & + cache%gradient_grid, & + params%int_exec_space, & + params%lwd_kernel, & + params%nspins, & + status) + IF (status%status%code /= 0) GO TO 600 + END IF + + cache%natom = params%natom + cache%nspins = params%nspins + cache%batch_size = params%batch_size + cache%device_runtime_fill_fraction = REAL(params%device_runtime_fill_fraction, c_double) + cache%xc_fun_name = TRIM(params%xc_fun_name) + cache%grid_type = TRIM(params%grid_type) + cache%radial_quadrature = TRIM(params%radial_quadrature) + cache%pruning_scheme = TRIM(params%pruning_scheme) + cache%lb_exec_space = TRIM(params%lb_exec_space) + cache%int_exec_space = TRIM(params%int_exec_space) + cache%model_eval_name = TRIM(params%model_eval_name) + cache%lwd_kernel = TRIM(params%lwd_kernel) + cache%use_gradient_mpi_runtime = params%use_gradient_mpi_runtime + cache%use_mpi_runtime = params%use_mpi_runtime + cache%use_gradient_self_runtime = params%use_gradient_self_runtime + cache%use_self_runtime = params%use_self_runtime + cache%use_fd_gradient = params%use_fd_gradient + IF (ALLOCATED(cache%last_positions)) & + DEALLOCATE (cache%last_positions) + ALLOCATE (cache%last_positions(3, params%natom)) + + BLOCK + INTEGER :: iatom + DO iatom = 1, params%natom + cache%last_positions(:, iatom) = REAL(particle_set(iatom)%r(:), c_double) + END DO + END BLOCK + + cache%mpi_comm = para_env%get_handle() + cache%is_init = .TRUE. + + RETURN + + ! Cleanup section in the error case. + +100 CONTINUE + CALL gauxc_destroy_molecule(cache%molecule, status) + CALL gauxc_check_status(status) + GO TO 999 + +200 CONTINUE + CALL gauxc_destroy_basisset(cache%basisset, status) + CALL gauxc_check_status(status) + GO TO 100 + +300 CONTINUE + CALL gauxc_destroy_grid(cache%grid, status) + CALL gauxc_check_status(status) + GO TO 200 + +400 CONTINUE + CALL gauxc_destroy_integrator(cache%integrator, status) + CALL gauxc_check_status(status) + GO TO 300 + +500 CONTINUE + CALL gauxc_destroy_grid(cache%gradient_grid, status) + CALL gauxc_check_status(status) + GO TO 400 + +600 CONTINUE + CALL gauxc_destroy_integrator(cache%gradient_integrator, status) + CALL gauxc_check_status(status) + +999 CONTINUE + IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) + cache%is_init = .FALSE. +#else + MARK_USED(params) + MARK_USED(para_env) + MARK_USED(particle_set) + MARK_USED(qs_kind_set) + MARK_USED(status) + cache%is_init = .FALSE. +#endif + + END SUBROUTINE gauxc_cache_init + +! ************************************************************************************************** +!> \brief Release all GauXC objects in a cache and deallocate arrays +!> \param cache ... +! ************************************************************************************************** + SUBROUTINE gauxc_cache_release(cache) + TYPE(cp_gauxc_cache_type), INTENT(INOUT) :: cache + +#ifdef __GAUXC + TYPE(cp_gauxc_status_type) :: status + + IF (cache%is_init) THEN + IF (cache%needs_gradient_grid()) THEN + CALL gauxc_destroy_integrator(cache%gradient_integrator, status) + CALL gauxc_check_status(status) + CALL gauxc_destroy_grid(cache%gradient_grid, status) + CALL gauxc_check_status(status) + END IF + CALL gauxc_destroy_integrator(cache%integrator, status) + CALL gauxc_check_status(status) + CALL gauxc_destroy_grid(cache%grid, status) + CALL gauxc_check_status(status) + CALL gauxc_destroy_basisset(cache%basisset, status) + CALL gauxc_check_status(status) + CALL gauxc_destroy_molecule(cache%molecule, status) + CALL gauxc_check_status(status) + END IF + IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) + cache%is_init = .FALSE. +#else + MARK_USED(cache) + IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) + cache%is_init = .FALSE. +#endif + END SUBROUTINE gauxc_cache_release + +! ************************************************************************************************** +!> \brief Check if the GauXC cache is valid for the given parameters +!> \param cache ... +!> \param params ... +!> \param para_env ... +!> \param particle_set ... +!> \return ... +!> \retval cache_valid ... +! ************************************************************************************************** + FUNCTION gauxc_cache_is_valid( & + cache, & + params, & + para_env, & + particle_set) & + RESULT(cache_valid) + + TYPE(cp_gauxc_cache_type), INTENT(IN) :: cache + TYPE(cp_gauxc_cache_params), INTENT(in) :: params + TYPE(mp_para_env_type), INTENT(in), POINTER :: para_env + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + LOGICAL :: use_gradient_self_runtime, use_gradient_mpi_runtime, use_fd_gradient + LOGICAL :: cache_valid + +#ifdef __GAUXC + INTEGER :: iatom + REAL(c_double), PARAMETER :: pos_tol = 1.0E-8_c_double + + cache_valid = .FALSE. + IF (.NOT. cache%is_init) RETURN + IF (cache%natom /= params%natom) RETURN + IF (cache%nspins /= params%nspins) RETURN + IF (cache%batch_size /= params%batch_size) RETURN + IF (ABS(cache%device_runtime_fill_fraction - REAL(params%device_runtime_fill_fraction, c_double)) > & + 1.0E-10_c_double) RETURN + IF (TRIM(cache%xc_fun_name) /= TRIM(params%xc_fun_name)) RETURN + IF (TRIM(cache%grid_type) /= TRIM(params%grid_type)) RETURN + IF (TRIM(cache%radial_quadrature) /= TRIM(params%radial_quadrature)) RETURN + IF (TRIM(cache%pruning_scheme) /= TRIM(params%pruning_scheme)) RETURN + IF (TRIM(cache%lb_exec_space) /= TRIM(params%lb_exec_space)) RETURN + IF (TRIM(cache%int_exec_space) /= TRIM(params%int_exec_space)) RETURN + IF (TRIM(cache%model_eval_name) /= TRIM(params%model_eval_name)) RETURN + IF (TRIM(cache%lwd_kernel) /= TRIM(params%lwd_kernel)) RETURN + IF (cache%use_self_runtime .NEQV. params%use_self_runtime) RETURN + IF (cache%use_mpi_runtime .NEQV. params%use_mpi_runtime) RETURN + + ! These three are modified during cache init, so we must emulate these changes here + use_gradient_self_runtime = params%use_gradient_self_runtime + use_gradient_mpi_runtime = params%use_gradient_mpi_runtime + use_fd_gradient = params%use_fd_gradient + + use_fd_gradient = & + use_fd_gradient .AND. (cache%max_l() > 3) + use_gradient_mpi_runtime = & + use_gradient_mpi_runtime .AND. .NOT. use_fd_gradient + use_gradient_self_runtime = & + use_gradient_self_runtime .AND. .NOT. use_gradient_mpi_runtime + + IF (cache%use_gradient_mpi_runtime .NEQV. use_gradient_mpi_runtime) RETURN + IF (cache%use_fd_gradient .NEQV. use_fd_gradient) RETURN + IF (cache%use_gradient_self_runtime .NEQV. use_gradient_self_runtime) RETURN + IF (cache%mpi_comm /= para_env%get_handle()) RETURN + + IF (.NOT. ALLOCATED(cache%last_positions)) RETURN + IF (SIZE(cache%last_positions, 2) /= params%natom) RETURN + DO iatom = 1, params%natom + IF (ANY(ABS(cache%last_positions(:, iatom) - & + REAL(particle_set(iatom)%r(:), c_double)) > pos_tol)) RETURN + END DO + cache_valid = .TRUE. +#else + MARK_USED(cache) + MARK_USED(particle_set) + MARK_USED(params) + MARK_USED(use_gradient_self_runtime) + MARK_USED(use_gradient_mpi_runtime) + MARK_USED(use_fd_gradient) + MARK_USED(para_env) + cache_valid = .FALSE. +#endif + END FUNCTION gauxc_cache_is_valid + +END MODULE xc_gauxc_cache diff --git a/src/xc/xc_gauxc_functional.F b/src/xc/xc_gauxc_functional.F index 3c12631d2f..50adf633b9 100644 --- a/src/xc/xc_gauxc_functional.F +++ b/src/xc/xc_gauxc_functional.F @@ -49,6 +49,9 @@ MODULE xc_gauxc_functional qs_rho_type USE qs_scf_types, ONLY: qs_scf_env_type USE string_utilities, ONLY: uppercase + USE xc_gauxc_cache, ONLY: cp_gauxc_cache_params,& + cp_gauxc_cache_type,& + gauxc_cache_init USE xc_gauxc_interface, ONLY: & cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & cp_gauxc_molecule_type, cp_gauxc_status_type, cp_gauxc_xc_gradient_type, cp_gauxc_xc_type, & @@ -117,24 +120,26 @@ CONTAINS !> \brief ... !> \param dbcsr_mat ... !> \param dense_mat ... +!> \param para_env ... ! ************************************************************************************************** - SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat) - USE cp_dbcsr_api, ONLY: dbcsr_get_info, dbcsr_get_matrix_type, dbcsr_iterator_type, & - dbcsr_iterator_start, dbcsr_iterator_next_block, dbcsr_iterator_blocks_left, & - dbcsr_iterator_stop, dbcsr_type_antisymmetric, dbcsr_type_symmetric + SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat, para_env) + USE cp_dbcsr_api, ONLY: dbcsr_distribution_get, dbcsr_distribution_type, dbcsr_get_info, & + dbcsr_get_matrix_type, dbcsr_get_readonly_block_p, & + dbcsr_get_stored_coordinates, dbcsr_type_antisymmetric, & + dbcsr_type_symmetric TYPE(dbcsr_p_type), INTENT(IN) :: dbcsr_mat REAL(c_double), ALLOCATABLE, DIMENSION(:, :), & INTENT(INOUT) :: dense_mat + TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env CHARACTER :: matrix_type - INTEGER :: col, col_end, col_start, icol, irow, & - nblkcols_total, nblkrows_total, ncols, & - nrows, row, row_end, row_start + INTEGER :: col, col_end, col_start, icol, irow, mynode, nblkcols_total, nblkrows_total, & + ncols, nrows, numnodes, owner, row, row_end, row_start INTEGER, ALLOCATABLE, DIMENSION(:) :: c_offset, r_offset INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size - LOGICAL :: transposed + LOGICAL :: found REAL(c_double), POINTER :: block(:, :) - TYPE(dbcsr_iterator_type) :: iter + TYPE(dbcsr_distribution_type) :: dist CALL dbcsr_get_info(dbcsr_mat%matrix, & row_blk_size=row_blk_size, & @@ -142,7 +147,9 @@ CONTAINS nblkrows_total=nblkrows_total, & nblkcols_total=nblkcols_total, & nfullrows_total=nrows, & - nfullcols_total=ncols) + nfullcols_total=ncols, & + distribution=dist) + CALL dbcsr_distribution_get(dist, mynode=mynode, numnodes=numnodes) matrix_type = dbcsr_get_matrix_type(dbcsr_mat%matrix) IF (.NOT. ALLOCATED(dense_mat)) THEN @@ -166,23 +173,19 @@ CONTAINS c_offset(col) = c_offset(col - 1) + col_blk_size(col - 1) END DO - CALL dbcsr_iterator_start(iter, dbcsr_mat%matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, irow, icol, block, transposed=transposed) - row_start = r_offset(irow) - row_end = row_start + row_blk_size(irow) - 1 - col_start = c_offset(icol) - col_end = col_start + col_blk_size(icol) - 1 - IF (transposed) THEN - dense_mat(row_start:row_end, col_start:col_end) = TRANSPOSE(block) - IF (irow /= icol) THEN - IF (matrix_type == dbcsr_type_symmetric) THEN - dense_mat(col_start:col_end, row_start:row_end) = block - ELSE IF (matrix_type == dbcsr_type_antisymmetric) THEN - dense_mat(col_start:col_end, row_start:row_end) = -block - END IF - END IF - ELSE + ! Replicated DBCSR blocks must enter the following MPI sum exactly once. + DO irow = 1, nblkrows_total + DO icol = 1, nblkcols_total + IF (numnodes == 1 .AND. para_env%num_pe > 1 .AND. para_env%mepos /= 0) CYCLE + CALL dbcsr_get_stored_coordinates(dbcsr_mat%matrix, irow, icol, owner) + IF (owner /= mynode) CYCLE + CALL dbcsr_get_readonly_block_p(matrix=dbcsr_mat%matrix, row=irow, col=icol, & + block=block, found=found) + IF (.NOT. found) CYCLE + row_start = r_offset(irow) + row_end = row_start + row_blk_size(irow) - 1 + col_start = c_offset(icol) + col_end = col_start + col_blk_size(icol) - 1 dense_mat(row_start:row_end, col_start:col_end) = block IF (irow /= icol) THEN IF (matrix_type == dbcsr_type_symmetric) THEN @@ -191,9 +194,8 @@ CONTAINS dense_mat(col_start:col_end, row_start:row_end) = -TRANSPOSE(block) END IF END IF - END IF + END DO END DO - CALL dbcsr_iterator_stop(iter) DEALLOCATE (r_offset, c_offset) @@ -572,7 +574,8 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & gauxc_status, & - mpi_comm=mp_comm_self%get_handle()) + mpi_comm=mp_comm_self%get_handle(), & + force_new_runtime=.TRUE.) CALL gauxc_check_status(gauxc_status) gauxc_integrator_fd = gauxc_create_integrator( & TRIM(xc_fun_name), & @@ -895,31 +898,36 @@ CONTAINS INTEGER, INTENT(out), OPTIONAL :: max_deriv CHARACTER(len=default_path_length) :: model_key, model_name - CHARACTER(len=default_string_length) :: xc_fun_name + CHARACTER(len=default_string_length) :: xc_fun_key, xc_fun_name LOGICAL :: native_grid CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) CALL section_vals_val_get(functional, "MODEL", c_val=model_name) CALL section_vals_val_get(functional, "NATIVE_GRID", l_val=native_grid) model_key = ADJUSTL(model_name) + xc_fun_key = ADJUSTL(xc_fun_name) CALL uppercase(model_key) + CALL uppercase(xc_fun_key) IF (PRESENT(reference)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & + TRIM(model_key) == TRIM(xc_fun_key)) THEN reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" ELSE reference = "Functional computed by GauXC Skala model "//TRIM(model_name) END IF END IF IF (PRESENT(shortform)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & + TRIM(model_key) == TRIM(xc_fun_key)) THEN shortform = "GAUXC ("//TRIM(xc_fun_name)//")" ELSE shortform = "GAUXC Skala" END IF END IF IF (PRESENT(needs)) THEN - IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "") THEN + IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "" .AND. & + TRIM(model_key) /= TRIM(xc_fun_key)) THEN IF (lsd) THEN needs%rho_spin = .TRUE. needs%drho_spin = .TRUE. @@ -961,26 +969,21 @@ CONTAINS REAL(KIND=dp), PARAMETER :: gapw_fd_gradient_dx = 1.0E-4_dp CHARACTER(len=default_path_length) :: model_key, model_name, output_path - CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, grid_key, & - grid_type, int_exec_space, lb_exec_space, lwd_kernel, pruning_key, pruning_scheme, & - radial_quadrature, skala_runtime, skala_runtime_key, xc_fun_name - INTEGER :: atom_chunk_size, batch_size, env_status, & - img, ispin, natom, nimages, nspins + CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, & + grid_key, pruning_key, skala_runtime, & + skala_runtime_key, xc_fun_key + INTEGER :: atom_chunk_size, env_status, img, ispin, & + nimages LOGICAL :: atom_chunk_size_explicit, do_kpoints, gapw_method, gapw_paw_pseudopotentials, & gapw_pseudopotentials, grid_explicit, hdf5_output, is_periodic, molecular_virial, & molecular_virial_debug, need_xc_gradient, periodic_reference, pruning_explicit, & - use_fd_gradient, use_gauxc_model, use_gradient_mpi_runtime, use_gradient_self_runtime, & - use_self_runtime, use_skala_model, write_hdf5_output - REAL(KIND=dp) :: device_runtime_fill_fraction, & - molecular_virial_debug_dx + use_skala_model, write_hdf5_output + REAL(KIND=dp) :: molecular_virial_debug_dx REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: density_scalar, density_zeta TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell - TYPE(cp_gauxc_basisset_type) :: gauxc_basis - TYPE(cp_gauxc_grid_type) :: gauxc_gradient_grid_result, & - gauxc_grid_result - TYPE(cp_gauxc_integrator_type) :: gauxc_gradient_integrator_result, gauxc_integrator_result - TYPE(cp_gauxc_molecule_type) :: gauxc_mol + TYPE(cp_gauxc_cache_params) :: params + TYPE(cp_gauxc_cache_type), POINTER :: cache TYPE(cp_gauxc_status_type) :: gauxc_status TYPE(cp_gauxc_xc_gradient_type) :: exc_grad TYPE(cp_gauxc_xc_type) :: gauxc_xc_result @@ -1023,7 +1026,7 @@ CONTAINS energy=energy, & ks_env=ks_env, & matrix_vxc=matrix_vxc, & - natom=natom, & + natom=params%natom, & atomic_kind_set=atomic_kind_set, & force=force, & para_env=para_env, & @@ -1050,7 +1053,7 @@ CONTAINS rho_ao_kp=rho_ao) nimages = dft_control%nimages - nspins = dft_control%nspins + params%nspins = dft_control%nspins is_periodic = .FALSE. IF (ASSOCIATED(cell)) is_periodic = ANY(cell%perd /= 0) @@ -1065,7 +1068,7 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "FUNCTIONAL", & - c_val=xc_fun_name) + c_val=params%xc_fun_name) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL", & @@ -1073,25 +1076,25 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "GRID", & - c_val=grid_type, & + c_val=params%grid_type, & explicit=grid_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "RADIAL_QUADRATURE", & - c_val=radial_quadrature) + c_val=params%radial_quadrature) CALL section_vals_val_get( & gauxc_functional_section, & "PRUNING_SCHEME", & - c_val=pruning_scheme, & + c_val=params%pruning_scheme, & explicit=pruning_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "BATCH_SIZE", & - i_val=batch_size) + i_val=params%batch_size) CALL section_vals_val_get( & gauxc_functional_section, & "DEVICE_RUNTIME_FILL_FRACTION", & - r_val=device_runtime_fill_fraction) + r_val=params%device_runtime_fill_fraction) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL_ATOM_CHUNK_SIZE", & @@ -1116,15 +1119,15 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "LB_EXECUTION_SPACE", & - c_val=lb_exec_space) + c_val=params%lb_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "INT_EXECUTION_SPACE", & - c_val=int_exec_space) + c_val=params%int_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "LWD_KERNEL", & - c_val=lwd_kernel) + c_val=params%lwd_kernel) CALL section_vals_val_get( & gauxc_functional_section, & "SKALA_RUNTIME", & @@ -1140,20 +1143,21 @@ CONTAINS model_key = ADJUSTL(model_name) CALL uppercase(model_key) + xc_fun_key = ADJUSTL(params%xc_fun_name) + CALL uppercase(xc_fun_key) skala_runtime_key = ADJUSTL(skala_runtime) CALL uppercase(skala_runtime_key) gradient_runtime_key = ADJUSTL(gradient_runtime) CALL uppercase(gradient_runtime_key) - use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") + params%use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & + TRIM(model_key) /= TRIM(xc_fun_key)) use_skala_model = (INDEX(TRIM(model_key), "SKALA") > 0) - IF (gapw_pseudopotentials .AND. .NOT. use_gauxc_model) THEN - CALL cp_abort(__LOCATION__, & - "GauXC with METHOD GAPW/GAPW_XC and pseudopotentials is supported only for "// & - "Skala-style models that replace the molecular XC term. "// & - "Use POTENTIAL ALL for local/semi-local GauXC GAPW validation or METHOD GPW "// & - "with pseudopotentials.") + params%model_eval_name = model_name + IF (.NOT. params%use_gauxc_model) THEN + ! MODEL NONE and MODEL equal to FUNCTIONAL select conventional GauXC. + params%model_eval_name = "NONE" END IF - IF (gapw_pseudopotentials .AND. use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & + IF (gapw_pseudopotentials .AND. params%use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & .NOT. gapw_paw_pseudopotentials .AND. para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1163,7 +1167,7 @@ CONTAINS "XC correction is used for those regular-grid kinds.") END IF END IF - IF (device_runtime_fill_fraction <= 0.0_dp .OR. device_runtime_fill_fraction > 1.0_dp) THEN + IF (params%device_runtime_fill_fraction <= 0.0_dp .OR. params%device_runtime_fill_fraction > 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "GAUXC%DEVICE_RUNTIME_FILL_FRACTION must be > 0 and <= 1.") END IF @@ -1191,21 +1195,21 @@ CONTAINS END IF END IF END IF - IF (use_gauxc_model) THEN + IF (params%use_gauxc_model) THEN IF (has_nlcc(qs_kind_set)) THEN CALL cp_abort(__LOCATION__, & "GauXC Skala with NLCC pseudopotentials is not implemented. "// & "The frozen core density would need a SKALA-consistent feature definition.") END IF END IF - IF (use_gauxc_model) THEN + IF (params%use_gauxc_model) THEN CALL set_gauxc_model_atom_chunk_env( & atom_chunk_size, atom_chunk_size_explicit) - IF (.NOT. grid_explicit) grid_type = "SUPERFINE" - IF (.NOT. pruning_explicit) pruning_scheme = "UNPRUNED" + IF (.NOT. grid_explicit) params%grid_type = "SUPERFINE" + IF (.NOT. pruning_explicit) params%pruning_scheme = "UNPRUNED" - grid_key = ADJUSTL(grid_type) - pruning_key = ADJUSTL(pruning_scheme) + grid_key = ADJUSTL(params%grid_type) + pruning_key = ADJUSTL(params%pruning_scheme) CALL uppercase(grid_key) CALL uppercase(pruning_key) IF (use_skala_model .AND. need_xc_gradient .AND. & @@ -1220,35 +1224,36 @@ CONTAINS IF (env_status /= 0 .OR. LEN_TRIM(model_name) == 0) THEN CPABORT("MODEL SKALA requires the GAUXC_SKALA_MODEL environment variable") END IF + params%model_eval_name = model_name END IF END IF SELECT CASE (TRIM(skala_runtime_key)) CASE ("AUTO") - use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. nspins > 1 + params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. params%nspins > 1 CASE ("MPI") - use_self_runtime = .FALSE. + params%use_self_runtime = .FALSE. CASE ("SELF") - use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 + params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%SKALA_RUNTIME value.") END SELECT - IF (.NOT. use_skala_model) use_self_runtime = .FALSE. + IF (.NOT. use_skala_model) params%use_self_runtime = .FALSE. SELECT CASE (TRIM(gradient_runtime_key)) CASE ("AUTO", "SELF") - use_gradient_mpi_runtime = .FALSE. - use_gradient_self_runtime = need_xc_gradient .AND. use_gauxc_model .AND. & - para_env%num_pe > 1 .AND. .NOT. use_self_runtime + params%use_gradient_mpi_runtime = .FALSE. + params%use_gradient_self_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. & + para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime CASE ("MPI") - use_gradient_mpi_runtime = need_xc_gradient .AND. use_gauxc_model .AND. para_env%num_pe > 1 - use_gradient_self_runtime = .FALSE. + params%use_gradient_mpi_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. para_env%num_pe > 1 + params%use_gradient_self_runtime = .FALSE. CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%MODEL_GRADIENT_RUNTIME value.") END SELECT - IF (.NOT. use_gauxc_model) THEN - use_gradient_mpi_runtime = .FALSE. - use_gradient_self_runtime = .FALSE. + IF (.NOT. params%use_gauxc_model) THEN + params%use_gradient_mpi_runtime = .FALSE. + params%use_gradient_self_runtime = .FALSE. END IF - IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. use_self_runtime .AND. & + IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime .AND. & para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1259,15 +1264,18 @@ CONTAINS END IF END IF - gauxc_mol = gauxc_create_molecule( & - particle_set, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) - gauxc_basis = gauxc_create_basisset( & - qs_kind_set, & - particle_set, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) + ! After creating the basisset, we will have to check max_l>3 as a further condition + params%use_fd_gradient = gapw_method .AND. need_xc_gradient + + cache => qs_env%gauxc_cache + CALL gauxc_cache_init( & + cache, & + params, & + para_env, & + particle_set, & + qs_kind_set, & + gauxc_status) + hdf5_output = (TRIM(output_path) /= "") write_hdf5_output = hdf5_output .AND. para_env%mepos == 0 IF (write_hdf5_output .AND. ASSOCIATED(scf_env)) THEN @@ -1275,98 +1283,20 @@ CONTAINS END IF IF (write_hdf5_output) THEN CALL gauxc_write_molecule_hdf5( & - gauxc_mol, & + cache%molecule, & output_path, & "molecule.h5", & "molecule", & gauxc_status) CALL gauxc_check_status(gauxc_status) CALL gauxc_write_basisset_hdf5( & - gauxc_basis, & + cache%basisset, & output_path, & "basisset.h5", & "basisset", & gauxc_status) CALL gauxc_check_status(gauxc_status) END IF - use_fd_gradient = gapw_method .AND. need_xc_gradient .AND. (gauxc_basis%max_l > 3) - IF (use_fd_gradient) use_gradient_mpi_runtime = .FALSE. - IF (use_gradient_mpi_runtime) THEN - use_gradient_self_runtime = .FALSE. - END IF - IF (use_fd_gradient .AND. para_env%mepos == 0) THEN - CALL cp_warn( & - __LOCATION__, & - "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & - "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & - "not yet reliable for this case.") - END IF - IF (use_self_runtime) THEN - ! SKALA currently needs a replicated molecular runtime for reproducible - ! open-shell densities across CP2K MPI ranks. - gauxc_grid_result = gauxc_create_grid( & - gauxc_mol, & - gauxc_basis, & - grid_type, & - radial_quadrature, & - pruning_scheme, & - lb_exec_space, & - batch_size, & - device_runtime_fill_fraction, & - gauxc_status, & - mpi_comm=mp_comm_self%get_handle()) - ELSE - ! Use the QS force-evaluation communicator rather than GauXC's global - ! runtime. In mixed CDFT the diabatic states can be built on disjoint - ! MPI subgroups; using the global communicator would make GauXC wait - ! for ranks that are working on another state. - gauxc_grid_result = gauxc_create_grid( & - gauxc_mol, & - gauxc_basis, & - grid_type, & - radial_quadrature, & - pruning_scheme, & - lb_exec_space, & - batch_size, & - device_runtime_fill_fraction, & - gauxc_status, & - mpi_comm=para_env%get_handle()) - END IF - CALL gauxc_check_status(gauxc_status) - gauxc_integrator_result = gauxc_create_integrator( & - TRIM(xc_fun_name), & - gauxc_grid_result, & - int_exec_space, & - lwd_kernel, & - nspins, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) - - IF (use_gradient_self_runtime) THEN - ! Upstream GauXC does not yet support Skala nuclear gradients - ! on an MPI runtime. Keep the energy/VXC path on the normal MPI - ! runtime and use an isolated runtime only for the replicated gradient. - gauxc_gradient_grid_result = gauxc_create_grid( & - gauxc_mol, & - gauxc_basis, & - grid_type, & - radial_quadrature, & - pruning_scheme, & - lb_exec_space, & - batch_size, & - device_runtime_fill_fraction, & - gauxc_status, & - mpi_comm=mp_comm_self%get_handle()) - CALL gauxc_check_status(gauxc_status) - gauxc_gradient_integrator_result = gauxc_create_integrator( & - TRIM(xc_fun_name), & - gauxc_gradient_grid_result, & - int_exec_space, & - lwd_kernel, & - nspins, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) - END IF IF (qs_env%run_rtp) THEN CPABORT("GAUXC XC energy currently does not support real-time propagation") @@ -1375,46 +1305,46 @@ CONTAINS energy%exc = 0 IF (ASSOCIATED(matrix_vxc)) CALL dbcsr_deallocate_matrix_set(matrix_vxc) - CALL dbcsr_allocate_matrix_set(matrix_vxc, nspins) + CALL dbcsr_allocate_matrix_set(matrix_vxc, params%nspins) DO img = 1, nimages IF (img > 1) THEN CPABORT("UNIMPLEMENTED: Handling nimg>1 in k-point integration") END IF - CALL dbcsr_to_dense(rho_ao(1, img), density_scalar) + CALL dbcsr_to_dense(rho_ao(1, img), density_scalar, para_env) CALL para_env%sum(density_scalar) - IF (nspins == 1) THEN + IF (params%nspins == 1) THEN gauxc_xc_result = gauxc_compute_xc( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & - nspins=nspins, & + nspins=params%nspins, & status=gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (use_fd_gradient) THEN + IF (params%use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, nspins, model_name, & - xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & + params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad) - ELSE IF (use_gradient_self_runtime) THEN + ELSE IF (params%use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - gauxc_gradient_integrator_result, & + cache%gradient_integrator, & density_scalar, & - nspins=nspins, & - natom=natom, & + nspins=params%nspins, & + natom=params%natom, & status=gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & - nspins=nspins, & - natom=natom, & + nspins=params%nspins, & + natom=params%natom, & status=gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1429,19 +1359,19 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & - model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & + params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) END IF DEALLOCATE (exc_grad%exc_grad) END IF ELSE - CPASSERT(nspins == 2) + CPASSERT(params%nspins == 2) ! In here: ! scalar <- rho_ao(1, :) + rho_ao(2, :) ! zeta <- rho_ao(1, :) - rho_ao(2, :) - CALL dbcsr_to_dense(rho_ao(2, img), density_zeta) + CALL dbcsr_to_dense(rho_ao(2, img), density_zeta, para_env) CALL para_env%sum(density_zeta) ! Do NOT reorder the following lines! density_scalar(:, :) = density_scalar(:, :) + density_zeta(:, :) @@ -1451,39 +1381,39 @@ CONTAINS ! This style lowers memory footprint. density_zeta(:, :) = density_scalar(:, :) - 2.0_dp*density_zeta(:, :) gauxc_xc_result = gauxc_compute_xc( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & density_zeta, & - nspins, & + params%nspins, & gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (use_fd_gradient) THEN + IF (params%use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, nspins, model_name, & - xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & + params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad, density_zeta=density_zeta) - ELSE IF (use_gradient_self_runtime) THEN + ELSE IF (params%use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - gauxc_gradient_integrator_result, & + cache%gradient_integrator, & density_scalar, & density_zeta, & - nspins, & - natom, & + params%nspins, & + params%natom, & gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & density_zeta, & - nspins, & - natom, & + params%nspins, & + params%natom, & gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1498,10 +1428,10 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & - model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & + params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & density_zeta=density_zeta) END IF DEALLOCATE (exc_grad%exc_grad) @@ -1510,14 +1440,14 @@ CONTAINS energy%exc = energy%exc + gauxc_xc_result%exc - IF (nspins == 1) THEN + IF (params%nspins == 1) THEN IF (img == 1) THEN matrix_vxc(1) = dense_to_dbcsr(gauxc_xc_result%vxc_scalar, rho_ao(1, img)) ELSE CPABORT("UNIMPLEMENTED: Handling multiple result matrices in k-point integration") END IF ELSE - CPASSERT(nspins == 2) + CPASSERT(params%nspins == 2) ! Transform derivatives from total/spin density back to alpha/beta channels. vxc_zeta_tmp = dense_to_dbcsr(gauxc_xc_result%vxc_zeta, rho_ao(1, img)) IF (img == 1) THEN @@ -1544,25 +1474,10 @@ CONTAINS IF (ALLOCATED(gauxc_xc_result%vxc_zeta)) DEALLOCATE (gauxc_xc_result%vxc_zeta) CALL set_ks_env(ks_env, matrix_vxc=matrix_vxc) - DO ispin = 1, nspins + DO ispin = 1, params%nspins CALL dbcsr_finalize(matrix_vxc(ispin)%matrix) END DO - IF (use_gradient_self_runtime) THEN - CALL gauxc_destroy_integrator(gauxc_gradient_integrator_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_grid(gauxc_gradient_grid_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - END IF - CALL gauxc_destroy_integrator(gauxc_integrator_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_grid(gauxc_grid_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_basisset(gauxc_basis, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_molecule(gauxc_mol, gauxc_status) - CALL gauxc_check_status(gauxc_status) - END SUBROUTINE apply_gauxc END MODULE xc_gauxc_functional diff --git a/src/xc/xc_gauxc_interface.F b/src/xc/xc_gauxc_interface.F index ed1356ebde..dadfbc0c99 100644 --- a/src/xc/xc_gauxc_interface.F +++ b/src/xc/xc_gauxc_interface.F @@ -506,6 +506,7 @@ CONTAINS !> \param device_runtime_fill_fraction ... !> \param status ... !> \param mpi_comm optional communicator for a grid-local GauXC runtime +!> \param force_new_runtime force creation of a grid-local GauXC runtime !> \return ... ! ************************************************************************************************** FUNCTION gauxc_create_grid( & @@ -518,7 +519,8 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & status, & - mpi_comm) RESULT(res) + mpi_comm, & + force_new_runtime) RESULT(res) TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule TYPE(cp_gauxc_basisset_type), INTENT(in) :: basis @@ -528,13 +530,14 @@ CONTAINS REAL(c_double), INTENT(IN) :: device_runtime_fill_fraction TYPE(cp_gauxc_status_type), INTENT(OUT) :: status INTEGER, INTENT(IN), OPTIONAL :: mpi_comm + LOGICAL, INTENT(IN), OPTIONAL :: force_new_runtime TYPE(cp_gauxc_grid_type) :: res #ifdef __GAUXC INTEGER(c_int) :: grid_type_local, int_exec_space_local, & lb_exec_space_local, & pruning_scheme_local, radial_quad_local - LOGICAL :: use_device_runtime + LOGICAL :: force_new_runtime_local, use_device_runtime grid_type_local = read_atomic_grid_size(grid_type) radial_quad_local = read_radial_quad(radial_quadrature) @@ -542,6 +545,8 @@ CONTAINS lb_exec_space_local = read_execution_space(lb_exec_space) int_exec_space_local = read_execution_space("host") use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device) + force_new_runtime_local = .FALSE. + IF (PRESENT(force_new_runtime)) force_new_runtime_local = force_new_runtime res%owns_rt = .FALSE. IF (use_device_runtime) THEN @@ -570,7 +575,8 @@ CONTAINS IF (PRESENT(mpi_comm)) THEN ! Reuse the global runtime when the requested communicator matches ! the communicator used during gauxc_init. - IF (.NOT. rt_has_mpi_comm .OR. mpi_comm /= rt_mpi_comm) THEN + IF (force_new_runtime_local .OR. .NOT. rt_has_mpi_comm .OR. & + mpi_comm /= rt_mpi_comm) THEN res%rt = gauxc_runtime_environment_new(status%status, mpi_comm) GAUXC_RETURN_IF_ERROR(status) res%owns_rt = .TRUE. @@ -578,6 +584,7 @@ CONTAINS END IF #else MARK_USED(mpi_comm) + MARK_USED(force_new_runtime) #endif END IF @@ -637,6 +644,7 @@ CONTAINS MARK_USED(grid_type) MARK_USED(lb_exec_space) MARK_USED(mpi_comm) + MARK_USED(force_new_runtime) MARK_USED(molecule) MARK_USED(pruning_scheme) MARK_USED(radial_quadrature) @@ -809,10 +817,6 @@ CONTAINS END IF IF (nspins == 1) THEN - ! xmat factor 2 is applied by both CP2K and GauXC - ! "unapply" it here to even things back out. - ! This is NOT necessary in the Skala branch. - density_scalar = 0.5_dp*density_scalar CALL gauxc_integrator_eval_exc_vxc_rks( & status%status, & integrator%integrator, & diff --git a/src/xc/xc_libxc.F b/src/xc/xc_libxc.F index 3faed929f3..4c58f994a0 100644 --- a/src/xc/xc_libxc.F +++ b/src/xc/xc_libxc.F @@ -307,9 +307,11 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) + SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & + func_name_override) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -317,6 +319,7 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -326,8 +329,13 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -398,6 +406,7 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & @@ -415,9 +424,11 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) + SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & + func_name_override) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -425,6 +436,7 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -434,8 +446,13 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -508,6 +525,7 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are "// & "asking for a functional of the LibXC library, "// & @@ -542,14 +560,16 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params) + SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_eval' @@ -574,15 +594,22 @@ CONTAINS NULLIFY (dummy) NULLIFY (rho, norm_drho, laplace_rho, tau) - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_UNPOLARIZED) xc_info = xc_f03_func_get_info(xc_func) - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + no_exc = .FALSE. + IF (.NOT. PRESENT(func_name_override)) & + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rho=rho, norm_drho=norm_drho, laplace_rho=laplace_rho, & @@ -762,6 +789,7 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & "you have to download and install the library!") @@ -777,14 +805,16 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params) + SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_eval' @@ -823,15 +853,22 @@ CONTAINS NULLIFY (rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, laplace_rhoa, & laplace_rhob, tau_a, tau_b) - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_POLARIZED) xc_info = xc_f03_func_get_info(xc_func) - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + no_exc = .FALSE. + IF (.NOT. PRESENT(func_name_override)) & + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, & @@ -1290,6 +1327,7 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & diff --git a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md index c7e9b8747a..b369135c48 100644 --- a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md +++ b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md @@ -20,6 +20,8 @@ used to move towards making accurate XC integration the GAPW default in a future | DC-DFT/Energy Correction | `regtest-acc-2/HF-ec1.inp`, `HF-ec2.inp`, `HF-ec3.inp` | `HF-ec4.inp`, `HF-ec5.inp`, `HF-ec6.inp`, and `HF-ec7.inp` now also use explicit accurate integration | | TDDFPT forces | `regtest-acc-5/h2o_f01.inp` | `regtest-acc-5/h2o_f01_fine.inp` | | ADMM-GAPW TDDFPT response | `regtest-acc-5/ft3.inp` | `regtest-acc-5/ft3_fine.inp` | +| UZH basis/potential data | all-electron UZH HF force-debug tests in `regtest-acc-1` | GAPW all-electron and GAPW/GAPW_XC GTH finite-difference force and stress checks with `BASIS_MOLOPT_UZH` and `POTENTIAL_UZH` | +| def2-ECP data | def2-SVP ECP GAPW energy checks in `regtest-ecp` and `regtest-ecp-2` | GAPW mixed all-electron/ECP and GAPW_XC ECP-only finite-difference force and stress checks | | XAS/RT response | XAS_TDP and RTBSE coverage in `regtest-xastdp` and `regtest-rtbse` | open-shell GAPW XAS_TDP and GAPW RTBSE smoke tests in `regtest-acc-3` | | KG embedding | existing `regtest-kg` GPW cases | GAPW/GAPW_XC energy and stress checks for libxc KG, meta-GGA/tau KG, and RI embedding | | KG atomic potential | `regtest-kg/H2_KG-1.inp` | GAPW/GAPW_XC energy and stress checks for `TNADD_METHOD ATOMIC` | @@ -55,6 +57,16 @@ Finite-difference checks with `STOP_ON_MISMATCH` are included for: is kept diagonal in the targeted debug tests above. - GAPW_XC forces and diagonal stress: `regtest-acc-1/h2o-gapw_xc-force-1.inp`, `regtest-acc-1/h2o-gapw_xc-stress-debug-1.inp`. +- UZH all-electron GAPW forces and analytical stress smoke: + `regtest-acc-1/h2o-uzh-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp`. +- UZH GTH GAPW/GAPW_XC forces and analytical stress smoke: + `regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp`, + `regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp`, and + `regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp`. +- ECP GAPW/GAPW_XC targeted force and analytical stress smoke checks: + `regtest-ecp/ICl_lanl2dz_gapw_force.inp`, `ICl_lanl2dz_gapw_stress.inp`, + `ICl_lanl2dz_gapw_xc_force.inp`, and `ICl_lanl2dz_gapw_xc_stress.inp`; the def2-ECP energy path + remains covered by `regtest-ecp/SbH3_def2_gapw.inp`. - ADMM-GAPW forces: `regtest-acc-1/HF-d5.inp`, `regtest-acc-5/ft3_fine.inp`. - ADMM-GAPW diagonal stress: `regtest-acc-2/h2o-admm-gapw-stress-debug-1.inp`, `regtest-acc-2/h2o-admm-gapw-pbe-stress-debug-1.inp`. diff --git a/tests/QS/regtest-acc-1/TEST_FILES.toml b/tests/QS/regtest-acc-1/TEST_FILES.toml index 41e4817c71..d26801d538 100644 --- a/tests/QS/regtest-acc-1/TEST_FILES.toml +++ b/tests/QS/regtest-acc-1/TEST_FILES.toml @@ -36,4 +36,10 @@ "h2o-gapw_xc-stress-debug-1.inp" = [] "h2o-gapw_xc-full-stress-1.inp" = [{matcher="M011", tol=1e-08, ref=-17.256333793570239}, {matcher="M031", tol=1e-08, ref=3.91898639036E+03}] +"h2o-uzh-gapw-force-1.inp" = [] +"h2o-uzh-gapw-stress-debug-1.inp" = [] +"h2o-uzh-gth-gapw-force-1.inp" = [] +"h2o-uzh-gth-gapw-stress-debug-1.inp" = [] +"h2o-uzh-gth-gapw_xc-force-1.inp" = [] +"h2o-uzh-gth-gapw_xc-stress-debug-1.inp" = [] #EOF diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp new file mode 100644 index 0000000000..9e6684b46a --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp @@ -0,0 +1,63 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gapw-force-1 + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &KIND O + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp new file mode 100644 index 0000000000..920bbbf7a1 --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp @@ -0,0 +1,60 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gapw-stress-debug-1 + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &KIND O + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp new file mode 100644 index 0000000000..924f9670d2 --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp @@ -0,0 +1,67 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw-force-1 + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp new file mode 100644 index 0000000000..3c80d1546e --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp @@ -0,0 +1,64 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw-stress-debug-1 + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp new file mode 100644 index 0000000000..412457eafe --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp @@ -0,0 +1,69 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw_xc-force-1 + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp new file mode 100644 index 0000000000..5bceffa537 --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp @@ -0,0 +1,66 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw_xc-stress-debug-1 + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp new file mode 100644 index 0000000000..35a8618cc7 --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp @@ -0,0 +1,62 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_force + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp new file mode 100644 index 0000000000..aa73463cd3 --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp @@ -0,0 +1,59 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_stress + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp new file mode 100644 index 0000000000..a1fd01ce1e --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp @@ -0,0 +1,64 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_xc_force + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 6.0 0.0 0.0 + B 0.25 6.1 0.0 + C 0.15 0.35 6.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp new file mode 100644 index 0000000000..b94b1a47a1 --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp @@ -0,0 +1,61 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_xc_stress + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 6.0 0.0 0.0 + B 0.25 6.1 0.0 + C 0.15 0.35 6.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/TEST_FILES.toml b/tests/QS/regtest-ecp/TEST_FILES.toml index 77e7b87d8e..914bf20fb4 100644 --- a/tests/QS/regtest-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-ecp/TEST_FILES.toml @@ -3,3 +3,7 @@ "SbH3_def2_gapw.inp" = [{matcher="M011", tol=1.0E-11, ref=-241.414769303399083}] "HCl_ccECP.inp" = [{matcher="M011", tol=1.0E-12, ref=-15.457709431781252}] "HCl_force.inp" = [] +"ICl_lanl2dz_gapw_force.inp" = [] +"ICl_lanl2dz_gapw_stress.inp" = [] +"ICl_lanl2dz_gapw_xc_force.inp" = [] +"ICl_lanl2dz_gapw_xc_stress.inp" = [] diff --git a/tests/QS/regtest-gauxc-api/TEST_FILES.toml b/tests/QS/regtest-gauxc-api/TEST_FILES.toml index c03ead6223..e9ee7d1cee 100644 --- a/tests/QS/regtest-gauxc-api/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-api/TEST_FILES.toml @@ -1,7 +1,7 @@ "1H2_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163125608332391}] "1H2_GAUXC_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] -"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121899608445}] +"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] "NH3_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722432805445091}] -"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722558568119791}] +"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722557896081605}] "OH_GAUXC_MODEL_PBE_UKS.inp" = [{matcher="E_total", tol=5e-6, ref=-16.541584062034670}] "CH4_DIMER_GAUXC_PBE_D3.inp" = [{matcher="M033", tol=1e-14, ref=-0.00355123783846}] diff --git a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml index 3bd87ffe71..db816e3a27 100644 --- a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml @@ -1,11 +1,11 @@ "H2_PBE_CDFT_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157232743213941}, {matcher="M071", tol=1e-8, ref=0.197625731046}] -"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229554329094}, +"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229340943540}, {matcher="M071", tol=1e-8, ref=0.197624070585}] "H2_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.216557647288}] "H2_GAPW_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.217417757774}] "H2_PBE_CDFT_CI_REFERENCE.inp" = [{matcher="M073", tol=1e-8, ref=345.364329058819}, {matcher="M077", tol=1e-8, ref=-1.16295181842678}] -"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325437357859}, - {matcher="M077", tol=1e-8, ref=-1.16294823026735}] +"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325380057211}, + {matcher="M077", tol=1e-8, ref=-1.16294801624740}] "H2_SKALA_CDFT_CI.inp" = [{matcher="M077", tol=5e-8, ref=-1.39020335005227}] diff --git a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml index 274511571a..babec12d78 100644 --- a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml @@ -1,8 +1,8 @@ "HCl_GAPW_SKALA_ECP_ENERGY.inp" = [{matcher="E_total", tol=5e-6, ref=-15.464581508021762}] -"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.45263701}] +"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44142596263930}] "HCl_NATIVE_SKALA_GAPW_GPWTYPE_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36078871}] -"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36291913}] +"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.35170807520943}] "H2_NATIVE_SKALA_GAPW_ECP_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=6e-1, ref=0.0}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] diff --git a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml index 80fac5377e..dea40ed44e 100644 --- a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml @@ -1,3 +1,3 @@ -"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] diff --git a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml index 300b8bb9d2..fbeaab6fca 100644 --- a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml @@ -1,8 +1,8 @@ -"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833172}] -"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833169}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] "H2_NATIVE_SKALA_GAPW_GPWTYPE_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="M072", tol=1e-4, ref=5.37252718E-05}, {matcher="M031", tol=1e-5, ref=-8.58976831594E+04}] -"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9698629747}] +"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.94877811114650}] "H2_NATIVE_SKALA_GAPW_GTH_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=2e-1, ref=0.0}] "H2_NATIVE_SKALA_GAPW_GTH_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=2e-1, ref=0.0}] diff --git a/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch b/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch index c129f3c11c..62a7ddf812 100644 --- a/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch +++ b/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch @@ -1,8 +1,11 @@ diff --git a/cmake/gauxc-config.cmake.in b/cmake/gauxc-config.cmake.in -index c6c4c2d4..35e426af 100644 +index c6c4c2d4..b517ccc5 100644 --- a/cmake/gauxc-config.cmake.in +++ b/cmake/gauxc-config.cmake.in -@@ -8,0 +9,8 @@ include(CMakeFindDependencyMacro) +@@ -6,6 +6,14 @@ list(PREPEND CMAKE_MODULE_PATH ${GauXC_CMAKE_DIR} ) + list(PREPEND CMAKE_MODULE_PATH ${GauXC_CMAKE_DIR}/linalg-cmake-modules ) + include(CMakeFindDependencyMacro) + +if(POLICY CMP0144) + cmake_policy(PUSH) + cmake_policy(SET CMP0144 NEW) @@ -11,7 +14,13 @@ index c6c4c2d4..35e426af 100644 + endif() + set(CMAKE_POLICY_DEFAULT_CMP0144 NEW) +endif() -@@ -93,0 +102,9 @@ endif() + # Always Required Dependencies + find_dependency( ExchCXX ) + find_dependency( IntegratorXX ) +@@ -91,4 +99,13 @@ if(NOT TARGET gauxc::gauxc) + include("${GauXC_CMAKE_DIR}/gauxc-targets.cmake") + endif() + +if(POLICY CMP0144) + if(DEFINED _GAUXC_PREV_CMAKE_POLICY_DEFAULT_CMP0144) + set(CMAKE_POLICY_DEFAULT_CMP0144 "${_GAUXC_PREV_CMAKE_POLICY_DEFAULT_CMP0144}") @@ -21,33 +30,7 @@ index c6c4c2d4..35e426af 100644 + unset(_GAUXC_PREV_CMAKE_POLICY_DEFAULT_CMP0144) + cmake_policy(POP) +endif() -diff --git a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h ---- a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h -+++ b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h -@@ -14,0 +15,8 @@ -+#if (defined(__GNUC__) || defined(__GNUG__)) && \ -+ !defined(__APPLE__) && !defined(__clang__) -+static inline void* gg_aligned_alloc(const size_t alignment, const size_t size) { -+ const size_t aligned_size = -+ ((size + alignment - 1) / alignment) * alignment; -+ return aligned_alloc(alignment, aligned_size); -+} -+#endif -@@ -15,0 +24 @@ -+ -@@ -70 +79 @@ -- #define ALIGNED_MALLOC(alignment, size) aligned_alloc(alignment, size) -+ #define ALIGNED_MALLOC(alignment, size) gg_aligned_alloc(alignment, size) -diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt -index a9e60fd8..29b0949d 100644 ---- a/src/CMakeLists.txt -+++ b/src/CMakeLists.txt -@@ -122,1 +122,4 @@ if ( GAUXC_HAS_ONEDFT ) -- target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}" nlohmann_json::nlohmann_json) -+ get_target_property(GAUXC_NLOHMANN_JSON_INCLUDE_DIRS -+ nlohmann_json::nlohmann_json INTERFACE_INCLUDE_DIRECTORIES) -+ target_include_directories(gauxc PRIVATE ${GAUXC_NLOHMANN_JSON_INCLUDE_DIRS}) -+ target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}") + set(GauXC_LIBRARIES gauxc::gauxc) diff --git a/cmake/gauxc-exchcxx.cmake b/cmake/gauxc-exchcxx.cmake index 412df9b3..011ae844 100644 --- a/cmake/gauxc-exchcxx.cmake @@ -98,6 +81,129 @@ index b6bbbf0e..502067d2 100644 + endif() +endif() +diff --git a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h +index f6033886..4bbbf13f 100644 +--- a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h ++++ b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h +@@ -14,0 +15,9 @@ ++#if (defined(__GNUC__) || defined(__GNUG__)) && \ ++ !defined(__APPLE__) && !defined(__clang__) ++static inline void* gg_aligned_alloc(const size_t alignment, const size_t size) { ++ const size_t aligned_size = ++ ((size + alignment - 1) / alignment) * alignment; ++ return aligned_alloc(alignment, aligned_size); ++} ++#endif ++ +@@ -67,7 +76,7 @@ + #elif defined(__GNUC__) || defined(__GNUG__) + // pragmas for GCC + +- #define ALIGNED_MALLOC(alignment, size) aligned_alloc(alignment, size) ++ #define ALIGNED_MALLOC(alignment, size) gg_aligned_alloc(alignment, size) + #define ALIGNED_FREE(ptr) free(ptr) + #define ASSUME_ALIGNED(ptr, width) + +diff --git a/include/gauxc/xc_integrator_settings.hpp b/include/gauxc/xc_integrator_settings.hpp +index a63899e6..9031be78 100644 +--- a/include/gauxc/xc_integrator_settings.hpp ++++ b/include/gauxc/xc_integrator_settings.hpp +@@ -23,6 +23,9 @@ struct IntegratorSettingsSNLinK : public IntegratorSettingsEXX { + struct IntegratorSettingsXC { virtual ~IntegratorSettingsXC() noexcept = default; }; + struct IntegratorSettingsKS : public IntegratorSettingsXC { + double gks_dtol = 1e-12; ++ // RKS density matrices are interpreted as one-spin densities by default. ++ // Set this when the caller provides the spin-summed closed-shell density. ++ bool rks_density_matrix_is_spin_summed = false; + }; + + struct OneDFTSettings : public IntegratorSettingsXC { +diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt +index a9e60fd8..29b0949d 100644 +--- a/src/CMakeLists.txt ++++ b/src/CMakeLists.txt +@@ -119,7 +119,10 @@ if( GAUXC_HAS_MPI ) + endif() + + if ( GAUXC_HAS_ONEDFT ) +- target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}" nlohmann_json::nlohmann_json) ++ get_target_property(GAUXC_NLOHMANN_JSON_INCLUDE_DIRS ++ nlohmann_json::nlohmann_json INTERFACE_INCLUDE_DIRECTORIES) ++ target_include_directories(gauxc PRIVATE ${GAUXC_NLOHMANN_JSON_INCLUDE_DIRS}) ++ target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}") + endif() + + add_subdirectory( runtime_environment ) +diff --git a/src/c-api/c_xc_integrator.cxx b/src/c-api/c_xc_integrator.cxx +index 534eb3d0..f1efc430 100644 +--- a/src/c-api/c_xc_integrator.cxx ++++ b/src/c-api/c_xc_integrator.cxx +@@ -200,12 +200,14 @@ void gauxc_integrator_eval_exc_rks( + detail::gauxc_status_handle(status, 1, "Exc output pointer cannot be null"); + return; + } ++ IntegratorSettingsKS ks_settings{}; ++ ks_settings.rks_density_matrix_is_spin_summed = true; + try { + detail::get_xc_integrator_ptr(integrator)->eval_exc( + m, n, + density_matrix, ldp, + exc, +- IntegratorSettingsXC{} ); ++ ks_settings ); + } catch (std::exception& e) { + detail::gauxc_status_handle(status, 1, e.what()); + } +@@ -333,13 +335,15 @@ void gauxc_integrator_eval_exc_vxc_rks( + detail::gauxc_status_handle(status, 1, "VXC matrix pointer cannot be null"); + return; + } ++ IntegratorSettingsKS ks_settings{}; ++ ks_settings.rks_density_matrix_is_spin_summed = true; + try { + detail::get_xc_integrator_ptr(integrator)->eval_exc_vxc( + m, n, + density_matrix, ldp, + vxc_matrix, vxc_ld, + exc, +- IntegratorSettingsXC{} ); ++ ks_settings ); + } catch (std::exception& e) { + detail::gauxc_status_handle(status, 1, e.what()); + } +@@ -565,12 +569,14 @@ void gauxc_integrator_eval_exc_grad_rks( + detail::gauxc_status_handle(status, 1, "Exc gradient output pointer cannot be null"); + return; + } ++ IntegratorSettingsEXC_GRAD exc_grad_settings{}; ++ exc_grad_settings.rks_density_matrix_is_spin_summed = true; + try { + detail::get_xc_integrator_ptr(integrator)->eval_exc_grad( + m, n, + density_matrix, ldp, + exc_grad, +- IntegratorSettingsXC{} ); ++ exc_grad_settings ); + } catch (std::exception& e) { + detail::gauxc_status_handle(status, 1, e.what()); + } +@@ -726,13 +732,15 @@ void gauxc_integrator_eval_fxc_contraction_rks( + detail::gauxc_status_handle(status, 1, "FXC output pointer cannot be null"); + return; + } ++ IntegratorSettingsKS ks_settings{}; ++ ks_settings.rks_density_matrix_is_spin_summed = true; + try { + detail::get_xc_integrator_ptr(integrator)->eval_fxc_contraction( + m, n, + density_matrix, ldp, + t_density_matrix, ldtp, + fxc, ldfxc, +- IntegratorSettingsXC{} ); ++ ks_settings ); + } catch (std::exception& e) { + detail::gauxc_status_handle(status, 1, e.what()); + } diff --git a/src/xc_integrator/local_work_driver/factory.cxx b/src/xc_integrator/local_work_driver/factory.cxx index fd6b86ad..3547e1d3 100644 --- a/src/xc_integrator/local_work_driver/factory.cxx @@ -135,3 +241,443 @@ index fd6b86ad..3547e1d3 100644 (void)(settings); switch(ex) { +diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp +index 1287835e..91027539 100644 +--- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp ++++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp +@@ -128,7 +128,8 @@ protected: + const value_type* Py, int64_t ldpy, + const value_type* Px, int64_t ldpx, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data, bool do_vxc ); ++ XCDeviceData& device_data, bool do_vxc, ++ const IntegratorSettingsXC& settings ); + + void exc_vxc_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, + const value_type* Pz, int64_t ldpz, +@@ -139,7 +140,7 @@ protected: + value_type* VXCy, int64_t ldvxcy, + value_type* VXCx, int64_t ldvxcx, value_type* EXC, value_type *N_EL, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data ); ++ XCDeviceData& device_data, const IntegratorSettingsXC& settings ); + + void pre_onedft_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, + const value_type* Pz, int64_t ldpz, +@@ -159,7 +160,7 @@ protected: + const value_type* tPs, int64_t ldtps, + const value_type* tPz, int64_t ldtpz, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data); ++ XCDeviceData& device_data, const IntegratorSettingsXC& settings); + + void fxc_contraction_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, + const value_type* Pz, int64_t ldpz, +@@ -169,7 +170,7 @@ protected: + value_type* FXCs, int64_t ldfxcs, + value_type* FXCz, int64_t ldfxcz, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data ); ++ XCDeviceData& device_data, const IntegratorSettingsXC& settings ); + + void eval_exc_grad_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, + const value_type* Pz, int64_t ldpz, +diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp +index 9a2a7cf4..b6f4a3da 100644 +--- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp ++++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp +@@ -59,7 +59,7 @@ void IncoreReplicatedXCDeviceIntegrator:: + exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, + // Passing nullptr for VXCs disables VXC entirely + nullptr, 0, nullptr, 0, nullptr, 0, nullptr, 0, EXC, &N_EL, +- tasks.begin(), tasks.end(), *device_data_ptr); ++ tasks.begin(), tasks.end(), *device_data_ptr, settings); + }); + + GAUXC_MPI_CODE( +@@ -100,4 +100,3 @@ void IncoreReplicatedXCDeviceIntegrator:: + + } + } +- +diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp +index 6c030bc2..15230d68 100644 +--- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp ++++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp +@@ -168,6 +168,10 @@ void IncoreReplicatedXCDeviceIntegrator:: + IntegratorSettingsEXC_GRAD exc_grad_settings; + if( auto* tmp = dynamic_cast(&settings) ) { + exc_grad_settings = *tmp; ++ } else if( auto* ks_tmp = dynamic_cast(&settings) ) { ++ exc_grad_settings.gks_dtol = ks_tmp->gks_dtol; ++ exc_grad_settings.rks_density_matrix_is_spin_summed = ++ ks_tmp->rks_density_matrix_is_spin_summed; + } + + // Check that Partition Weights have been calculated +@@ -221,7 +225,8 @@ void IncoreReplicatedXCDeviceIntegrator:: + else lwd->eval_collocation_gradient( &device_data ); + + // Evaluate X matrix and V vars +- const auto xmat_fac = is_rks ? 2.0 : 1.0; ++ const auto xmat_fac = ++ (is_rks and not exc_grad_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; + const auto need_lapl = func.needs_laplacian(); + const auto need_xmat_grad = not func.is_lda(); + auto do_xmat_vvar = [&](density_id den_id) { +diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp +index 6a27521d..42723b94 100644 +--- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp ++++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp +@@ -110,8 +110,8 @@ void IncoreReplicatedXCDeviceIntegrator:: + // If we can do reductions on the device (e.g. NCCL) + // Don't communicate data back to the host before reduction + this->timer_.time_op("XCIntegrator.LocalWork_EXC_VXC", [&](){ +- exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, tasks.begin(), tasks.end(), +- *device_data_ptr, true); ++ exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, tasks.begin(), tasks.end(), ++ *device_data_ptr, true, settings); + }); + + GAUXC_MPI_CODE( +@@ -177,7 +177,7 @@ void IncoreReplicatedXCDeviceIntegrator:: + this->timer_.time_op("XCIntegrator.LocalWork_EXC_VXC", [&](){ + exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, + VXCs, ldvxcs, VXCz, ldvxcz, VXCy, ldvxcy, VXCx, ldvxcx, EXC, +- &N_EL, tasks.begin(), tasks.end(), *device_data_ptr); ++ &N_EL, tasks.begin(), tasks.end(), *device_data_ptr, settings); + }); + + GAUXC_MPI_CODE( +@@ -225,7 +225,8 @@ void IncoreReplicatedXCDeviceIntegrator:: + const value_type* Py, int64_t ldpy, + const value_type* Px, int64_t ldpx, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data, bool do_vxc ) { ++ XCDeviceData& device_data, bool do_vxc, ++ const IntegratorSettingsXC& settings ) { + const bool is_gks = (Pz != nullptr) and (Py != nullptr) and (Px != nullptr); + const bool is_uks = (Pz != nullptr) and (Py == nullptr) and (Px == nullptr); + const bool is_rks = (Ps != nullptr) and (not is_uks and not is_gks); +@@ -243,6 +244,11 @@ void IncoreReplicatedXCDeviceIntegrator:: + + if( func.is_mgga() and is_gks ) GAUXC_GENERIC_EXCEPTION("GKS mGGAs NYI!"); + ++ IntegratorSettingsKS ks_settings; ++ if( auto* tmp = dynamic_cast(&settings) ) { ++ ks_settings = *tmp; ++ } ++ + // Get basis map + BasisSetMap basis_map(basis,mol); + +@@ -312,7 +318,8 @@ void IncoreReplicatedXCDeviceIntegrator:: + else if( func.is_gga() ) lwd->eval_collocation_gradient( &device_data ); + else lwd->eval_collocation( &device_data ); + +- const double xmat_fac = is_rks ? 2.0 : 1.0; ++ const double xmat_fac = ++ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; + const bool need_xmat_grad = func.is_mgga(); + + // Evaluate X matrix and V vars +@@ -396,11 +403,12 @@ void IncoreReplicatedXCDeviceIntegrator:: + value_type* VXCy, int64_t ldvxcy, + value_type* VXCx, int64_t ldvxcx, value_type* EXC, value_type *N_EL, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data ) { ++ XCDeviceData& device_data, const IntegratorSettingsXC& settings ) { + + // Get integrate and keep data on device + const bool do_vxc = VXCs; +- exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, task_begin, task_end, device_data, do_vxc ); ++ exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, ++ task_begin, task_end, device_data, do_vxc, settings ); + auto rt = detail::as_device_runtime(this->load_balancer_->runtime()); + rt.device_backend()->master_queue_synchronize(); + +@@ -414,4 +422,3 @@ void IncoreReplicatedXCDeviceIntegrator:: + + } + } +- +diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp +index ffc0ca41..0b813924 100644 +--- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp ++++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp +@@ -85,7 +85,7 @@ namespace GauXC::detail { + // Don't communicate data back to the host before reduction + this->timer_.time_op("XCIntegrator.LocalWork_FXC", [&](){ + fxc_contraction_local_work_( basis, Ps, ldps, Pz, ldpz, tPs, ldtps, tPz, ldtpz, +- tasks.begin(), tasks.end(), *device_data_ptr); ++ tasks.begin(), tasks.end(), *device_data_ptr, ks_settings); + }); + + GAUXC_MPI_CODE( +@@ -127,7 +127,8 @@ namespace GauXC::detail { + // data from device + this->timer_.time_op("XCIntegrator.LocalWork_FXC", [&](){ + fxc_contraction_local_work_( basis, Ps, ldps, Pz, ldpz, tPs, ldtps, tPz, ldtpz, &N_EL, +- FXCs, ldfxcs, FXCz, ldfxcz, tasks.begin(), tasks.end(), *device_data_ptr); ++ FXCs, ldfxcs, FXCz, ldfxcz, tasks.begin(), tasks.end(), *device_data_ptr, ++ ks_settings); + }); + + GAUXC_MPI_CODE( +@@ -160,7 +161,7 @@ namespace GauXC::detail { + const value_type* tPs, int64_t ldtps, + const value_type* tPz, int64_t ldtpz, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data) { ++ XCDeviceData& device_data, const IntegratorSettingsXC& settings) { + const bool is_uks = (Pz != nullptr); + const bool is_rks = !is_uks; + if (not is_rks and not is_uks) { +@@ -175,6 +176,11 @@ namespace GauXC::detail { + const auto& func = *this->func_; + const auto& mol = this->load_balancer_->molecule(); + ++ IntegratorSettingsKS ks_settings; ++ if( auto* tmp = dynamic_cast(&settings) ) { ++ ks_settings = *tmp; ++ } ++ + // Get basis map + BasisSetMap basis_map(basis,mol); + +@@ -243,7 +249,8 @@ namespace GauXC::detail { + else if( func.is_gga() ) lwd->eval_collocation_gradient( &device_data ); + else lwd->eval_collocation( &device_data ); + +- const double xmat_fac = is_rks ? 2.0 : 1.0; ++ const double xmat_fac = ++ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; + const bool need_xmat_grad = func.is_mgga(); + + // Evaluate X matrix and V vars +@@ -327,11 +334,11 @@ namespace GauXC::detail { + value_type* FXCs, int64_t ldfxcs, + value_type* FXCz, int64_t ldfxcz, + host_task_iterator task_begin, host_task_iterator task_end, +- XCDeviceData& device_data ) { ++ XCDeviceData& device_data, const IntegratorSettingsXC& settings ) { + + // Get integrate and keep data on device + fxc_contraction_local_work_( basis, Ps, ldps, Pz, ldpz, tPs, ldtps, tPz, ldtpz, +- task_begin, task_end, device_data); ++ task_begin, task_end, device_data, settings); + auto rt = detail::as_device_runtime(this->load_balancer_->runtime()); + rt.device_backend()->master_queue_synchronize(); + +diff --git a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp +index f04ae24b..b3c5db95 100644 +--- a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp ++++ b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp +@@ -126,6 +126,10 @@ void ReferenceReplicatedXCHostIntegrator:: + IntegratorSettingsEXC_GRAD exc_grad_settings; + if( auto* tmp = dynamic_cast(&settings) ) { + exc_grad_settings = *tmp; ++ } else if( auto* ks_tmp = dynamic_cast(&settings) ) { ++ exc_grad_settings.gks_dtol = ks_tmp->gks_dtol; ++ exc_grad_settings.rks_density_matrix_is_spin_summed = ++ ks_tmp->rks_density_matrix_is_spin_summed; + } + + // Get basis map +@@ -330,7 +334,8 @@ void ReferenceReplicatedXCHostIntegrator:: + + // Evaluate X matrix (2 * P * B/Bx/By/Bz) -> store in Z + // XXX: This assumes that bfn + gradients are contiguous in memory +- const auto xmat_fac = is_rks ? 2.0 : 1.0; ++ const auto xmat_fac = ++ (is_rks and not exc_grad_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; + const int xmat_len = func.is_lda() ? 1 : 4; + lwd->eval_xmat( xmat_len*npts, nbf, nbe, submat_map, xmat_fac, Ps, ldps, basis_eval, nbe, + xNmat, nbe, nbe_scr ); +diff --git a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp +index 29878c50..94774eb5 100644 +--- a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp ++++ b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp +@@ -385,7 +385,8 @@ void ReferenceReplicatedXCHostIntegrator:: + + + // Evaluate X matrix (fac * P * B) -> store in Z +- const auto xmat_fac = is_rks ? 2.0 : 1.0; // TODO Fix for spinor RKS input ++ const auto xmat_fac = ++ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; + lwd->eval_xmat( mgga_dim_scal * npts, nbf, nbe, submat_map, xmat_fac, Ps, ldps, basis_eval, nbe, + zmat, nbe, nbe_scr ); + +diff --git a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp +index 192fe0f8..473e56f7 100644 +--- a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp ++++ b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp +@@ -387,7 +387,8 @@ void ReferenceReplicatedXCHostIntegrator:: + + + // Evaluate X matrix (fac * P * B) -> store in Z +- const auto xmat_fac = is_rks ? 2.0 : 1.0; // TODO Fix for spinor RKS input ++ const auto xmat_fac = ++ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; + lwd->eval_xmat( mgga_dim_scal * npts, nbf, nbe, submat_map, xmat_fac, Ps, ldps, basis_eval, nbe, + zmat, nbe, nbe_scr ); + // X matrix for Pz +diff --git a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp +index 40e9512f..ceaaee1a 100644 +--- a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp ++++ b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp +@@ -139,7 +139,9 @@ protected: + value_type* VXCy, int64_t ldvxcy, + value_type* VXCx, int64_t ldvxcx, + value_type* EXC, value_type *N_EL, +- host_task_iterator task_begin, host_task_iterator task_end, incore_integrator_type& incore_integrator ++ host_task_iterator task_begin, host_task_iterator task_end, ++ incore_integrator_type& incore_integrator, ++ const IntegratorSettingsXC& ks_settings + ); + + +@@ -152,7 +154,9 @@ protected: + value_type* VXCz, int64_t ldvxcz, + value_type* VXCy, int64_t ldvxcy, + value_type* VXCx, int64_t ldvxcx, +- value_type* EXC, value_type* N_EL, incore_integrator_type& incore_integrator); ++ value_type* EXC, value_type* N_EL, ++ incore_integrator_type& incore_integrator, ++ const IntegratorSettingsXC& ks_settings); + public: + + template +diff --git a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp +index 2a5565c9..02126e12 100644 +--- a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp ++++ b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp +@@ -38,7 +38,7 @@ void ShellBatchedReplicatedXCIntegratorload_balancer_->basis(); +@@ -84,7 +84,7 @@ void ShellBatchedReplicatedXCIntegratortimer_.time_op("XCIntegrator.LocalWork", [&](){ + exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, + nullptr, 0, nullptr, 0, nullptr, 0, nullptr, 0, EXC, +- &N_EL, tasks.begin(), tasks.end(), incore_integrator ); ++ &N_EL, tasks.begin(), tasks.end(), incore_integrator, ks_settings ); + }); + + // Release ownership of LWD back to this integrator instance +@@ -134,4 +134,3 @@ void ShellBatchedReplicatedXCIntegrator +@@ -31,7 +31,7 @@ void ShellBatchedReplicatedXCIntegrator +diff --git a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp +index 3dd43f4d..961c3f46 100644 +--- a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp ++++ b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp +@@ -42,7 +42,7 @@ void ShellBatchedReplicatedXCIntegratorload_balancer_->basis(); +@@ -98,7 +98,7 @@ void ShellBatchedReplicatedXCIntegratortimer_.time_op("XCIntegrator.LocalWork", [&](){ + exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, + VXCs, ldvxcs, VXCz, ldvxcz, VXCy, ldvxcy, VXCx, ldvxcx, EXC, +- &N_EL, tasks.begin(), tasks.end(), incore_integrator ); ++ &N_EL, tasks.begin(), tasks.end(), incore_integrator, ks_settings ); + }); + + // Release ownership of LWD back to this integrator instance +@@ -166,7 +166,8 @@ void ShellBatchedReplicatedXCIntegrator Date: Fri, 17 Jul 2026 08:19:44 +0200 Subject: [PATCH 04/30] Bump fortitude to version 0.9.0 and consider some of its new rules (#5597) --- src/accint_weights_forces.F | 15 +- src/admm_dm_methods.F | 12 +- src/admm_dm_types.F | 3 +- src/admm_methods.F | 15 +- src/admm_types.F | 18 +- src/almo_scf.F | 35 +- src/almo_scf_diis_types.F | 16 +- src/almo_scf_env_methods.F | 102 - src/almo_scf_methods.F | 93 +- src/almo_scf_optimizer.F | 1640 +---------------- src/almo_scf_qs.F | 76 +- src/almo_scf_types.F | 6 +- src/aobasis/ai_contraction.F | 2 +- src/aobasis/ai_eri_debug.F | 16 +- src/aobasis/ai_os_rr.F | 8 +- src/aobasis/ai_overlap.F | 12 +- src/aobasis/ai_overlap3_debug.F | 12 +- src/aobasis/ai_overlap_debug.F | 8 +- src/aobasis/basis_set_types.F | 8 +- src/arnoldi/arnoldi_data_methods.F | 27 +- src/arnoldi/arnoldi_geev.F | 2 +- src/arnoldi/arnoldi_methods.F | 2 +- src/atom_electronic_structure.F | 8 +- src/atom_energy.F | 6 +- src/atom_fit.F | 4 +- src/atom_grb.F | 3 +- src/atom_kind_orbitals.F | 2 +- src/atom_operators.F | 4 +- src/atom_optimization.F | 2 +- src/atom_output.F | 9 +- src/atom_pseudo.F | 4 +- src/atom_set_basis.F | 2 +- src/atom_sgp.F | 8 +- src/atom_types.F | 6 +- src/atom_upf.F | 22 +- src/atom_utils.F | 4 +- src/atoms_input.F | 15 +- src/base/base_hooks.F | 3 +- src/base/machine.F | 9 +- src/bse_util.F | 4 +- src/bsse.F | 10 +- src/cell_methods.F | 33 +- src/colvar_methods.F | 93 +- src/common/array_sort.fypp | 6 +- src/common/cp_array_utils.F | 9 +- src/common/cp_error_handling.F | 10 +- src/common/cp_log_handling.F | 33 +- src/common/cp_result_methods.F | 12 +- src/common/cp_units.F | 36 +- src/common/distribution_1d_types.F | 3 +- src/common/fparser.F | 34 +- src/common/gfun.F | 2 +- src/common/hash_map.fypp | 6 +- src/common/list.fypp | 114 +- src/common/mathlib.F | 37 +- src/common/memory_utilities_unittest.F | 27 +- src/common/parallel_rng_types.F | 12 +- src/common/parallel_rng_types_unittest.F | 30 +- src/common/reference_manager.F | 12 +- src/common/spherical_harmonics.F | 40 +- src/common/splines.F | 12 +- src/common/timings.F | 21 +- src/common/timings_report.F | 9 +- src/common/util.F | 2 +- src/commutator_rpnl.F | 316 ++-- src/constraint.F | 95 +- src/constraint_fxd.F | 3 +- src/constraint_util.F | 6 +- src/constraint_vsite.F | 6 +- src/core_ppl.F | 8 +- src/core_ppnl.F | 6 +- src/cp2k_debug.F | 2 +- src/cp_control_types.F | 21 +- src/cp_control_utils.F | 149 +- src/cp_dbcsr_cholesky.F | 3 +- src/cp_dbcsr_operations.F | 46 +- src/cp_ddapc_forces.F | 2 +- src/cp_ddapc_methods.F | 4 +- src/cp_ddapc_util.F | 9 +- src/cp_eri_mme_interface.F | 6 +- src/cp_external_control.F | 5 +- src/cp_subsys_methods.F | 12 +- src/cryssym.F | 2 +- src/csvr_system_types.F | 3 +- src/ct_methods.F | 10 +- src/ct_types.F | 68 - src/dbm/dbm_api.F | 3 +- src/dbm/dbm_tests.F | 2 +- src/dbt/dbt_allocate_wrap.F | 2 +- src/dbt/dbt_array_list_methods.F | 22 +- src/dbt/dbt_methods.F | 16 +- src/dbt/dbt_split.F | 17 +- src/dbt/dbt_types.F | 10 +- src/dbt/tas/dbt_tas_mm.F | 16 +- src/dbt/tas/dbt_tas_split.F | 8 +- src/dbt/tas/dbt_tas_util.F | 8 +- src/dbx/cp_dbcsr_api.F | 3 +- src/debug_os_integrals.F | 10 +- src/dft_plus_u.F | 8 +- src/distribution_2d_types.F | 36 +- src/distribution_methods.F | 34 +- src/dm_ls_chebyshev.F | 18 +- src/dm_ls_scf.F | 20 +- src/dm_ls_scf_create.F | 21 +- src/dm_ls_scf_curvy.F | 3 +- src/dm_ls_scf_methods.F | 20 +- src/dm_ls_scf_qs.F | 10 +- src/dm_ls_scf_types.F | 9 +- src/domain_submatrix_methods.F | 98 - src/ec_orth_solver.F | 12 +- src/eeq_data.F | 2 +- src/eeq_method.F | 8 +- src/efield_tb_methods.F | 10 +- src/efield_utils.F | 8 +- src/eip_silicon.F | 682 +++---- src/emd/rt_bse_types.F | 5 +- src/emd/rt_delta_pulse.F | 3 +- src/emd/rt_projection_mo_utils.F | 33 +- src/emd/rt_propagation_methods.F | 9 +- src/emd/rt_propagation_output.F | 38 +- src/emd/rt_propagation_utils.F | 6 +- src/emd/rt_propagator_init.F | 2 +- src/energy_corrections.F | 2 +- src/environment.F | 19 +- src/eri_mme/eri_mme_error_control.F | 15 +- src/eri_mme/eri_mme_gaussian.F | 6 +- src/eri_mme/eri_mme_lattice_summation.F | 55 +- src/eri_mme/eri_mme_test.F | 3 +- src/eri_mme/eri_mme_types.F | 3 +- src/et_coupling_proj.F | 89 +- src/ewald_spline_util.F | 4 +- src/ewalds.F | 4 +- src/ewalds_multipole.F | 31 +- src/ewalds_multipole_sr.fypp | 8 +- src/excited_states.F | 4 +- src/exstates_types.F | 3 +- src/f77_interface.F | 11 +- src/farming_methods.F | 2 +- src/farming_types.F | 3 +- src/fist_efield_methods.F | 2 +- src/fist_environment_types.F | 3 +- src/fist_force.F | 4 +- src/fist_intra_force.F | 20 +- src/fist_neighbor_lists.F | 2 +- src/fist_nonbond_env_types.F | 42 +- src/floquet_utils.F | 2 +- src/fm/cp_cfm_types.F | 15 +- src/fm/cp_fm_diag_utils.F | 21 +- src/fm/cp_fm_elpa.F | 24 +- src/fm/cp_fm_struct.F | 12 +- src/fm/cp_fm_types.F | 35 +- src/force_env_methods.F | 39 +- src/force_env_types.F | 6 +- src/force_env_utils.F | 2 +- src/force_fields_all.F | 60 +- src/force_fields_input.F | 18 +- src/global_types.F | 3 +- src/graphcon.F | 2 +- src/grid/grid_api.F | 12 +- src/grpp/libgrpp.F | 10 + src/gw_integrals.F | 2 +- src/gw_large_cell_gamma_ri_rs.F | 49 +- src/gw_non_periodic_ri_rs.F | 6 +- src/gw_utils.F | 9 +- src/gx_ac_unittest.F | 14 +- src/hartree_local_methods.F | 6 +- src/hdf5_wrapper.F | 7 + src/hfx_ace_methods.F | 44 +- src/hfx_admm_utils.F | 17 +- src/hfx_compression_methods.F | 2 + src/hfx_energy_potential.F | 11 +- src/hfx_exx.F | 2 +- src/hfx_load_balance_methods.F | 3 +- src/hfx_pw_methods.F | 7 +- src/hfx_ri.F | 3 +- src/hfx_ri_kp.F | 9 +- src/hfx_types.F | 16 +- src/hfxbase/hfx_compression_core_methods.F | 54 +- src/hirshfeld_methods.F | 6 +- src/iao_analysis.F | 4 +- src/iao_types.F | 7 +- src/input/cp_output_handling.F | 24 +- src/input/cp_parser_ilist_methods.F | 3 +- src/input/cp_parser_inpp_methods.F | 15 +- src/input/cp_parser_methods.F | 3 +- src/input/cp_parser_types.F | 3 +- src/input/input_enumeration_types.F | 9 +- src/input/input_keyword_types.F | 31 +- src/input/input_parsing.F | 30 +- src/input/input_section_types.F | 67 +- src/input/input_val_types.F | 9 +- src/input_cp2k_check.F | 27 +- src/input_cp2k_restarts_util.F | 3 +- src/input_restart_force_eval.F | 9 +- src/input_restart_rng.F | 3 +- src/ipi_driver.F | 3 +- src/ipi_server.F | 9 +- src/iterate_matrix.F | 9 +- src/kg_correction.F | 6 +- src/kg_vertex_coloring_methods.F | 3 +- src/kpoint_io.F | 4 +- src/kpoint_methods.F | 4 +- src/kpoint_transitional.F | 3 +- src/kpoint_types.F | 6 +- src/kpsym.F | 583 +++--- src/libint_2c_3c.F | 8 +- src/libint_wrapper.F | 15 +- src/library_tests.F | 56 +- src/linesearch.F | 6 +- src/local_gemm_api.F | 17 +- src/localization_tb.F | 2 +- src/localized_moments.F | 5 +- src/lri_optimize_ri_basis_types.F | 3 +- src/manybody_eam.F | 8 +- src/manybody_gal.F | 58 +- src/manybody_gal21.F | 106 +- src/manybody_nequip.F | 3 +- src/manybody_potential.F | 6 +- src/manybody_siepmann.F | 36 +- src/manybody_tersoff.F | 6 +- src/mao_basis.F | 3 +- src/mao_io.F | 4 +- src/mao_wfn_analysis.F | 3 +- src/metadyn_tools/graph.F | 10 +- src/metadyn_tools/graph_methods.F | 22 +- src/metadynamics_types.F | 3 +- src/metadynamics_utils.F | 21 +- src/minbas_methods.F | 5 +- src/minbas_wfn_analysis.F | 4 +- src/minimax/minimax_exp.F | 2 +- src/minimax/minimax_rpa.F | 783 ++++---- src/mixed_cdft_methods.F | 246 ++- src/mixed_cdft_types.F | 87 +- src/mixed_cdft_utils.F | 123 +- src/mixed_environment_types.F | 6 +- src/mode_selective.F | 61 +- src/mol_force.F | 14 +- src/molecular_dipoles.F | 6 +- src/molsym.F | 6 +- src/motion/bfgs_optimizer.F | 26 +- src/motion/cell_opt_utils.F | 6 +- src/motion/cg_utils.F | 17 +- src/motion/cp_lbfgs.F | 21 +- src/motion/cp_lbfgs_geo.F | 3 +- src/motion/cp_lbfgs_optimizer_gopt.F | 24 +- src/motion/dimer_methods.F | 6 +- src/motion/dimer_types.F | 9 +- src/motion/dimer_utils.F | 2 +- src/motion/dumpdcd.F | 13 +- src/motion/free_energy_methods.F | 3 +- src/motion/geo_opt.F | 3 +- src/motion/glbopt_callback.F | 9 +- src/motion/gopt_f77_methods.F | 6 +- src/motion/gopt_f_methods.F | 17 +- src/motion/helium_common.F | 6 +- src/motion/helium_interactions.F | 4 +- src/motion/helium_sampling.F | 2 +- src/motion/helium_types.F | 18 +- src/motion/input_cp2k_restarts.F | 29 +- src/motion/integrator.F | 12 +- src/motion/integrator_utils.F | 8 +- src/motion/mc/mc_control.F | 6 +- src/motion/mc/mc_coordinates.F | 9 +- src/motion/mc/mc_ensembles.F | 36 +- src/motion/mc/mc_ge_moves.F | 23 +- src/motion/mc/mc_move_control.F | 34 +- src/motion/mc/mc_moves.F | 53 +- src/motion/mc/mc_types.F | 21 +- src/motion/mc/tamc_run.F | 91 +- src/motion/md_conserved_quantities.F | 3 +- src/motion/md_energies.F | 6 +- src/motion/md_run.F | 15 +- src/motion/md_vel_utils.F | 28 +- src/motion/neb_io.F | 17 +- src/motion/neb_methods.F | 10 +- src/motion/neb_opt_utils.F | 16 +- src/motion/neb_utils.F | 10 +- src/motion/pint_methods.F | 27 +- src/motion/pint_piglet.F | 3 +- src/motion/pint_public.F | 2 +- src/motion/reftraj_util.F | 6 +- src/motion/rt_propagation.F | 12 +- src/motion/simpar_methods.F | 6 +- src/motion/thermal_region_utils.F | 6 +- src/motion/thermostat/al_system_dynamics.F | 17 +- src/motion/thermostat/al_system_init.F | 3 +- src/motion/thermostat/barostat_types.F | 6 +- src/motion/thermostat/barostat_utils.F | 2 +- src/motion/thermostat/extended_system_init.F | 12 +- .../thermostat/extended_system_mapping.F | 6 +- src/motion/thermostat/gle_system_dynamics.F | 2 +- src/motion/thermostat/thermostat_utils.F | 29 +- src/motion/vibrational_analysis.F | 4 +- src/motion/xyz2dcd.F | 13 +- src/motion_utils.F | 5 +- src/mp2_cphf.F | 6 +- src/mp2_eri.F | 6 +- src/mp2_gpw.F | 3 +- src/mp2_grids.F | 3 +- src/mp2_ri_2c.F | 6 +- src/mp2_ri_gpw.F | 15 +- src/mp2_ri_grad.F | 2 +- src/mpiwrap/message_passing.F | 9 +- src/mpiwrap/mp_perf_env.F | 2 + src/mpiwrap/mp_perf_test.F | 5 +- src/mscfg_methods.F | 9 +- src/mulliken.F | 2 +- src/negf_control_types.F | 15 +- src/negf_env_types.F | 31 +- src/negf_green_methods.F | 3 +- src/negf_integr_cc.F | 3 +- src/negf_integr_simpson.F | 9 +- src/negf_integr_utils.F | 9 +- src/negf_matrix_utils.F | 33 +- src/negf_methods.F | 24 +- src/negf_subgroup_types.F | 3 +- src/offload/offload_api.F | 3 +- src/openpmd_api.F | 5 +- src/optimize_basis.F | 12 +- src/optimize_basis_types.F | 27 +- src/optimize_basis_utils.F | 36 +- src/optimize_embedding_potential.F | 37 +- src/optimize_input.F | 6 +- src/pair_potential_types.F | 9 +- src/pair_potential_util.F | 15 +- src/pao_io.F | 46 +- src/pao_linpot_rotinv.F | 12 +- src/pao_main.F | 5 +- src/pao_methods.F | 24 +- src/pao_ml.F | 22 +- src/pao_ml_descriptor.F | 15 +- src/pao_ml_gaussprocess.F | 3 +- src/pao_model.F | 18 +- src/pao_optimizer.F | 9 +- src/pao_param_equi.F | 3 +- src/pao_param_exp.F | 3 +- src/pao_param_fock.F | 7 +- src/pao_param_gth.F | 24 +- src/pao_param_linpot.F | 21 +- src/pao_param_methods.F | 3 +- src/pao_types.F | 6 +- src/particle_methods.F | 14 +- src/pexsi_interface.F | 51 +- src/pexsi_methods.F | 18 +- src/pilaenv_hack.F | 4 +- src/pme.F | 10 +- src/population_analyses.F | 3 +- src/post_scf_bandstructure_utils.F | 3 +- src/preconditioner.F | 8 +- src/preconditioner_apply.F | 3 +- src/preconditioner_makes.F | 15 +- src/preconditioner_solvers.F | 3 +- src/pw/dgs.F | 36 +- src/pw/dirichlet_bc_methods.F | 4 +- src/pw/fft/fftw3_lib.F | 13 +- src/pw/fft/mltfftsg_tools.F | 3 + src/pw/fft_tools.F | 6 +- src/pw/mt_util.F | 3 +- src/pw/ps_implicit_methods.F | 30 +- src/pw/ps_wavelet_base.F | 4 +- src/pw/ps_wavelet_fft3d.F | 98 +- src/pw/ps_wavelet_kernel.F | 8 +- src/pw/ps_wavelet_methods.F | 6 +- src/pw/ps_wavelet_scaling_function.F | 6 +- src/pw/ps_wavelet_types.F | 6 +- src/pw/pw_fpga.F | 3 +- src/pw/pw_gpu.F | 6 +- src/pw/pw_grid_types.F | 3 +- src/pw/pw_poisson_methods.F | 12 +- src/pw/pw_poisson_types.F | 12 +- src/pw/pw_spline_utils.F | 23 +- src/pw/realspace_grid_cube.F | 18 +- src/pw/realspace_grid_cube_unittest.F | 15 +- src/pw/realspace_grid_openpmd.F | 3 +- src/pw/realspace_grid_types.F | 6 +- src/qcschema.F | 6 +- src/qmmm_create.F | 6 +- src/qmmm_elpot.F | 2 +- src/qmmm_force.F | 3 +- src/qmmm_gaussian_init.F | 2 +- src/qmmm_gpw_energy.F | 13 +- src/qmmm_gpw_forces.F | 43 +- src/qmmm_image_charge.F | 3 +- src/qmmm_init.F | 21 +- src/qmmm_links_methods.F | 12 +- src/qmmm_per_elpot.F | 5 +- src/qmmm_tb_methods.F | 40 +- src/qmmm_topology_util.F | 3 +- src/qmmm_util.F | 5 +- src/qmmmx_force.F | 10 +- src/qmmmx_util.F | 30 +- src/qs_2nd_kernel_ao.F | 3 +- src/qs_active_space_methods.F | 29 +- src/qs_active_space_mixing.F | 8 +- src/qs_active_space_types.F | 6 +- src/qs_cdft_methods.F | 40 +- src/qs_cdft_opt_types.F | 23 +- src/qs_cdft_scf_utils.F | 21 +- src/qs_cdft_types.F | 121 +- src/qs_cdft_utils.F | 50 +- src/qs_charge_mixing.F | 17 +- src/qs_chargemol.F | 2 +- src/qs_charges_types.F | 6 +- src/qs_cneo_methods.F | 15 +- src/qs_cneo_types.F | 90 +- src/qs_collocate_density.F | 73 +- src/qs_core_hamiltonian.F | 6 +- src/qs_core_matrices.F | 2 +- src/qs_dcdr_utils.F | 3 +- src/qs_dftb_parameters.F | 3 +- src/qs_dftb_utils.F | 3 +- src/qs_dispersion_cnum.F | 8 +- src/qs_dispersion_d3.F | 2 +- src/qs_dispersion_nonloc.F | 2 +- src/qs_dispersion_pairpot.F | 12 +- src/qs_efield_berry.F | 7 +- src/qs_electric_field_gradient.F | 2 +- src/qs_energy.F | 3 +- src/qs_energy_init.F | 10 +- src/qs_energy_window.F | 2 +- src/qs_environment.F | 35 +- src/qs_environment_types.F | 33 +- src/qs_external_potential.F | 2 +- src/qs_fb_env_types.F | 45 +- src/qs_fb_filter_matrix_methods.F | 23 +- src/qs_force.F | 19 +- src/qs_fxc.F | 3 +- src/qs_gapw_densities.F | 3 +- src/qs_gspace_mixing.F | 16 +- src/qs_initial_guess.F | 17 +- src/qs_integrate_potential_product.F | 88 +- src/qs_kind_types.F | 67 +- src/qs_kinetic.F | 4 +- src/qs_kpp1_env_methods.F | 5 +- src/qs_ks_apply_restraints.F | 9 +- src/qs_ks_atom.F | 8 +- src/qs_ks_methods.F | 14 +- src/qs_ks_types.F | 30 +- src/qs_ks_utils.F | 29 +- src/qs_kubo_transport.F | 4 +- src/qs_linres_atom_current.F | 14 +- src/qs_linres_current.F | 3 +- src/qs_linres_current_utils.F | 5 +- src/qs_linres_epr_nablavks.F | 2 +- src/qs_linres_issc_utils.F | 98 +- src/qs_linres_kernel.F | 12 +- src/qs_linres_methods.F | 2 +- src/qs_linres_module.F | 3 +- src/qs_linres_op.F | 14 +- src/qs_loc_main.F | 2 +- src/qs_loc_states.F | 23 +- src/qs_loc_types.F | 9 +- src/qs_loc_utils.F | 65 +- src/qs_local_rho_types.F | 9 +- src/qs_localization_methods.F | 50 +- src/qs_mixing_utils.F | 12 +- src/qs_mo_io.F | 21 +- src/qs_mo_occupation.F | 43 +- src/qs_mom_methods.F | 15 +- src/qs_moments.F | 6 +- src/qs_neighbor_list_types.F | 7 +- src/qs_neighbor_lists.F | 46 +- src/qs_nonscf_utils.F | 36 +- src/qs_ot.F | 3 +- src/qs_ot_types.F | 18 +- src/qs_outer_scf.F | 36 +- src/qs_overlap.F | 4 +- src/qs_p_env_methods.F | 5 +- src/qs_pdos.F | 9 +- src/qs_resp.F | 6 +- src/qs_rho0_ggrid.F | 3 +- src/qs_rho_methods.F | 14 +- src/qs_scf.F | 76 +- src/qs_scf_csr_write.F | 3 +- src/qs_scf_diagonalization.F | 22 +- src/qs_scf_initialization.F | 62 +- src/qs_scf_loop_utils.F | 9 +- src/qs_scf_methods.F | 30 +- src/qs_scf_output.F | 76 +- src/qs_scf_post_gpw.F | 15 +- src/qs_scf_post_scf.F | 8 +- src/qs_scf_wfn_mix.F | 18 +- src/qs_subsys_types.F | 9 +- src/qs_tddfpt2_densities.F | 5 +- src/qs_tddfpt2_eigensolver.F | 9 +- src/qs_tddfpt2_fhxc.F | 8 +- src/qs_tddfpt2_fhxc_forces.F | 8 +- src/qs_tddfpt2_forces.F | 2 +- src/qs_tddfpt2_fprint.F | 8 +- src/qs_tddfpt2_methods.F | 55 +- src/qs_tddfpt2_properties.F | 10 +- src/qs_tddfpt2_restart.F | 9 +- src/qs_tddfpt2_stda_types.F | 3 +- src/qs_tddfpt2_stda_utils.F | 5 +- src/qs_tddfpt2_subgroups.F | 32 +- src/qs_tddfpt2_types.F | 5 +- src/qs_tddfpt2_utils.F | 47 +- src/qs_tensors.F | 28 +- src/qs_update_s_mstruct.F | 3 +- src/qs_vcd_utils.F | 21 +- src/qs_vxc.F | 13 +- src/qs_vxc_atom.F | 2 +- src/qs_wannier90.F | 6 +- src/qs_wf_history_methods.F | 6 +- src/replica_methods.F | 3 +- src/replica_types.F | 3 +- src/response_solver.F | 4 +- src/restraint.F | 18 +- src/rpa_grad.F | 30 +- src/rpa_gw_kpoints_util.F | 3 +- src/rpa_im_time.F | 3 +- src/rpa_main.F | 12 +- src/rt_propagation_forces.F | 6 +- src/rt_propagation_types.F | 45 +- src/rt_propagation_velocity_gauge.F | 30 +- src/scf_control_types.F | 10 +- src/scine_utils.F | 30 +- src/se_core_matrix.F | 39 +- src/semi_empirical_int_ana.F | 11 +- src/semi_empirical_int_debug.F | 4 +- src/semi_empirical_int_gks.F | 8 +- src/semi_empirical_int_num.F | 8 +- src/semi_empirical_par_utils.F | 15 +- src/semi_empirical_store_int_types.F | 3 +- src/semi_empirical_types.F | 2 +- src/semi_empirical_utils.F | 3 +- src/shg_int/construct_shg.F | 3 +- src/sirius_interface.F | 2 +- src/skala_gpw_features.F | 57 +- src/skala_gpw_functional.F | 3 +- src/smeagol_control_types.F | 2 +- src/smeagol_emtoptions.F | 9 +- src/smeagol_interface.F | 6 +- src/smeagol_matrix_utils.F | 27 +- src/start/cp2k.F | 6 +- src/start/cp2k_runs.F | 18 +- src/start/cp2k_shell.F | 4 +- src/start/libcp2k.F | 18 +- src/stm_images.F | 6 +- src/subsys/colvar_types.F | 47 +- src/subsys/external_potential_types.F | 57 +- src/subsys/molecule_kind_types.F | 33 +- src/subsys/molecule_types.F | 15 +- src/surface_dipole.F | 4 +- src/swarm/glbopt_history.F | 9 +- src/swarm/glbopt_mincrawl.F | 3 +- src/swarm/glbopt_minhop.F | 3 +- src/swarm/glbopt_worker.F | 24 +- src/swarm/swarm_master.F | 3 +- src/swarm/swarm_message.F | 6 +- src/swarm/swarm_mpi.F | 18 +- src/swarm/swarm_worker.F | 3 +- src/task_list_methods.F | 50 +- src/tblite_interface.F | 119 +- src/tblite_scc_mixer.F | 4 +- src/tblite_types.F | 15 +- src/tmc/tmc_analysis.F | 123 +- src/tmc/tmc_analysis_types.F | 18 +- src/tmc/tmc_calculations.F | 6 +- src/tmc/tmc_cancelation.F | 3 +- src/tmc/tmc_dot_tree.F | 3 +- src/tmc/tmc_file_io.F | 18 +- src/tmc/tmc_master.F | 148 +- src/tmc/tmc_messages.F | 46 +- src/tmc/tmc_move_handle.F | 42 +- src/tmc/tmc_moves.F | 21 +- src/tmc/tmc_setup.F | 108 +- src/tmc/tmc_tree_acceptance.F | 29 +- src/tmc/tmc_tree_build.F | 84 +- src/tmc/tmc_tree_search.F | 12 +- src/tmc/tmc_types.F | 21 +- src/tmc/tmc_worker.F | 71 +- src/topology.F | 6 +- src/topology_amber.F | 78 +- src/topology_cif.F | 4 +- src/topology_connectivity_util.F | 9 +- src/topology_constraint_util.F | 23 +- src/topology_coordinate_util.F | 29 +- src/topology_generate_util.F | 2 +- src/topology_gromos.F | 6 +- src/topology_input.F | 3 +- src/topology_multiple_unit_cell.F | 9 +- src/topology_pdb.F | 16 +- src/topology_psf.F | 6 +- src/topology_types.F | 12 +- src/topology_util.F | 3 +- src/topology_xtl.F | 9 +- src/topology_xyz.F | 3 +- src/transport.F | 3 +- src/wannier90.F | 8 +- src/xas_methods.F | 40 +- src/xas_restart.F | 12 +- src/xas_tdp_atom.F | 2 +- src/xas_tdp_correction.F | 2 +- src/xas_tdp_kernel.F | 7 +- src/xas_tdp_methods.F | 9 +- src/xas_tp_scf.F | 3 +- src/xc/xc.F | 23 +- src/xc/xc_derivative_set_types.F | 3 +- src/xc/xc_derivatives.F | 3 +- src/xc/xc_functionals_utilities.F | 24 +- src/xc/xc_gauxc_cache.F | 26 +- src/xc/xc_libxc.F | 6 +- src/xc/xc_libxc_wrap.F | 3 +- src/xc/xc_pade.F | 3 +- src/xc/xc_perdew86.F | 2 - src/xc/xc_perdew_zunger.F | 2 +- src/xc/xc_rho_set_types.F | 3 +- src/xc/xc_tfw.F | 3 +- src/xc/xc_thomas_fermi.F | 3 +- src/xc/xc_vwn.F | 4 +- src/xc/xc_xalpha.F | 3 +- src/xc_adiabatic_utils.F | 3 +- src/xc_pot_saop.F | 18 +- src/xtb_coulomb.F | 4 +- src/xtb_hcore.F | 4 +- src/xtb_ks_matrix.F | 15 +- src/xtb_parameters.F | 30 +- src/xtb_potentials.F | 3 +- src/xtb_types.F | 3 +- tools/precommit/fortitude.toml | 48 +- tools/precommit/requirements.txt | 2 +- 622 files changed, 7366 insertions(+), 7363 deletions(-) diff --git a/src/accint_weights_forces.F b/src/accint_weights_forces.F index b5d9376e9b..f56be20318 100644 --- a/src/accint_weights_forces.F +++ b/src/accint_weights_forces.F @@ -412,7 +412,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_g_base, rho_r, rho_g) - ELSEIF (ASSOCIATED(rho_r_base)) THEN + ELSE IF (ASSOCIATED(rho_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_r_base, rho_r, rho_g) ELSE CPABORT("Fine Grid in xc_density requires rho_r or rho_g") @@ -420,7 +420,7 @@ CONTAINS IF (rho_tau_valid) THEN IF (rho_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_g_base, tau_r, tau_g) - ELSEIF (ASSOCIATED(tau_r_base)) THEN + ELSE IF (ASSOCIATED(tau_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_r_base, tau_r, tau_g) ELSE CPABORT("Fine Grid in xc_density requires tau_r or tau_g") @@ -482,7 +482,7 @@ CONTAINS NULLIFY (rho1_r, rho1_g, tau1_r, tau1_g) IF (rho1_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho1_g_base, rho1_r, rho1_g) - ELSEIF (ASSOCIATED(rho1_r_base)) THEN + ELSE IF (ASSOCIATED(rho1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho1_r_base, rho1_r, rho1_g) ELSE CPABORT("Fine Grid in xc_density requires rho1_r or rho1_g") @@ -490,7 +490,7 @@ CONTAINS IF (rho1_tau_valid) THEN IF (rho1_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau1_g_base, tau1_r, tau1_g) - ELSEIF (ASSOCIATED(tau1_r_base)) THEN + ELSE IF (ASSOCIATED(tau1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau1_r_base, tau1_r, tau1_g) ELSE CPABORT("Fine Grid in xc_density requires tau1_r or tau1_g") @@ -518,7 +518,7 @@ CONTAINS NULLIFY (rho1_r, rho1_g, tau1_r, tau1_g) IF (rho1_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho1_g_base, rho1_r, rho1_g) - ELSEIF (ASSOCIATED(rho1_r_base)) THEN + ELSE IF (ASSOCIATED(rho1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho1_r_base, rho1_r, rho1_g) ELSE CPABORT("Fine Grid in xc_density requires rho1_r or rho1_g") @@ -526,7 +526,7 @@ CONTAINS IF (rho1_tau_valid) THEN IF (rho1_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau1_g_base, tau1_r, tau1_g) - ELSEIF (ASSOCIATED(tau1_r_base)) THEN + ELSE IF (ASSOCIATED(tau1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau1_r_base, tau1_r, tau1_g) ELSE CPABORT("Fine Grid in xc_density requires tau1_r or tau1_g") @@ -574,8 +574,9 @@ CONTAINS DEALLOCATE (vxc_rho) END IF IF (ASSOCIATED(vxc_tau)) THEN - IF (.NOT. ASSOCIATED(tau1_r)) & + IF (.NOT. ASSOCIATED(tau1_r)) THEN CPABORT("Tau response density required for mGGA xc_density") + END IF DO ispin = 1, nspins CALL pw_multiply_with(vxc_tau(ispin), tau1_r(ispin)) CALL pw_axpy(vxc_tau(ispin), exc, 1.0_dp) diff --git a/src/admm_dm_methods.F b/src/admm_dm_methods.F index 7d046cdca3..a2c56f3155 100644 --- a/src/admm_dm_methods.F +++ b/src/admm_dm_methods.F @@ -76,8 +76,9 @@ CONTAINS CPABORT("admm_dm_calc_rho_aux: unknown method") END SELECT - IF (admm_dm%purify) & + IF (admm_dm%purify) THEN CALL purify_mcweeny(qs_env) + END IF CALL update_rho_aux(qs_env) @@ -120,8 +121,9 @@ CONTAINS CPABORT("admm_dm_merge_ks_matrix: unknown method") END SELECT - IF (admm_dm%purify) & + IF (admm_dm%purify) THEN CALL dbcsr_deallocate_matrix_set(matrix_ks_merge) + END IF CALL timestop(handle) @@ -217,8 +219,9 @@ CONTAINS IF (admm_dm%block_map(iatom, jatom) == 1) THEN CALL dbcsr_get_block_p(rho_ao_aux(ispin)%matrix, & row=iatom, col=jatom, BLOCK=sparse_block_aux, found=found) - IF (found) & + IF (found) THEN sparse_block_aux = sparse_block + END IF END IF END DO CALL dbcsr_iterator_stop(iter) @@ -333,8 +336,9 @@ CONTAINS CALL dbcsr_iterator_start(iter, matrix_ks_merge(ispin)%matrix) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block) - IF (admm_dm%block_map(iatom, jatom) == 0) & + IF (admm_dm%block_map(iatom, jatom) == 0) THEN sparse_block = 0.0_dp + END IF END DO CALL dbcsr_iterator_stop(iter) CALL dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_merge(ispin)%matrix, 1.0_dp, 1.0_dp) diff --git a/src/admm_dm_types.F b/src/admm_dm_types.F index 2ca1e1d4d7..90183cb8a4 100644 --- a/src/admm_dm_types.F +++ b/src/admm_dm_types.F @@ -105,8 +105,9 @@ CONTAINS DEALLOCATE (admm_dm%matrix_a) END IF - IF (ASSOCIATED(admm_dm%block_map)) & + IF (ASSOCIATED(admm_dm%block_map)) THEN DEALLOCATE (admm_dm%block_map) + END IF DEALLOCATE (admm_dm%mcweeny_history) DEALLOCATE (admm_dm) diff --git a/src/admm_methods.F b/src/admm_methods.F index 42d3850230..9715ce9516 100644 --- a/src/admm_methods.F +++ b/src/admm_methods.F @@ -226,12 +226,13 @@ CONTAINS END IF - IF (admm_env%purification_method == do_admm_purify_cauchy) & + IF (admm_env%purification_method == do_admm_purify_cauchy) THEN CALL purify_dm_cauchy(admm_env, & mo_set=mos_aux_fit(ispin), & density_matrix=rho_ao_aux(ispin)%matrix, & ispin=ispin, & blocked=admm_env%block_dm) + END IF !GPW is the default, PW density is computed using the AUX_FIT basis and task_list !If GAPW, the we use the AUX_FIT_SOFT basis and task list @@ -2180,13 +2181,15 @@ CONTAINS IF (my_kpgrp) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux, work_aux_aux, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, work_aux_aux2, & para_env, info(indx, 2)) + END IF ELSE CALL cp_fm_start_copy_general(admm_env%work_aux_aux, fmdummy, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) + END IF END IF END DO END DO @@ -2984,12 +2987,14 @@ CONTAINS IF (my_kpgrp) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux, work_aux_aux, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, work_aux_aux2, para_env, info(indx, 2)) + END IF ELSE CALL cp_fm_start_copy_general(admm_env%work_aux_aux, fmdummy, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) + END IF END IF END DO END DO diff --git a/src/admm_types.F b/src/admm_types.F index 3aefcb365e..e02e1ba93f 100644 --- a/src/admm_types.F +++ b/src/admm_types.F @@ -382,12 +382,15 @@ CONTAINS admm_env%aux_x_param(:) = admm_control%aux_x_param(:) !ADMMP, ADMMQ, ADMMS - IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & + IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN admm_env%do_admmp = .TRUE. - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) & + END IF + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) THEN admm_env%do_admmq = .TRUE. - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & + END IF + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN admm_env%do_admms = .TRUE. + END IF IF ((admm_control%method == do_admm_blocking_purify_full) .OR. & (admm_control%method == do_admm_blocked_projection)) THEN @@ -483,13 +486,16 @@ CONTAINS DEALLOCATE (admm_env%eigvals_lambda) DEALLOCATE (admm_env%eigvals_P_to_be_purified) - IF (ASSOCIATED(admm_env%block_map)) & + IF (ASSOCIATED(admm_env%block_map)) THEN DEALLOCATE (admm_env%block_map) + END IF - IF (ASSOCIATED(admm_env%xc_section_primary)) & + IF (ASSOCIATED(admm_env%xc_section_primary)) THEN CALL section_vals_release(admm_env%xc_section_primary) - IF (ASSOCIATED(admm_env%xc_section_aux)) & + END IF + IF (ASSOCIATED(admm_env%xc_section_aux)) THEN CALL section_vals_release(admm_env%xc_section_aux) + END IF IF (ASSOCIATED(admm_env%admm_gapw_env)) CALL admm_gapw_env_release(admm_env%admm_gapw_env) IF (ASSOCIATED(admm_env%admm_dm)) CALL admm_dm_release(admm_env%admm_dm) diff --git a/src/almo_scf.F b/src/almo_scf.F index b005bb02e6..c01f6f1a07 100644 --- a/src/almo_scf.F +++ b/src/almo_scf.F @@ -1400,7 +1400,6 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_delocalization' INTEGER :: handle, ispin, unit_nr - LOGICAL :: almo_experimental TYPE(cp_logger_type), POINTER :: logger TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: no_quench TYPE(optimizer_options_type) :: arbitrary_optimizer @@ -1462,25 +1461,6 @@ CONTAINS !!!! are commented out at the moment because some of their !!!! routines have not been thoroughly tested. - !!!! if we have virtuals pre-optimize and truncate them - !!!IF (almo_scf_env%need_virtuals) THEN - !!! SELECT CASE (almo_scf_env%deloc_truncate_virt) - !!! CASE (virt_full) - !!! ! simply copy virtual orbitals from matrix_v_full_blk to matrix_v_blk - !!! DO ispin=1,almo_scf_env%nspins - !!! CALL dbcsr_copy(almo_scf_env%matrix_v_blk(ispin),& - !!! almo_scf_env%matrix_v_full_blk(ispin)) - !!! ENDDO - !!! CASE (virt_number,virt_occ_size) - !!! CALL split_v_blk(almo_scf_env) - !!! !CALL truncate_subspace_v_blk(qs_env,almo_scf_env) - !!! CASE DEFAULT - !!! CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation") - !!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !!! END SELECT - !!!ENDIF - !!!CALL harris_foulkes_correction(qs_env,almo_scf_env) - IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & @@ -1585,18 +1565,6 @@ CONTAINS perturbation_only=.FALSE., & special_case=xalmo_case_normal) - ! RZK-warning THIS IS A HACK TO GET ORBITAL ENERGIES - almo_experimental = .FALSE. - IF (almo_experimental) THEN - almo_scf_env%perturbative_delocalization = .TRUE. - !DO ispin=1,almo_scf_env%nspins - ! CALL dbcsr_copy(almo_scf_env%matrix_t(ispin),& - ! almo_scf_env%matrix_t_blk(ispin)) - !ENDDO - CALL almo_scf_xalmo_eigensolver(qs_env, almo_scf_env, & - arbitrary_optimizer) - END IF ! experimental - ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & @@ -2622,8 +2590,9 @@ CONTAINS ALLOCATE (almo_scf_env%matrix_p_blk(nspins)) ALLOCATE (almo_scf_env%matrix_ks(nspins)) ALLOCATE (almo_scf_env%matrix_ks_blk(nspins)) - IF (almo_scf_env%need_previous_ks) & + IF (almo_scf_env%need_previous_ks) THEN ALLOCATE (almo_scf_env%matrix_ks_0deloc(nspins)) + END IF DO ispin = 1, nspins ! RZK-warning copy with symmery but remember that this might cause problems CALL dbcsr_create(almo_scf_env%matrix_p(ispin), & diff --git a/src/almo_scf_diis_types.F b/src/almo_scf_diis_types.F index d776ff9d8b..75341d7de5 100644 --- a/src/almo_scf_diis_types.F +++ b/src/almo_scf_diis_types.F @@ -258,8 +258,9 @@ CONTAINS ! update the buffer length old_buffer_length = diis_env%buffer_length diis_env%buffer_length = diis_env%buffer_length + 1 - IF (diis_env%buffer_length > diis_env%max_buffer_length) & + IF (diis_env%buffer_length > diis_env%max_buffer_length) THEN diis_env%buffer_length = diis_env%max_buffer_length + END IF !!!! resize B matrix !!!IF (old_buffer_length.lt.diis_env%buffer_length) THEN @@ -402,24 +403,12 @@ CONTAINS ! use the eigensystem to invert (implicitly) B matrix ! and compute the extrapolation coefficients - !! ALLOCATE(tmp1(diis_env%buffer_length+1,1)) - !! ALLOCATE(coeff(diis_env%buffer_length+1,1)) - !! tmp1(:,1)=-1.0_dp*m_b_copy(1,:)/eigenvalues(:) - !! coeff=MATMUL(m_b_copy,tmp1) - !! DEALLOCATE(tmp1) ALLOCATE (tmp1(diis_env%buffer_length + 1)) ALLOCATE (coeff(diis_env%buffer_length + 1)) tmp1(:) = -1.0_dp*m_b_copy(1, :)/eigenvalues(:) coeff(:) = MATMUL(m_b_copy, tmp1) DEALLOCATE (tmp1) - !IF (unit_nr.gt.0) THEN - ! DO im=1,diis_env%buffer_length+1 - ! WRITE(unit_nr,*) diis_env%m_b(idomain)%mdata(im,:) - ! ENDDO - ! WRITE (unit_nr,*) coeff(:,1) - !ENDIF - ! extrapolate the variable checksum = 0.0_dp IF (diis_env%diis_env_type == diis_env_dbcsr) THEN @@ -441,7 +430,6 @@ CONTAINS checksum = checksum + coeff(im + 1) END DO END IF - !WRITE(*,*) checksum DEALLOCATE (coeff) diff --git a/src/almo_scf_env_methods.F b/src/almo_scf_env_methods.F index 06a3d9f70f..adb25ed0f3 100644 --- a/src/almo_scf_env_methods.F +++ b/src/almo_scf_env_methods.F @@ -364,108 +364,6 @@ CONTAINS almo_scf_env%activate = 0 END IF - !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_AOS",& - ! i_val=almo_scf_env%domain_layout_aos) - !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_MOS",& - ! i_val=almo_scf_env%domain_layout_mos) - !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_AOS",& - ! i_val=almo_scf_env%mat_distr_aos) - !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_MOS",& - ! i_val=almo_scf_env%mat_distr_mos) - !CALL section_vals_val_get(almo_scf_section,"CONSTRAINT_TYPE",& - ! i_val=almo_scf_env%constraint_type) - !CALL section_vals_val_get(almo_scf_section,"MU",& - ! r_val=almo_scf_env%mu) - !CALL section_vals_val_get(almo_scf_section,"FIXED_MU",& - ! l_val=almo_scf_env%fixed_mu) - !CALL section_vals_val_get(almo_scf_section,"EPS_USE_PREV_AS_GUESS",& - ! r_val=almo_scf_env%eps_prev_guess) - !CALL section_vals_val_get(almo_scf_section,"MIXING_FRACTION",& - ! r_val=almo_scf_env%mixing_fraction) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_TENSOR_TYPE",& - ! i_val=almo_scf_env%deloc_cayley_tensor_type) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_CONJUGATOR",& - ! i_val=almo_scf_env%deloc_cayley_conjugator) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_MAX_ITER",& - ! i_val=almo_scf_env%deloc_cayley_max_iter) - !CALL section_vals_val_get(almo_scf_section,"DELOC_USE_OCC_ORBS",& - ! l_val=almo_scf_env%deloc_use_occ_orbs) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_USE_VIRT_ORBS",& - ! l_val=almo_scf_env%deloc_cayley_use_virt_orbs) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_LINEAR",& - ! l_val=almo_scf_env%deloc_cayley_linear) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_EPS_CONVERGENCE",& - ! r_val=almo_scf_env%deloc_cayley_eps_convergence) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_OCC_PRECOND",& - ! l_val=almo_scf_env%deloc_cayley_occ_precond) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_VIR_PRECOND",& - ! l_val=almo_scf_env%deloc_cayley_vir_precond) - !CALL section_vals_val_get(almo_scf_section,"ALMO_UPDATE_ALGORITHM_BD",& - ! i_val=almo_scf_env%almo_update_algorithm) - !CALL section_vals_val_get(almo_scf_section,"DELOC_TRUNCATE_VIRTUALS",& - ! i_val=almo_scf_env%deloc_truncate_virt) - !CALL section_vals_val_get(almo_scf_section,"DELOC_VIRT_PER_DOMAIN",& - ! i_val=almo_scf_env%deloc_virt_per_domain) - ! - !CALL section_vals_val_get(almo_scf_section,"OPT_K_EPS_CONVERGENCE",& - ! r_val=almo_scf_env%opt_k_eps_convergence) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_MAX_ITER",& - ! i_val=almo_scf_env%opt_k_max_iter) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_OUTER_MAX_ITER",& - ! i_val=almo_scf_env%opt_k_outer_max_iter) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE",& - ! r_val=almo_scf_env%opt_k_trial_step_size) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJUGATOR",& - ! i_val=almo_scf_env%opt_k_conjugator) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE_MULTIPLIER",& - ! r_val=almo_scf_env%opt_k_trial_step_size_multiplier) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_START",& - ! i_val=almo_scf_env%opt_k_conj_iter_start) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_START",& - ! i_val=almo_scf_env%opt_k_prec_iter_start) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_FREQ_RESET",& - ! i_val=almo_scf_env%opt_k_conj_iter_freq) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_FREQ_UPDATE",& - ! i_val=almo_scf_env%opt_k_prec_iter_freq) - ! - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_RADIUS_TYPE",& - ! i_val=almo_scf_env%quencher_radius_type) - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_FACTOR",& - ! r_val=almo_scf_env%quencher_r0_factor) - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_FACTOR",& - ! r_val=almo_scf_env%quencher_r1_factor) - !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_SHIFT",& - !! r_val=almo_scf_env%quencher_r0_shift) - !! - !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_SHIFT",& - !! r_val=almo_scf_env%quencher_r1_shift) - !! - !!almo_scf_env%quencher_r0_shift = cp_unit_to_cp2k(& - !! almo_scf_env%quencher_r0_shift,"angstrom") - !!almo_scf_env%quencher_r1_shift = cp_unit_to_cp2k(& - !! almo_scf_env%quencher_r1_shift,"angstrom") - ! - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_0",& - ! r_val=almo_scf_env%quencher_s0) - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_1",& - ! r_val=almo_scf_env%quencher_s1) - - !CALL section_vals_val_get(almo_scf_section,"ENVELOPE_AMPLITUDE",& - ! r_val=almo_scf_env%envelope_amplitude) - - !! how to read lists - !CALL section_vals_val_get(almo_scf_section,"INT_LIST01", & - ! n_rep_val=n_rep) - !counter_i = 0 - !DO k = 1,n_rep - ! CALL section_vals_val_get(almo_scf_section,"INT_LIST01",& - ! i_rep_val=k,i_vals=tmplist) - ! DO jj = 1,SIZE(tmplist) - ! counter_i=counter_i+1 - ! almo_scf_env%charge_of_domain(counter_i)=tmplist(jj) - ! ENDDO - !ENDDO - almo_scf_env%domain_layout_aos = almo_domain_layout_molecular almo_scf_env%domain_layout_mos = almo_domain_layout_molecular almo_scf_env%mat_distr_aos = almo_mat_distr_molecular diff --git a/src/almo_scf_methods.F b/src/almo_scf_methods.F index fdcc864590..67c4a367cf 100644 --- a/src/almo_scf_methods.F +++ b/src/almo_scf_methods.F @@ -1620,8 +1620,9 @@ CONTAINS my_algorithm = 0 IF (PRESENT(algorithm)) my_algorithm = algorithm - IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) & + IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) THEN CPABORT("PARA and BLACS env are necessary for cholesky algorithm") + END IF use_sigma_inv_guess = .FALSE. IF (PRESENT(use_guess)) THEN @@ -2092,7 +2093,6 @@ CONTAINS ALLOCATE (subm_in(ndomains)) ALLOCATE (subm_temp(ndomains)) ALLOCATE (subm_out(ndomains)) - !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL init_submatrices(subm_in) CALL init_submatrices(subm_temp) CALL init_submatrices(subm_out) @@ -2100,11 +2100,6 @@ CONTAINS CALL construct_submatrices(matrix_in, subm_in, & dpattern, map, node_of_domain, select_row) - !!!TRIM IF (matrix_trimmer_required) THEN - !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& - !!!TRIM dpattern,map,node_of_domain,select_row) - !!!TRIM ENDIF - IF (my_action == 0) THEN ! for example, apply preconditioner CALL multiply_submatrices('N', 'N', 1.0_dp, operator1, & @@ -2257,16 +2252,10 @@ CONTAINS ALLOCATE (subm_main(ndomains)) CALL init_submatrices(subm_main) - !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL construct_submatrices(matrix_main, subm_main, & dpattern, map, node_of_domain, select_row_col) - !!!TRIM IF (matrix_trimmer_required) THEN - !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& - !!!TRIM dpattern,map,node_of_domain,select_row) - !!!TRIM ENDIF - IF (my_action == -1) THEN ! project out the local occupied space !tmp=MATMUL(subm_r(idomain)%mdata,Minv) @@ -2315,38 +2304,9 @@ CONTAINS END DO naos = subm_main(idomain)%nrows - !WRITE(*,*) "Domain, mo_self_and_neig, ao_domain: ", idomain, n_domain_mos, naos ALLOCATE (Minv(naos, naos)) - !!!TRIM IF (my_use_trimmer) THEN - !!!TRIM ! THIS IS SUPER EXPENSIVE (ELIMINATE) - !!!TRIM ! trim the main matrix before inverting - !!!TRIM ! assume that the trimmer columns are different (i.e. the main matrix is different for each MO) - !!!TRIM allocate(tmp(naos,nmos(idomain))) - !!!TRIM DO ii=1, nmos(idomain) - !!!TRIM ! transform the main matrix using the trimmer for the current MO - !!!TRIM DO jj=1, naos - !!!TRIM DO kk=1, naos - !!!TRIM Mstore(jj,kk)=sumb_main(idomain)%mdata(jj,kk)*& - !!!TRIM subm_trimmer(idomain)%mdata(jj,ii)*& - !!!TRIM subm_trimmer(idomain)%mdata(kk,ii) - !!!TRIM ENDDO - !!!TRIM ENDDO - !!!TRIM ! invert the main matrix (exclude some eigenvalues, shift some) - !!!TRIM CALL pseudo_invert_matrix(A=Mstore,Ainv=Minv,N=naos,method=1,& - !!!TRIM !range1_thr=1.0E-9_dp,range2_thr=1.0E-9_dp,& - !!!TRIM shift=1.0E-5_dp,& - !!!TRIM range1=nmos(idomain),range2=nmos(idomain),& - !!!TRIM - !!!TRIM ! apply the inverted matrix - !!!TRIM ! RZK-warning this is only possible when the preconditioner is applied - !!!TRIM tmp(:,ii)=MATMUL(Minv,subm_in(idomain)%mdata(:,ii)) - !!!TRIM ENDDO - !!!TRIM subm_out=MATMUL(tmp,sigma) - !!!TRIM deallocate(tmp) - !!!TRIM ELSE - IF (PRESENT(bad_modes_projector_down)) THEN ALLOCATE (proj_array(naos, naos)) CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata, Ainv=Minv, N=naos, method=1, & @@ -2360,7 +2320,6 @@ CONTAINS CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata, Ainv=Minv, N=naos, method=1, & range1=nmos(idomain), range2=n_domain_mos) END IF - !!!TRIM ENDIF CALL copy_submatrices(subm_main(idomain), preconditioner(idomain), .FALSE.) CALL copy_submatrix_data(Minv, preconditioner(idomain)) @@ -2635,24 +2594,6 @@ CONTAINS unit_nr = -1 END IF - !CALL dpotrf('L', N, Ainv, N, INFO ) - !IF( INFO/=0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed") - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !END IF - !CALL dpotri('L', N, Ainv, N, INFO ) - !IF( INFO/=0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !END IF - !! complete the matrix - !DO ii=1,N - ! DO jj=ii+1,N - ! Ainv(ii,jj)=Ainv(jj,ii) - ! ENDDO - ! !WRITE(*,'(100F13.9)') Ainv(ii,:) - !ENDDO - ! diagonalize first ALLOCATE (eigenvalues(N)) ! Query the optimal workspace for dsyev @@ -2689,21 +2630,6 @@ CONTAINS DEALLOCATE (eigenvalues) -!!! ! compute the error -!!! allocate(test(N,N)) -!!! test=MATMUL(Ainv,A) -!!! DO ii=1,N -!!! test(ii,ii)=test(ii,ii)-1.0_dp -!!! ENDDO -!!! test_error=0.0_dp -!!! DO ii=1,N -!!! DO jj=1,N -!!! test_error=test_error+test(jj,ii)*test(jj,ii) -!!! ENDDO -!!! ENDDO -!!! WRITE(*,*) "Inversion error: ", SQRT(test_error) -!!! deallocate(test) - CALL timestop(handle) END SUBROUTINE matrix_sqrt @@ -2916,21 +2842,6 @@ CONTAINS END SELECT - !! compute the inversion error - !allocate(temp1(N,N)) - !temp1=MATMUL(Ainv,A) - !DO ii=1,N - ! temp1(ii,ii)=temp1(ii,ii)-1.0_dp - !ENDDO - !temp1_error=0.0_dp - !DO ii=1,N - ! DO jj=1,N - ! temp1_error=temp1_error+temp1(jj,ii)*temp1(jj,ii) - ! ENDDO - !ENDDO - !WRITE(*,*) "Inversion error: ", SQRT(temp1_error) - !deallocate(temp1) - CALL timestop(handle) END SUBROUTINE pseudo_invert_matrix diff --git a/src/almo_scf_optimizer.F b/src/almo_scf_optimizer.F index b516dcac0c..8325511ab0 100644 --- a/src/almo_scf_optimizer.F +++ b/src/almo_scf_optimizer.F @@ -72,8 +72,7 @@ MODULE almo_scf_optimizer ct_step_env_init,& ct_step_env_set,& ct_step_env_type - USE domain_submatrix_methods, ONLY: add_submatrices,& - construct_submatrices,& + USE domain_submatrix_methods, ONLY: construct_submatrices,& copy_submatrices,& init_submatrices,& maxnorm_submatrices,& @@ -226,11 +225,11 @@ CONTAINS ! get error_norm: choose the largest of the two spins prev_error_norm = error_norm DO ispin = 1, nspin - !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm_ispin = dbcsr_maxabs(almo_scf_env%matrix_err_blk(ispin)) IF (ispin == 1) error_norm = error_norm_ispin - IF (ispin > 1 .AND. error_norm_ispin > error_norm) & + IF (ispin > 1 .AND. error_norm_ispin > error_norm) THEN error_norm = error_norm_ispin + END IF END DO IF (error_norm < almo_scf_env%eps_prev_guess) THEN @@ -253,8 +252,9 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) & + IF (optimizer%early_stopping_on .AND. iscf == 1) THEN prepare_to_exit = .FALSE. + END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix @@ -294,21 +294,7 @@ CONTAINS local_nocc_of_domain(:) = almo_scf_env%nocc_of_domain(:, ispin) local_mu(:) = almo_scf_env%mu_of_domain(:, ispin) - ! RZK UPDATE! the update algorithm is removed because - ! RZK UPDATE! it requires updating core LS_SCF routines - ! RZK UPDATE! (the code exists in the CVS version) CPABORT("Density_matrix_sign has not been tested yet") - ! RZK UPDATE! CALL density_matrix_sign(almo_scf_env%matrix_p_blk(ispin),& - ! RZK UPDATE! local_mu,& - ! RZK UPDATE! almo_scf_env%fixed_mu,& - ! RZK UPDATE! almo_scf_env%matrix_ks_blk(ispin),& - ! RZK UPDATE! !matrix_mixing_old_blk(ispin),& - ! RZK UPDATE! almo_scf_env%matrix_s_blk(1), & - ! RZK UPDATE! almo_scf_env%matrix_s_blk_inv(1), & - ! RZK UPDATE! local_nocc_of_domain,& - ! RZK UPDATE! almo_scf_env%eps_filter,& - ! RZK UPDATE! almo_scf_env%domain_index_of_ao) - ! RZK UPDATE! almo_scf_env%mu_of_domain(:, ispin) = local_mu(:) END DO @@ -497,13 +483,6 @@ CONTAINS dpattern=almo_scf_env%quench_t(ispin), & map=almo_scf_env%domain_map(ispin), & node_of_domain=almo_scf_env%cpu_of_domain) - ! TRY: construct s_inv - !CALL construct_domain_s_inv(& - ! matrix_s=almo_scf_env%matrix_s(1),& - ! subm_s_inv=almo_scf_env%domain_s_inv(:,ispin),& - ! dpattern=almo_scf_env%quench_t(ispin),& - ! map=almo_scf_env%domain_map(ispin),& - ! node_of_domain=almo_scf_env%cpu_of_domain) ! construct the domain template for the occupied orbitals DO ispin = 1, nspin @@ -524,27 +503,6 @@ CONTAINS CALL init_submatrices(submatrix_mixing_old_blk) ALLOCATE (almo_diis(nspin)) - ! TRY: construct block-projector - !ALLOCATE(submatrix_tmp(almo_scf_env%ndomains)) - !DO ispin=1,nspin - ! CALL init_submatrices(submatrix_tmp) - ! CALL construct_domain_r_down(& - ! matrix_t=almo_scf_env%matrix_t_blk(ispin),& - ! matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& - ! matrix_s=almo_scf_env%matrix_s(1),& - ! subm_r_down=submatrix_tmp(:),& - ! dpattern=almo_scf_env%quench_t(ispin),& - ! map=almo_scf_env%domain_map(ispin),& - ! node_of_domain=almo_scf_env%cpu_of_domain,& - ! filter_eps=almo_scf_env%eps_filter) - ! CALL multiply_submatrices('N','N',1.0_dp,& - ! submatrix_tmp(:),& - ! almo_scf_env%domain_s_inv(:,1),0.0_dp,& - ! almo_scf_env%domain_r_down_up(:,ispin)) - ! CALL release_submatrices(submatrix_tmp) - !ENDDO - !DEALLOCATE(submatrix_tmp) - DO ispin = 1, nspin ! use s_sqrt since they are already properly constructed ! and have the same distributions as domain_err and domain_ks_xx @@ -578,7 +536,6 @@ CONTAINS ! check convergence converged = .TRUE. DO ispin = 1, nspin - !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm = dbcsr_maxabs(almo_scf_env%matrix_err_xx(ispin)) CALL maxnorm_submatrices(almo_scf_env%domain_err(:, ispin), & norm=error_norm_0) @@ -596,28 +553,18 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) & + IF (optimizer%early_stopping_on .AND. iscf == 1) THEN prepare_to_exit = .FALSE. + END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix ! perform mixing of KS matrices IF (iscf /= 1) THEN - IF (.FALSE.) THEN ! use diis instead of mixing - DO ispin = 1, nspin - CALL add_submatrices( & - almo_scf_env%mixing_fraction, & - almo_scf_env%domain_ks_xx(:, ispin), & - 1.0_dp - almo_scf_env%mixing_fraction, & - submatrix_mixing_old_blk(:, ispin), & - 'N') - END DO - ELSE - DO ispin = 1, nspin - CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & - d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) - END DO - END IF + DO ispin = 1, nspin + CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & + d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) + END DO END IF ! save the new matrix for the future mixing DO ispin = 1, nspin @@ -694,64 +641,6 @@ CONTAINS denergy_tot = denergy_tot + denergy_spin(ispin) - ! RZK-warning Energy correction can be evaluated using matrix_x - ! as shown in the attempt below and in the PCG procedure. - ! Using matrix_x allows immediate decomposition of the energy - ! lowering into 2-body components for EDA. However, it does not - ! work here because the diagonalization routine does not necessarily - ! produce orbitals with the same sign as the block-diagonal ALMOs - ! Any fixes?! - - !CALL dbcsr_init(matrix_x) - !CALL dbcsr_create(matrix_x,& - ! template=almo_scf_env%matrix_t(ispin)) - ! - !CALL dbcsr_init(matrix_tmp_no) - !CALL dbcsr_create(matrix_tmp_no,& - ! template=almo_scf_env%matrix_t(ispin)) - ! - !CALL dbcsr_copy(matrix_x,& - ! almo_scf_env%matrix_t_blk(ispin)) - !CALL dbcsr_add(matrix_x,almo_scf_env%matrix_t(ispin),& - ! -1.0_dp,1.0_dp) - - !CALL dbcsr_dot(matrix_x, almo_scf_env%matrix_err_xx(ispin),denergy) - - !denergy=denergy*spin_factor - - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "_ENERGY-0: ", almo_scf_env%almo_scf_energy - ! WRITE(unit_nr,*) "_ENERGY-D: ", denergy - ! WRITE(unit_nr,*) "_ENERGY-F: ", almo_scf_env%almo_scf_energy+denergy - !ENDIF - !! RZK-warning update will not work since the energy is overwritten almost immediately - !!CALL almo_scf_update_ks_energy(qs_env,& - !! almo_scf_env%almo_scf_energy+denergy) - !! - - !! print out the results of the decomposition analysis - !CALL dbcsr_hadamard_product(matrix_x,& - ! almo_scf_env%matrix_err_xx(ispin),& - ! matrix_tmp_no) - !CALL dbcsr_scale(matrix_tmp_no,spin_factor) - !CALL dbcsr_filter(matrix_tmp_no,almo_scf_env%eps_filter) - ! - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) - ! WRITE(unit_nr,'(T2,A)') "DECOMPOSITION OF THE DELOCALIZATION ENERGY" - !ENDIF - - !mynode=dbcsr_mp_mynode(dbcsr_distribution_mp(& - ! dbcsr_distribution(matrix_tmp_no))) - !WRITE(mynodestr,'(I6.6)') mynode - !mylogfile='EDA.'//TRIM(ADJUSTL(mynodestr)) - !OPEN (iunit,file=mylogfile,status='REPLACE') - !CALL print_block_sum(matrix_tmp_no,iunit) - !CLOSE(iunit) - ! - !CALL dbcsr_release(matrix_tmp_no) - !CALL dbcsr_release(matrix_x) - END IF ! iscf.eq.1 END DO @@ -955,13 +844,11 @@ CONTAINS eps_skip_gradients = almo_scf_env%real01 ! penalty amplitude adjusts the strength of volume conservation - energy_coeff = 1.0_dp !optimizer%opt_penalty%energy_coeff - localiz_coeff = 0.0_dp !optimizer%opt_penalty%occ_loc_coeff - penalty_amplitude = 0.0_dp !optimizer%opt_penalty%occ_vol_coeff - penalty_occ_vol = .FALSE. !( optimizer%opt_penalty%occ_vol_method & - !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) - penalty_occ_local = .FALSE. !( optimizer%opt_penalty%occ_loc_method & - !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) + energy_coeff = 1.0_dp + localiz_coeff = 0.0_dp + penalty_amplitude = 0.0_dp + penalty_occ_vol = .FALSE. + penalty_occ_local = .FALSE. normalize_orbitals = penalty_occ_vol .OR. penalty_occ_local ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) ALLOCATE (penalty_occ_vol_h_prefactor(nspins)) @@ -1322,9 +1209,6 @@ CONTAINS DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im - !CALL matrix_qs_to_almo(op_sm_set_qs(reim, idim0)%matrix, - ! op_sm_set_almo(reim, idim0)%matrix, & - ! almo_scf_env%mat_distr_aos) CALL dbcsr_multiply("N", "N", 1.0_dp, & op_sm_set_almo(reim, idim0)%matrix, & matrix_t_out(ispin), & @@ -1379,8 +1263,9 @@ CONTAINS ! save the previous gradient to compute beta ! do it only if the previous grad was computed ! for .NOT.line_search - IF (line_search_iteration == 0 .AND. iteration /= 0) & + IF (line_search_iteration == 0 .AND. iteration /= 0) THEN CALL dbcsr_copy(prev_grad(ispin), grad(ispin)) + END IF END DO ! ispin @@ -1494,11 +1379,13 @@ CONTAINS prepare_to_exit = .TRUE. END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. just_started) & + IF (optimizer%early_stopping_on .AND. just_started) THEN prepare_to_exit = .FALSE. + END IF - IF (grad_norm < almo_scf_env%eps_prev_guess) & + IF (grad_norm < almo_scf_env%eps_prev_guess) THEN use_guess = .TRUE. + END IF ! it is not time to exit just yet IF (.NOT. prepare_to_exit) THEN @@ -1580,10 +1467,6 @@ CONTAINS ! update the step direction IF (.NOT. line_search) THEN - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....updating step direction...." - !ENDIF - cg_iteration = cg_iteration + 1 ! save the previous step @@ -1663,10 +1546,6 @@ CONTAINS END DO ! ispin END IF ! compute_prec - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....applying precomputed preconditioner...." - !ENDIF - IF (my_special_case == xalmo_case_block_diag .OR. & my_special_case == xalmo_case_fully_deloc) THEN @@ -1700,16 +1579,6 @@ CONTAINS filter_eps=almo_scf_env%eps_filter) CALL dbcsr_scale(step(ispin), -1.0_dp) - !CALL dbcsr_copy(m_tmp_no_3,& - ! quench_t(ispin)) - !CALL inverse_of_elements(m_tmp_no_3) - !CALL dbcsr_copy(m_tmp_no_2,step) - !CALL dbcsr_hadamard_product(& - ! m_tmp_no_2,& - ! m_tmp_no_3,& - ! step) - !CALL dbcsr_copy(m_tmp_no_3,quench_t(ispin)) - END DO ! ispin END IF ! special case @@ -1762,10 +1631,6 @@ CONTAINS CALL dbcsr_copy(prev_minus_prec_grad(ispin), step(ispin)) - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....final beta....", beta - !ENDIF - ! conjugate the step direction CALL dbcsr_add(step(ispin), prev_step(ispin), 1.0_dp, beta) @@ -1794,10 +1659,6 @@ CONTAINS step_size = next_step_size_guess*1.05_dp END IF END IF - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,3F12.5)') & - ! "EG", e0, g0, step_size - !ENDIF next_step_size_guess = step_size ELSE IF (fixed_line_search_niter == 0) THEN @@ -1810,10 +1671,6 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,7F12.5)') & - ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der - !ENDIF step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -1824,11 +1681,6 @@ CONTAINS e1 = energy_new appr_sec_der = 2.0*((e1 - e0)/step_size - g0)/step_size g1 = appr_sec_der*step_size + g0 - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,7F12.5)') & - ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der - !ENDIF - !appr_sec_der=(g1-g0)/step_size step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -2144,7 +1996,7 @@ CONTAINS ALLOCATE (m_B0(1, dim_op, nspins)) !m_B0 first dim is 1 now! DO idim0 = 1, dim_op - DO reim = 1, 1 !SIZE(op_sm_set_qs, 1) + DO reim = 1, 1 DO ispin = 1, nspins CALL dbcsr_create(m_B0(reim, idim0, ispin), & template=m_theta(ispin), & @@ -2158,8 +2010,6 @@ CONTAINS ! penalty amplitude adjusts the strenght of volume conservation penalty_amplitude = optimizer%opt_penalty%penalty_strength - !penalty_occ_vol = ( optimizer%opt_penalty%occ_vol_method /= penalty_type_none ) - !penalty_local = ( optimizer%opt_penalty%occ_loc_method /= penalty_type_none ) ! preconditioner control prec_type = optimizer%preconditioner @@ -2453,7 +2303,6 @@ CONTAINS DO ispin = 1, nspins CALL compute_obj_nlmos( & - !obj_function_ispin=obj_function_ispin, & localization_obj_function_ispin=localization_obj_function_ispin, & penalty_func_ispin=penalty_func_ispin, & overlap_determinant=overlap_determinant, & @@ -2630,30 +2479,6 @@ CONTAINS ! TODO: write preconditioner code later ! For now, create matrix filled with 1.0 here CALL fill_matrix_with_ones(approx_inv_hessian(ispin)) - !CALL compute_preconditioner(& - ! m_prec_out=approx_hessian(ispin),& - ! m_ks=almo_scf_env%matrix_ks(ispin),& - ! m_s=matrix_s,& - ! m_siginv=almo_scf_env%template_matrix_sigma(ispin),& - ! m_quench_t=quench_t(ispin),& - ! m_FTsiginv=FTsiginv(ispin),& - ! m_siginvTFTsiginv=siginvTFTsiginv(ispin),& - ! m_ST=ST(ispin),& - ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env,& - ! nocc_of_domain=almo_scf_env%nocc_of_domain(:,ispin),& - ! domain_s_inv=almo_scf_env%domain_s_inv(:,ispin),& - ! domain_r_down=domain_r_down(:,ispin),& - ! cpu_of_domain=almo_scf_env%cpu_of_domain,& - ! domain_map=almo_scf_env%domain_map(ispin),& - ! assume_t0_q0x=assume_t0_q0x,& - ! penalty_occ_vol=penalty_occ_vol,& - ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin),& - ! eps_filter=eps_filter,& - ! neg_thr=0.5_dp,& - ! spin_factor=spin_factor,& - ! special_case=my_special_case) - !CALL invert hessian END DO ! ispin END IF @@ -2812,18 +2637,14 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,7F12.5)') & - ! "DT", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der - !ENDIF step_size = -g1/appr_sec_der ELSE IF (linear_search_type == 2) THEN ! alternative method for finding step size ! do not use quadratic approximation, only gradient signs IF (g1sign /= g0sign) THEN - step_size = -step_size/2.0; + step_size = -step_size/2.0 ELSE - step_size = step_size*1.5; + step_size = step_size*1.5 END IF END IF ! end alternative LS types @@ -3426,7 +3247,6 @@ CONTAINS proj_in_template=almo_scf_env%matrix_ov(ispin), & eps_filter=almo_scf_env%eps_filter, & sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin)) - !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),& ! save initial retained virtuals CALL dbcsr_create(vr_fixed, & @@ -3459,17 +3279,6 @@ CONTAINS ! project retained virtuals out of discarded block-by-block ! (1-Q^VR_ALMO)|ALMO_vd> ! this is probably not necessary, do it just to be safe - !CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin),& - ! psi_out=almo_scf_env%matrix_v_disc(ispin),& - ! psi_projector=almo_scf_env%matrix_v_blk(ispin),& - ! metric=almo_scf_env%matrix_s_blk(1),& - ! project_out=.TRUE.,& - ! psi_projector_orthogonal=.FALSE.,& - ! proj_in_template=almo_scf_env%matrix_k_tr(ispin),& - ! eps_filter=almo_scf_env%eps_filter,& - ! sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin)) - !CALL dbcsr_copy(almo_scf_env%matrix_v_disc_blk(ispin),& - ! almo_scf_env%matrix_v_disc(ispin)) ! construct discarded virtuals (1-R)|ALMO_vd> CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin), & @@ -3492,57 +3301,11 @@ CONTAINS CALL dbcsr_create(k_vr_index_down, & template=almo_scf_env%matrix_sigma_vv_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_copy(k_vr_index_down,& - ! almo_scf_env%matrix_sigma_vv_blk(ispin)) - - !CALL get_overlap(bra=almo_scf_env%matrix_v_blk(ispin),& - ! ket=almo_scf_env%matrix_v_blk(ispin),& - ! overlap=k_vr_index_down,& - ! metric=almo_scf_env%matrix_s_blk(1),& - ! retain_overlap_sparsity=.FALSE.,& - ! eps_filter=almo_scf_env%eps_filter) !! create the up metric in the discarded k-subspace CALL dbcsr_create(k_vd_index_down, & template=almo_scf_env%matrix_vv_disc_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_init(k_vd_index_up) - !CALL dbcsr_create(k_vd_index_up,& - ! template=almo_scf_env%matrix_vv_disc_blk(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_copy(k_vd_index_down,& - ! almo_scf_env%matrix_vv_disc_blk(ispin)) - - !CALL get_overlap(bra=almo_scf_env%matrix_v_disc_blk(ispin),& - ! ket=almo_scf_env%matrix_v_disc_blk(ispin),& - ! overlap=k_vd_index_down,& - ! metric=almo_scf_env%matrix_s_blk(1),& - ! retain_overlap_sparsity=.FALSE.,& - ! eps_filter=almo_scf_env%eps_filter) - - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "Inverting blocked overlap matrix of discarded virtuals" - !ENDIF - !CALL invert_Hotelling(k_vd_index_up,& - ! k_vd_index_down,& - ! almo_scf_env%eps_filter) - !IF (safe_mode) THEN - ! CALL dbcsr_init(matrix_tmp1) - ! CALL dbcsr_create(matrix_tmp1,template=k_vd_index_down,& - ! matrix_type=dbcsr_type_no_symmetry) - ! CALL dbcsr_multiply("N","N",1.0_dp,k_vd_index_up,& - ! k_vd_index_down,& - ! 0.0_dp, matrix_tmp1,& - ! filter_eps=almo_scf_env%eps_filter) - ! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp1) - ! CALL dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) - ! frob_matrix=dbcsr_frobenius_norm(matrix_tmp1) - ! IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "Error for (inv(SIG)*SIG-I)",& - ! frob_matrix/frob_matrix_base - ! ENDIF - ! CALL dbcsr_release(matrix_tmp1) - !ENDIF ! init matrices necessary for optimization of truncated virts ! init blocked gradient before setting K to zero @@ -3606,15 +3369,6 @@ CONTAINS template=almo_scf_env%matrix_k_blk(ispin)) CALL dbcsr_set(prev_grad, 0.0_dp) - !CALL dbcsr_init(sigma_oo_guess) - !CALL dbcsr_create(sigma_oo_guess,& - ! template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_set(sigma_oo_guess,0.0_dp) - !CALL dbcsr_add_on_diag(sigma_oo_guess,1.0_dp) - !CALL dbcsr_filter(sigma_oo_guess,almo_scf_env%eps_filter) - !CALL dbcsr_print(sigma_oo_guess) - END IF ! done constructing discarded virtuals ! init variables @@ -3652,9 +3406,6 @@ CONTAINS END IF ! decompose the overlap matrix of the current retained orbitals - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "decompose the active VV overlap matrix" - !ENDIF CALL get_overlap(bra=almo_scf_env%matrix_v(ispin), & ket=almo_scf_env%matrix_v(ispin), & overlap=almo_scf_env%matrix_sigma_vv(ispin), & @@ -3727,8 +3478,6 @@ CONTAINS CALL matrix_sqrt_Newton_Schulz(sigma_vv_sqrt, & sigma_vv_sqrt_inv, & almo_scf_env%matrix_sigma_vv(ispin), & - !matrix_sqrt_inv_guess=sigma_vv_sqrt_inv_guess,& - !matrix_sqrt_guess=sigma_vv_sqrt_guess,& threshold=almo_scf_env%eps_filter, & order=almo_scf_env%order_lanczos, & eps_lanczos=almo_scf_env%eps_lanczos, & @@ -3828,9 +3577,6 @@ CONTAINS +1.0_dp, +1.0_dp) ! calculate current occupied overlap - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "Inverting current occ overlap matrix" - !ENDIF CALL get_overlap(bra=t_curr, & ket=t_curr, & overlap=sigma_oo_curr, & @@ -3847,7 +3593,6 @@ CONTAINS sigma_oo_curr, & threshold=almo_scf_env%eps_filter, & use_inv_as_guess=.TRUE.) - !CALL dbcsr_copy(sigma_oo_guess,sigma_oo_curr_inv) END IF IF (safe_mode) THEN CALL dbcsr_create(matrix_tmp1, template=sigma_oo_curr, & @@ -3859,8 +3604,6 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) - !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) - !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (SIG*inv(SIG)-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3877,8 +3620,6 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) - !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) - !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (inv(SIG)*SIG-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3941,7 +3682,6 @@ CONTAINS tmp1_n_vr, & 0.0_dp, grad, & retain_sparsity=.TRUE.) - !filter_eps=almo_scf_env%eps_filter,& ! keep tmp2_n_o for the next step ! keep tmp4_o_vr for the preconditioner @@ -3991,21 +3731,6 @@ CONTAINS IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Computing preconditioner" END IF - !CALL opt_k_create_preconditioner(prec,& - ! almo_scf_env%matrix_v_disc(ispin),& - ! almo_scf_env%matrix_ks_0deloc(ispin),& - ! almo_scf_env%matrix_x(ispin),& - ! tmp4_o_vr,& - ! almo_scf_env%matrix_s(1),& - ! grad,& - ! !almo_scf_env%matrix_v_disc_blk(ispin),& - ! vd_fixed,& - ! t_curr,& - ! k_vd_index_up,& - ! k_vr_index_down,& - ! tmp1_n_vr,& - ! spin_factor,& - ! almo_scf_env%eps_filter) CALL opt_k_create_preconditioner_blk(almo_scf_env, & almo_scf_env%matrix_v_disc(ispin), & tmp4_o_vr, & @@ -4021,7 +3746,6 @@ CONTAINS ! compute the new step CALL opt_k_apply_preconditioner_blk(almo_scf_env, & step, grad, ispin) - !CALL dbcsr_hadamard_product(prec,grad,step) CALL dbcsr_scale(step, -1.0_dp) ! check whether we need to reset conjugate directions @@ -4036,9 +3760,6 @@ CONTAINS ELSE ! check for the errors in the cg algorithm - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) CALL dbcsr_dot(grad, prev_minus_prec_grad, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) conjugacy_error = numer/denom @@ -4076,63 +3797,32 @@ CONTAINS CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_fletcher_reeves) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) - !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) beta = numer/denom CASE (cg_polak_ribiere) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_fletcher) - !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !CALL dbcsr_dot(prev_grad,prev_step,denom) - !beta=-1.0_dp*numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_step, denom) beta = numer/denom CASE (cg_liu_storey) CALL dbcsr_dot(prev_grad, prev_step, denom) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_dai_yuan) - !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_dot(prev_grad,prev_step,denom) - !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_hager_zhang) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_dot(prev_grad,prev_step,denom) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(tmp_k_blk,prev_grad,numer) - !kappa=2.0_dp*numer/denom - !CALL dbcsr_dot(tmp_k_blk,grad,numer) - !tau=numer/denom - !CALL dbcsr_dot(prev_step,grad,numer) - !beta=tau-kappa*numer/denom CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) @@ -4164,7 +3854,6 @@ CONTAINS IF (reset_conjugator) THEN beta = 0.0_dp - !reset_step_size=.TRUE. IF (unit_nr > 0) THEN WRITE (unit_nr, *) "(Re)-setting conjugator to zero" @@ -4390,13 +4079,11 @@ CONTAINS "K iter CG", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun0, line_search_error, beta, conjugacy_error, t2a - t1a - !(flop1+flop2)/(1.0E6_dp*(t2-t1)) ELSE WRITE (unit_nr, '(T6,A,1X,I3,1X,E12.3,F16.10,F16.10,E12.3,E12.3,E12.3,F8.3,F8.3,F10.3)') & "K iter LS", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun1, line_search_error, beta, conjugacy_error, t2a - t1a - !(flop1+flop2)/(1.0E6_dp*(t2-t1)) END IF END IF CALL m_flush(unit_nr) @@ -4553,7 +4240,6 @@ CONTAINS IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CALL dbcsr_release(k_vr_index_down) CALL dbcsr_release(k_vd_index_down) - !CALL dbcsr_release(k_vd_index_up) CALL dbcsr_release(matrix_k_central) CALL dbcsr_release(vr_fixed) CALL dbcsr_release(vd_fixed) @@ -4678,8 +4364,6 @@ CONTAINS ! just get the energy correction CALL ct_step_env_get(ct_step_env, & energy_correction=energy_correction(ispin)) - !copy_da_energy_matrix=matrix_eda(ispin),& - !copy_da_charge_matrix=matrix_cta(ispin),& CALL ct_step_env_clean(ct_step_env) @@ -4700,18 +4384,6 @@ CONTAINS END IF energy_correction_final = energy_correction_final + energy_correction(ispin) - !!! print out the results of decomposition analysis - !!IF (unit_nr>0) THEN - !! WRITE(unit_nr,*) - !! WRITE(unit_nr,'(T2,A)') "ENERGY DECOMPOSITION" - !!ENDIF - !!CALL print_block_sum(eda_matrix(ispin), unit_nr=6) - !!IF (unit_nr>0) THEN - !! WRITE(unit_nr,*) - !! WRITE(unit_nr,'(T2,A)') "CHARGE DECOMPOSITION" - !!ENDIF - !!CALL print_block_sum(cta_matrix(ispin), unit_nr=6) - ! obtain density matrix from updated MOs ! RZK-later sigma and sigma_inv are lost here CALL almo_scf_t_to_proj(t=almo_scf_env%matrix_t(ispin), & @@ -4731,9 +4403,10 @@ CONTAINS para_env=almo_scf_env%para_env, & blacs_env=almo_scf_env%blacs_env) - IF (almo_scf_env%nspins == 1) & + IF (almo_scf_env%nspins == 1) THEN CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) + END IF END DO @@ -4779,17 +4452,6 @@ CONTAINS END IF - DO ispin = 1, nspin - ! RZK-warning the preconditioner is very important - ! IF (.FALSE.) THEN - ! CALL apply_matrix_preconditioner(almo_scf_env%matrix_ks(ispin),& - ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& - ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) - ! ENDIF - !CALL dbcsr_filter(almo_scf_env%matrix_ks(ispin),& - ! almo_scf_env%eps_filter) - END DO - ALLOCATE (matrix_p_almo_scf_converged(nspin)) DO ispin = 1, nspin CALL dbcsr_create(matrix_p_almo_scf_converged(ispin), & @@ -4802,50 +4464,19 @@ CONTAINS DO ispin = 1, nspin nelectron_spin_real(1) = almo_scf_env%nelectrons_spin(ispin) - IF (almo_scf_env%nspins == 1) & + IF (almo_scf_env%nspins == 1) THEN nelectron_spin_real(1) = nelectron_spin_real(1)/2 + END IF local_mu(1) = SUM(almo_scf_env%mu_of_domain(:, ispin))/almo_scf_env%ndomains fake(1) = 123523 - ! RZK UPDATE! the update algorithm is removed because - ! RZK UPDATE! it requires updating core LS_SCF routines - ! RZK UPDATE! (the code exists in the CVS version) CPABORT("CVS only: density_matrix_sign has not been updated in SVN") - ! RZK UPDATE!CALL density_matrix_sign(almo_scf_env%matrix_p(ispin),& - ! RZK UPDATE! local_mu,& - ! RZK UPDATE! almo_scf_env%fixed_mu,& - ! RZK UPDATE! almo_scf_env%matrix_ks_0deloc(ispin),& - ! RZK UPDATE! almo_scf_env%matrix_s(1), & - ! RZK UPDATE! almo_scf_env%matrix_s_inv(1), & - ! RZK UPDATE! nelectron_spin_real,& - ! RZK UPDATE! almo_scf_env%eps_filter,& - ! RZK UPDATE! fake) - ! RZK UPDATE! - almo_scf_env%mu = local_mu(1) - !IF (almo_scf_env%has_s_preconditioner) THEN - ! CALL apply_matrix_preconditioner(& - ! almo_scf_env%matrix_p_blk(ispin),& - ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& - ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) - !ENDIF - !CALL dbcsr_filter(almo_scf_env%matrix_p(ispin),& - ! almo_scf_env%eps_filter) - - IF (almo_scf_env%nspins == 1) & + IF (almo_scf_env%nspins == 1) THEN CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) - - !CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin),& - ! almo_scf_env%matrix_p(ispin),& - ! energy_correction(ispin)) - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) - ! WRITE(unit_nr,'(T2,A,I6,F20.9)') "EFAKE",ispin,& - ! energy_correction(ispin) - ! WRITE(unit_nr,*) - !ENDIF + END IF CALL dbcsr_add(matrix_p_almo_scf_converged(ispin), & almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp) CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin), & @@ -4958,13 +4589,6 @@ CONTAINS tmp1_n_vr, tmp2_n_vr, tmp_n_vd, & tmp_vd_vd_blk, tmp_vr_vr_blk -! init diag blocks outside -! init diag blocks otside -!INTEGER :: iblock_row, iblock_col,& -! nblkrows_tot, nblkcols_tot -!REAL(KIND=dp), DIMENSION(:, :), POINTER :: p_new_block -!INTEGER :: mynode, hold, row, col - CALL timeset(routineN, handle) ! initialize a matrix to 1.0 @@ -5362,562 +4986,6 @@ CONTAINS END SUBROUTINE opt_k_apply_preconditioner_blk -!! ************************************************************************************************** -!!> \brief Reduce the number of virtual orbitals by rotating them within -!!> a domain. The rotation is such that minimizes the frobenius norm of -!!> the Fov domain-blocks of the discarded virtuals -!!> \par History -!!> 2011.08 created [Rustam Z Khaliullin] -!!> \author Rustam Z Khaliullin -!! ************************************************************************************************** -! SUBROUTINE truncate_subspace_v_blk(qs_env,almo_scf_env) -! -! TYPE(qs_environment_type), POINTER :: qs_env -! TYPE(almo_scf_env_type) :: almo_scf_env -! -! CHARACTER(len=*), PARAMETER :: routineN = 'truncate_subspace_v_blk', & -! routineP = moduleN//':'//routineN -! -! INTEGER :: handle, ispin, iblock_row, & -! iblock_col, iblock_row_size, & -! iblock_col_size, retained_v, & -! iteration, line_search_step, & -! unit_nr, line_search_step_last -! REAL(KIND=dp) :: t1, obj_function, grad_norm,& -! c0, b0, a0, obj_function_new,& -! t2, alpha, ff1, ff2, step1,& -! step2,& -! frob_matrix_base,& -! frob_matrix -! LOGICAL :: safe_mode, converged, & -! prepare_to_exit, failure -! TYPE(cp_logger_type), POINTER :: logger -! TYPE(dbcsr_type) :: Fon, Fov, Fov_filtered, & -! temp1_oo, temp2_oo, Fov_original, & -! temp0_ov, U_blk_tot, U_blk, & -! grad_blk, step_blk, matrix_filter, & -! v_full_new,v_full_tmp,& -! matrix_sigma_vv_full,& -! matrix_sigma_vv_full_sqrt,& -! matrix_sigma_vv_full_sqrt_inv,& -! matrix_tmp1,& -! matrix_tmp2 -! -! REAL(kind=dp), DIMENSION(:, :), POINTER :: data_p, p_new_block -! TYPE(dbcsr_iterator_type) :: iter -! -! -!REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: eigenvalues, WORK -!REAL(kind=dp), DIMENSION(:,:), ALLOCATABLE :: data_copy, left_vectors, right_vectors -!INTEGER :: LWORK, INFO -!TYPE(dbcsr_type) :: temp_u_v_full_blk -! -! CALL timeset(routineN,handle) -! -! safe_mode=.TRUE. -! -! ! get a useful output_unit -! logger => cp_get_default_logger() -! IF (logger%para_env%is_source()) THEN -! unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) -! ELSE -! unit_nr=-1 -! ENDIF -! -! DO ispin=1,almo_scf_env%nspins -! -! t1 = m_walltime() -! -! !!!!!!!!!!!!!!!!! -! ! 0. Orthogonalize virtuals -! ! Unfortunately, we have to do it in the FULL V subspace :( -! -! CALL dbcsr_init(v_full_new) -! CALL dbcsr_create(v_full_new,& -! template=almo_scf_env%matrix_v_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! project the occupied subspace out -! CALL almo_scf_p_out_from_v(almo_scf_env%matrix_v_full_blk(ispin),& -! v_full_new,almo_scf_env%matrix_ov_full(ispin),& -! ispin,almo_scf_env) -! -! ! init overlap and its functions -! CALL dbcsr_init(matrix_sigma_vv_full) -! CALL dbcsr_init(matrix_sigma_vv_full_sqrt) -! CALL dbcsr_init(matrix_sigma_vv_full_sqrt_inv) -! CALL dbcsr_create(matrix_sigma_vv_full,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_create(matrix_sigma_vv_full_sqrt,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_create(matrix_sigma_vv_full_sqrt_inv,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! construct VV overlap -! CALL almo_scf_mo_to_sigma(v_full_new,& -! matrix_sigma_vv_full,& -! almo_scf_env%matrix_s(1),& -! almo_scf_env%eps_filter) -! -! IF (unit_nr>0) THEN -! WRITE(unit_nr,*) "sqrt and inv(sqrt) of the FULL virtual MO overlap" -! ENDIF -! -! ! construct orthogonalization matrices -! CALL matrix_sqrt_Newton_Schulz(matrix_sigma_vv_full_sqrt,& -! matrix_sigma_vv_full_sqrt_inv,& -! matrix_sigma_vv_full,& -! threshold=almo_scf_env%eps_filter,& -! order=almo_scf_env%order_lanczos,& -! eps_lanczos=almo_scf_env%eps_lanczos,& -! max_iter_lanczos=almo_scf_env%max_iter_lanczos) -! IF (safe_mode) THEN -! CALL dbcsr_init(matrix_tmp1) -! CALL dbcsr_create(matrix_tmp1,template=matrix_sigma_vv_full,& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_init(matrix_tmp2) -! CALL dbcsr_create(matrix_tmp2,template=matrix_sigma_vv_full,& -! matrix_type=dbcsr_type_no_symmetry) -! -! CALL dbcsr_multiply("N","N",1.0_dp,matrix_sigma_vv_full_sqrt_inv,& -! matrix_sigma_vv_full,& -! 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& -! matrix_sigma_vv_full_sqrt_inv,& -! 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) -! -! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp2) -! CALL dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) -! frob_matrix=dbcsr_frobenius_norm(matrix_tmp2) -! IF (unit_nr>0) THEN -! WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",frob_matrix/frob_matrix_base -! ENDIF -! -! CALL dbcsr_release(matrix_tmp1) -! CALL dbcsr_release(matrix_tmp2) -! ENDIF -! -! ! discard unnecessary overlap functions -! CALL dbcsr_release(matrix_sigma_vv_full) -! CALL dbcsr_release(matrix_sigma_vv_full_sqrt) -! -!! this can be re-written because we have (1-P)|v> -! -! !!!!!!!!!!!!!!!!!!! -! ! 1. Compute F_ov -! CALL dbcsr_init(Fon) -! CALL dbcsr_create(Fon,& -! template=almo_scf_env%matrix_v_full_blk(ispin)) -! CALL dbcsr_init(Fov) -! CALL dbcsr_create(Fov,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! CALL dbcsr_init(Fov_filtered) -! CALL dbcsr_create(Fov_filtered,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! CALL dbcsr_init(temp1_oo) -! CALL dbcsr_create(temp1_oo,& -! template=almo_scf_env%matrix_sigma(ispin),& -! !matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_init(temp2_oo) -! CALL dbcsr_create(temp2_oo,& -! template=almo_scf_env%matrix_sigma(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& -! almo_scf_env%matrix_ks_0deloc(ispin),& -! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& -! almo_scf_env%matrix_v_full_blk(ispin),& -! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& -! almo_scf_env%matrix_t_blk(ispin),& -! 0.0_dp,temp1_oo,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,temp1_oo,& -! almo_scf_env%matrix_sigma_inv(ispin),& -! 0.0_dp,temp2_oo,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_release(temp1_oo) -! -! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& -! almo_scf_env%matrix_s(1),& -! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& -! almo_scf_env%matrix_v_full_blk(ispin),& -! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_release(Fon) -! -! CALL dbcsr_multiply("N","N",-1.0_dp,temp2_oo,& -! Fov_filtered,& -! 1.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_release(temp2_oo) -! -! CALL dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_sigma_inv(ispin),& -! Fov,0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fov_filtered,& -! matrix_sigma_vv_full_sqrt_inv,& -! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) -! !CALL dbcsr_copy(Fov,Fov_filtered) -!CALL dbcsr_print(Fov) -! -! IF (safe_mode) THEN -! CALL dbcsr_init(Fov_original) -! CALL dbcsr_create(Fov_original,template=Fov) -! CALL dbcsr_copy(Fov_original,Fov) -! ENDIF -! -!!! remove diagonal blocks -!!CALL dbcsr_iterator_start(iter,Fov) -!!DO WHILE (dbcsr_iterator_blocks_left(iter)) -!! -!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -!! row_size=iblock_row_size,col_size=iblock_col_size) -!! -!! IF (iblock_row.eq.iblock_col) data_p(:,:)=0.0_dp -!! -!!ENDDO -!!CALL dbcsr_iterator_stop(iter) -!!CALL dbcsr_finalize(Fov) -! -!!! perform svd of blocks -!!!!! THIS ROUTINE WORKS ONLY ON ONE CPU AND ONLY FOR 2 MOLECULES !!! -!!CALL dbcsr_init(temp_u_v_full_blk) -!!CALL dbcsr_create(temp_u_v_full_blk,& -!! template=almo_scf_env%matrix_vv_full_blk(ispin),& -!! matrix_type=dbcsr_type_no_symmetry) -!! -!!CALL dbcsr_work_create(temp_u_v_full_blk,& -!! work_mutable=.TRUE.) -!!CALL dbcsr_iterator_start(iter,Fov) -!!DO WHILE (dbcsr_iterator_blocks_left(iter)) -!! -!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -!! row_size=iblock_row_size,col_size=iblock_col_size) -!! -!! IF (iblock_row.ne.iblock_col) THEN -!! -!! ! Prepare data -!! allocate(eigenvalues(min(iblock_row_size,iblock_col_size))) -!! allocate(data_copy(iblock_row_size,iblock_col_size)) -!! allocate(left_vectors(iblock_row_size,iblock_row_size)) -!! allocate(right_vectors(iblock_col_size,iblock_col_size)) -!! data_copy(:,:)=data_p(:,:) -!! -!! ! Query the optimal workspace for dgesvd -!! LWORK = -1 -!! allocate(WORK(MAX(1,LWORK))) -!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& -!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& -!! right_vectors,iblock_col_size,WORK,LWORK,INFO) -!! LWORK = INT(WORK( 1 )) -!! deallocate(WORK) -!! -!! ! Allocate the workspace and perform svd -!! allocate(WORK(MAX(1,LWORK))) -!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& -!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& -!! right_vectors,iblock_col_size,WORK,LWORK,INFO) -!! deallocate(WORK) -!! IF( INFO/=0 ) THEN -!! CPABORT("DGESVD failed") -!! END IF -!! -!! ! copy right singular vectors into a unitary matrix -!! CALL dbcsr_put_block(temp_u_v_full_blk,iblock_col,iblock_col,right_vectors) -!! -!! deallocate(eigenvalues) -!! deallocate(data_copy) -!! deallocate(left_vectors) -!! deallocate(right_vectors) -!! -!! ENDIF -!!ENDDO -!!CALL dbcsr_iterator_stop(iter) -!!CALL dbcsr_finalize(temp_u_v_full_blk) -!!!CALL dbcsr_print(temp_u_v_full_blk) -!!CALL dbcsr_multiply("N","T",1.0_dp,Fov,temp_u_v_full_blk,& -!! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) -!! -!!CALL dbcsr_copy(Fov,Fov_filtered) -!!CALL dbcsr_print(Fov) -! -! !!!!!!!!!!!!!!!!!!! -! ! 2. Initialize variables -! -! ! temp space -! CALL dbcsr_init(temp0_ov) -! CALL dbcsr_create(temp0_ov,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! -! ! current unitary matrix -! CALL dbcsr_init(U_blk) -! CALL dbcsr_create(U_blk,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! unitary matrix accumulator -! CALL dbcsr_init(U_blk_tot) -! CALL dbcsr_create(U_blk_tot,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_add_on_diag(U_blk_tot,1.0_dp) -! -!!CALL dbcsr_add_on_diag(U_blk,1.0_dp) -!!CALL dbcsr_multiply("N","T",1.0_dp,U_blk,temp_u_v_full_blk,& -!! 0.0_dp,U_blk_tot,filter_eps=almo_scf_env%eps_filter) -!! -!!CALL dbcsr_release(temp_u_v_full_blk) -! -! ! init gradient -! CALL dbcsr_init(grad_blk) -! CALL dbcsr_create(grad_blk,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! init step matrix -! CALL dbcsr_init(step_blk) -! CALL dbcsr_create(step_blk,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! "retain discarded" filter (0.0 - retain, 1.0 - discard) -! CALL dbcsr_init(matrix_filter) -! CALL dbcsr_create(matrix_filter,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! ! copy Fov into the filter matrix temporarily -! ! so we know which blocks contain significant elements -! CALL dbcsr_copy(matrix_filter,Fov) -! -! ! fill out filter elements block-by-block -! CALL dbcsr_iterator_start(iter,matrix_filter) -! DO WHILE (dbcsr_iterator_blocks_left(iter)) -! -! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -! row_size=iblock_row_size,col_size=iblock_col_size) -! -! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) -! -! data_p(:,1:retained_v)=0.0_dp -! data_p(:,(retained_v+1):iblock_col_size)=1.0_dp -! -! ENDDO -! CALL dbcsr_iterator_stop(iter) -! CALL dbcsr_finalize(matrix_filter) -! -! ! apply the filter -! CALL dbcsr_hadamard_product(Fov,matrix_filter,Fov_filtered) -! -! !!!!!!!!!!!!!!!!!!!!! -! ! 3. start iterative minimization of the elements to be discarded -! iteration=0 -! converged=.FALSE. -! prepare_to_exit=.FALSE. -! DO -! -! iteration=iteration+1 -! -! !!!!!!!!!!!!!!!!!!!!!!!!! -! ! 4. compute the gradient -! CALL dbcsr_set(grad_blk,0.0_dp) -! ! create the diagonal blocks only -! CALL dbcsr_add_on_diag(grad_blk,1.0_dp) -! -! CALL dbcsr_multiply("T","N",2.0_dp,Fov_filtered,Fov,& -! 0.0_dp,grad_blk,retain_sparsity=.TRUE.,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_multiply("T","N",-2.0_dp,Fov,Fov_filtered,& -! 1.0_dp,grad_blk,retain_sparsity=.TRUE.,& -! filter_eps=almo_scf_env%eps_filter) -! -! !!!!!!!!!!!!!!!!!!!!!!! -! ! 5. check convergence -! obj_function = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 -! grad_norm = dbcsr_frobenius_norm(grad_blk) -! converged=(grad_norm.lt.almo_scf_env%truncate_v_eps_convergence) -! IF (converged.OR.(iteration.ge.almo_scf_env%truncate_v_max_iter)) THEN -! prepare_to_exit=.TRUE. -! ENDIF -! -! IF (.NOT.prepare_to_exit) THEN -! -! !!!!!!!!!!!!!!!!!!!!!!! -! ! 6. perform steps in the direction of the gradient -! ! a. first, perform a trial step to "see" the parameters -! ! of the parabola along the gradient: -! ! a0 * x^2 + b0 * x + c0 -! ! b. then perform the step to the bottom of the parabola -! -! ! get c0 -! c0 = obj_function -! ! get b0 <= d_f/d_alpha along grad -! !!!CALL dbcsr_multiply("N","N",4.0_dp,Fov,grad_blk,& -! !!! 0.0_dp,temp0_ov,& -! !!! filter_eps=almo_scf_env%eps_filter) -! !!!CALL dbcsr_dot(Fov_filtered,temp0_ov,b0) -! -! alpha=almo_scf_env%truncate_v_trial_step_size -! -! line_search_step_last=3 -! DO line_search_step=1,line_search_step_last -! CALL dbcsr_copy(step_blk,grad_blk) -! CALL dbcsr_scale(step_blk,-1.0_dp*alpha) -! CALL generator_to_unitary(step_blk,U_blk,& -! almo_scf_env%eps_filter) -! CALL dbcsr_multiply("N","N",1.0_dp,Fov,U_blk,0.0_dp,temp0_ov,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& -! Fov_filtered) -! -! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 -! IF (line_search_step.eq.1) THEN -! ff1 = obj_function_new -! step1 = alpha -! ELSE IF (line_search_step.eq.2) THEN -! ff2 = obj_function_new -! step2 = alpha -! ENDIF -! -! IF (unit_nr>0.AND.(line_search_step.ne.line_search_step_last)) THEN -! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3)') & -! "JOINT_SVD_lin",& -! iteration,& -! alpha,& -! obj_function,& -! obj_function_new,& -! obj_function_new-obj_function -! ENDIF -! -! IF (line_search_step.eq.1) THEN -! alpha=2.0_dp*alpha -! ENDIF -! IF (line_search_step.eq.2) THEN -! a0 = ((ff1-c0)/step1 - (ff2-c0)/step2) / (step1 - step2) -! b0 = (ff1-c0)/step1 - a0*step1 -! ! step size in to the bottom of "the parabola" -! alpha=-b0/(2.0_dp*a0) -! ! update the default step size -! almo_scf_env%truncate_v_trial_step_size=alpha -! ENDIF -! !!!IF (line_search_step.eq.1) THEN -! !!! a0 = (obj_function_new - b0 * alpha - c0) / (alpha*alpha) -! !!! ! step size in to the bottom of "the parabola" -! !!! alpha=-b0/(2.0_dp*a0) -! !!! !IF (alpha.gt.10.0_dp) alpha=10.0_dp -! !!!ENDIF -! -! ENDDO -! -! ! update Fov and U_blk_tot (use grad_blk as tmp storage) -! CALL dbcsr_copy(Fov,temp0_ov) -! CALL dbcsr_multiply("N","N",1.0_dp,U_blk_tot,U_blk,& -! 0.0_dp,grad_blk,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_copy(U_blk_tot,grad_blk) -! -! ENDIF -! -! t2 = m_walltime() -! -! IF (unit_nr>0) THEN -! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3,E12.3,F10.3)') & -! "JOINT_SVD_itr",& -! iteration,& -! alpha,& -! obj_function,& -! obj_function_new,& -! obj_function_new-obj_function,& -! grad_norm,& -! t2-t1 -! !(flop1+flop2)/(1.0E6_dp*(t2-t1)) -! CALL m_flush(unit_nr) -! ENDIF -! -! t1 = m_walltime() -! -! IF (prepare_to_exit) EXIT -! -! ENDDO ! stop iterations -! -! IF (safe_mode) THEN -! CALL dbcsr_multiply("N","N",1.0_dp,Fov_original,& -! U_blk_tot,0.0_dp,temp0_ov,& -! filter_eps=almo_scf_env%eps_filter) -!CALL dbcsr_print(temp0_ov) -! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& -! Fov_filtered) -! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 -! -! IF (unit_nr>0) THEN -! WRITE(unit_nr,'(T6,A,1X,E12.3)') & -! "SANITY CHECK:",& -! obj_function_new -! CALL m_flush(unit_nr) -! ENDIF -! -! CALL dbcsr_release(Fov_original) -! ENDIF -! -! CALL dbcsr_release(temp0_ov) -! CALL dbcsr_release(U_blk) -! CALL dbcsr_release(grad_blk) -! CALL dbcsr_release(step_blk) -! CALL dbcsr_release(matrix_filter) -! CALL dbcsr_release(Fov) -! CALL dbcsr_release(Fov_filtered) -! -! ! compute rotated virtual orbitals -! CALL dbcsr_init(v_full_tmp) -! CALL dbcsr_create(v_full_tmp,& -! template=almo_scf_env%matrix_v_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! v_full_new,& -! matrix_sigma_vv_full_sqrt_inv,0.0_dp,v_full_tmp,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! v_full_tmp,& -! U_blk_tot,0.0_dp,v_full_new,& -! filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_release(matrix_sigma_vv_full_sqrt_inv) -! CALL dbcsr_release(v_full_tmp) -! CALL dbcsr_release(U_blk_tot) -! -!!!!! orthogonalized virtuals are not blocked -! ! copy new virtuals into the truncated matrix -! !CALL dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin),& -! CALL dbcsr_work_create(almo_scf_env%matrix_v(ispin),& -! work_mutable=.TRUE.) -! CALL dbcsr_iterator_start(iter,v_full_new) -! DO WHILE (dbcsr_iterator_blocks_left(iter)) -! -! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -! row_size=iblock_row_size,col_size=iblock_col_size) -! -! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) -! -! CALL dbcsr_put_block(almo_scf_env%matrix_v(ispin), iblock_row,iblock_col,data_p(:,1:retained_v)) -! CPASSERT(retained_v.gt.0) -! -! ENDDO ! iterator -! CALL dbcsr_iterator_stop(iter) -! !!CALL dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin)) -! CALL dbcsr_finalize(almo_scf_env%matrix_v(ispin)) -! -! CALL dbcsr_release(v_full_new) -! -! ENDDO ! ispin -! -! CALL timestop(handle) -! -! END SUBROUTINE truncate_subspace_v_blk - ! ************************************************************************************************** !> \brief Compute the gradient wrt the main variable (e.g. Theta, X) !> \param m_grad_out ... @@ -6049,44 +5117,9 @@ CONTAINS template=m_t, & matrix_type=dbcsr_type_no_symmetry) - ! do d_E/d_T first - !IF (.NOT.PRESENT(m_FTsiginv)) THEN - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_ks,& - ! m_t,& - ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=eps_filter) - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_tmp_no_1,& - ! m_siginv,& - ! 0.0_dp,m_FTsiginv,& - ! filter_eps=eps_filter) - !ENDIF - CALL dbcsr_copy(m_tmp_no_2, m_quench_t) CALL dbcsr_copy(m_tmp_no_2, m_FTsiginv, keep_sparsity=.TRUE.) - !IF (.NOT.PRESENT(m_siginvTFTsiginv)) THEN - ! CALL dbcsr_multiply("T","N",1.0_dp,& - ! m_t,& - ! m_FTsiginv,& - ! 0.0_dp,m_tmp_oo_1,& - ! filter_eps=eps_filter) - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_siginv,& - ! m_tmp_oo_1,& - ! 0.0_dp,m_siginvTFTsiginv,& - ! filter_eps=eps_filter) - !ENDIF - - !IF (.NOT.PRESENT(m_ST)) THEN - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_s,& - ! m_t,& - ! 0.0_dp,m_ST,& - ! filter_eps=eps_filter) - !ENDIF - CALL dbcsr_multiply("N", "N", -1.0_dp, & m_ST, & m_siginvTFTsiginv, & @@ -6134,15 +5167,12 @@ CONTAINS SELECT CASE (2) ! allows for selection of different spread functionals CASE (1) ! functional = -W_I * log( |z_I|^2 ) CPABORT("Localization function is not implemented") - !coeff = -(weights(idim0)/z2(ielem)) CASE (2) ! functional = W_I * ( 1 - |z_I|^2 ) coeff = -weights(idim0) CASE (3) ! functional = W_I * ( 1 - |z_I| ) CPABORT("Localization function is not implemented") - !coeff = -(weights(idim0)/(2.0_dp*z2(ielem))) END SELECT CALL dbcsr_add(temp2, temp1, 1.0_dp, coeff) - !CALL dbcsr_add(grad_loc, temp1, 1.0_dp, 1.0_dp) END DO ! end loop over idim0 CALL dbcsr_add(m_tmp_no_2, temp2, my_energy_coeff, my_localiz_coeff*4.0_dp) @@ -6150,13 +5180,6 @@ CONTAINS ! add penalty on the occupied volume: det(sigma) IF (penalty_occ_vol) THEN - !RZK-warning CALL dbcsr_multiply("N","N",& - !RZK-warning penalty_occ_vol_prefactor,& - !RZK-warning m_ST,& - !RZK-warning m_siginv,& - !RZK-warning 1.0_dp,m_tmp_no_2,& - !RZK-warning retain_sparsity=.TRUE.,& - !RZK-warning ) CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", & penalty_occ_vol_prefactor, & @@ -6167,7 +5190,6 @@ CONTAINS ! this norm does not contain the normalization factors penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) energy_g_norm = dbcsr_maxabs(m_tmp_no_2) - !WRITE (*, "(A30,2F20.10)") "Energy/penalty g norms (no norm): ", energy_g_norm, penalty_occ_vol_g_norm CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, 1.0_dp) END IF @@ -6181,17 +5203,6 @@ CONTAINS ! This is because tr(T).G_Energy = 0 and ! tr(T).G_Penalty = c0*I - !! faster way to take the norm into account (tested for vol penalty olny) - !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) - !!CALL dbcsr_copy(m_tmp_no_1, m_ST, keep_sparsity=.TRUE.) - !!CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, -penalty_occ_vol_prefactor) - !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) - !!CALL dbcsr_multiply("N", "N", 1.0_dp, & - !! m_tmp_no_2, & - !! m_sig_sqrti_ii, & - !! 0.0_dp, m_tmp_no_1, & - !! retain_sparsity=.TRUE.) - ! slower way of taking the norm into account CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -6266,34 +5277,6 @@ CONTAINS CALL dbcsr_copy(m_tmp_no_1, m_grad_out) END IF - !! check whether the gradient lies entirely in R or Q - !CALL dbcsr_multiply("T","N",1.0_dp,& - ! m_t,& - ! m_tmp_no_1,& - ! 0.0_dp,m_tmp_oo_1,& - ! filter_eps=eps_filter,& - ! ) - !CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_siginv,& - ! m_tmp_oo_1,& - ! 0.0_dp,m_tmp_oo_2,& - ! filter_eps=eps_filter,& - ! ) - !CALL dbcsr_copy(m_tmp_no_2,m_tmp_no_1) - !CALL dbcsr_multiply("N","N",-1.0_dp,& - ! m_ST,& - ! m_tmp_oo_2,& - ! 1.0_dp,m_tmp_no_2,& - ! retain_sparsity=.TRUE.,& - ! ) - !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) - !WRITE(*,"(A50,2F20.10)") "Virtual-space projection of the gradient", penalty_occ_vol_g_norm - !CALL dbcsr_add(m_tmp_no_2,m_tmp_no_1,1.0_dp,-1.0_dp) - !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) - !WRITE(*,"(A50,2F20.10)") "Occupied-space projection of the gradient", penalty_occ_vol_g_norm - !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) - !WRITE(*,"(A50,2F20.10)") "Full gradient", penalty_occ_vol_g_norm - ! transform d_E/d_T to d_E/d_theta IF (optimize_theta) THEN CALL dbcsr_copy(m_tmp_no_2, m_theta) @@ -6651,7 +5634,6 @@ CONTAINS CALL dbcsr_get_diag(m_temp_oo_4, tg_diagonal) CALL dbcsr_set(m_temp_oo_4, 0.0_dp) CALL dbcsr_set_diag(m_temp_oo_4, tg_diagonal) - !CALL para_group%sum(tg_diagonal) z2(:) = z2(:) + tg_diagonal(:)*tg_diagonal(:) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -7052,15 +6034,6 @@ CONTAINS CALL dbcsr_copy(m_f_vv_out, m_prec_out) END IF -#if 0 -!penalty_only=.TRUE. - WRITE (unit_nr, *) "prefactor0:", penalty_occ_vol_prefactor - !IF (penalty_occ_vol) THEN - CALL dbcsr_desymmetrize(m_s, & - m_prec_out) - !CALL dbcsr_scale(m_prec_out,-penalty_occ_vol_prefactor) - !ENDIF -#else ! sum up the F_vv and S_vv terms CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, 1.0_dp) @@ -7072,7 +6045,6 @@ CONTAINS CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, penalty_occ_vol_prefactor) END IF -#endif CALL dbcsr_copy(m_tmp_nn_1, m_prec_out) @@ -7168,67 +6140,6 @@ CONTAINS END IF ! special_case - ! invert using cholesky (works with S matrix, will not work with S-SRS matrix) - !!!CALL cp_dbcsr_cholesky_decompose(prec_vv,& - !!! para_env=almo_scf_env%para_env,& - !!! blacs_env=almo_scf_env%blacs_env) - !!!CALL cp_dbcsr_cholesky_invert(prec_vv,& - !!! para_env=almo_scf_env%para_env,& - !!! blacs_env=almo_scf_env%blacs_env,& - !!! uplo_to_full=.TRUE.) - !!!CALL dbcsr_filter(prec_vv,& - !!! almo_scf_env%eps_filter) - !!! - - ! re-create the matrix because desymmetrize is buggy - - ! it will create multiple copies of blocks - !!!DESYM!CALL dbcsr_create(prec_vv,& - !!!DESYM! template=almo_scf_env%matrix_s(1),& - !!!DESYM! matrix_type=dbcsr_type_no_symmetry) - !!!DESYM!CALL dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& - !!!DESYM! prec_vv) - !CALL dbcsr_multiply("N","N",1.0_dp,& - ! almo_scf_env%matrix_s(1),& - ! matrix_t_out(ispin),& - ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=almo_scf_env%eps_filter) - !CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_tmp_no_1,& - ! almo_scf_env%matrix_sigma_inv(ispin),& - ! 0.0_dp,m_tmp_no_3,& - ! filter_eps=almo_scf_env%eps_filter) - !CALL dbcsr_multiply("N","T",-1.0_dp,& - ! m_tmp_no_3,& - ! m_tmp_no_1,& - ! 1.0_dp,prec_vv,& - ! filter_eps=almo_scf_env%eps_filter) - !CALL dbcsr_add_on_diag(prec_vv,& - ! prec_sf_mixing_s) - - !CALL dbcsr_create(prec_oo,& - ! template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - ! prec_oo) - !CALL dbcsr_filter(prec_oo,& - ! almo_scf_env%eps_filter) - - !! invert using cholesky - !CALL dbcsr_create(prec_oo_inv,& - ! template=prec_oo,& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_desymmetrize(prec_oo,& - ! prec_oo_inv) - !CALL cp_dbcsr_cholesky_decompose(prec_oo_inv,& - ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env) - !CALL cp_dbcsr_cholesky_invert(prec_oo_inv,& - ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env,& - ! uplo_to_full=.TRUE.) - CALL dbcsr_release(m_tmp_nn_1) CALL dbcsr_release(m_tmp_no_3) @@ -7574,10 +6485,6 @@ CONTAINS filter_eps=eps_filter) ! RZK-warning -! compute preconditioner even if we do not use it -! this is for debugging because compute_preconditioner includes -! computing F_vv and S_vv necessary for -! IF ( use_preconditioner ) THEN ! domain_s_inv and domain_r_down are never used with assume_t0_q0x=FALSE CALL compute_preconditioner( & @@ -7610,8 +6517,6 @@ CONTAINS skip_inversion=.FALSE. & ) -! ENDIF ! use_preconditioner - ! initial guess CALL dbcsr_copy(m_delta(ispin), m_quench_t(ispin)) ! in order to use dbcsr_set matrix blocks must exist @@ -7647,10 +6552,7 @@ CONTAINS penalty_occ_vol_pf2=penalty_occ_vol_pf2(ispin), & m_s=m_s(1), & para_env=para_env, & - blacs_env=blacs_env & - ) - ! correct solution by the spin factor - !CALL dbcsr_scale(m_zet(ispin),1.0_dp/(2.0_dp*spin_factor)) + blacs_env=blacs_env) ELSE ! use PCG to solve H.D=-G @@ -7675,10 +6577,7 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter & - !matrix_trimmer=,& - !use_trimmer=.FALSE.,& - ) + filter_eps=eps_filter) END IF ! special_case @@ -7732,8 +6631,7 @@ CONTAINS normalize_orbitals=normalize_orbitals, & penalty_occ_vol_prefactor=penalty_occ_vol_prefactor, & eps_filter=eps_filter, & - path_num=hessian_path_reuse & - ) + path_num=hessian_path_reuse) ! alpha is computed outside the spin loop numer = 0.0_dp @@ -7778,10 +6676,6 @@ CONTAINS ! compute the new step (apply preconditioner if available) IF (use_preconditioner) THEN - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....applying preconditioner...." - !ENDIF - IF (special_case == xalmo_case_block_diag .OR. & special_case == xalmo_case_fully_deloc) THEN @@ -7801,10 +6695,7 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter & - !matrix_trimmer=,& - !use_trimmer=.FALSE.,& - ) + filter_eps=eps_filter) END IF ! special case @@ -7837,7 +6728,6 @@ CONTAINS t2 = m_walltime() IF (unit_nr > 0) THEN - !iter_type=TRIM("ALMO SCF "//iter_type) iter_type = TRIM("NR STEP") WRITE (unit_nr, '(T6,A9,I6,F14.5,F14.5,F15.10,F9.2)') & iter_type, iteration, & @@ -7860,26 +6750,6 @@ CONTAINS END DO ! outer loop -! is not necessary if penalty_occ_vol_pf2=0.0 -#if 0 - - IF (penalty_occ_vol) THEN - - DO ispin = 1, nspins - - CALL dbcsr_copy(m_zet(ispin), m_grad(ispin)) - CALL dbcsr_dot(m_delta(ispin), m_zet(ispin), alpha) - WRITE (unit_nr, *) "trace(grad.delta): ", alpha - alpha = -1.0_dp/(penalty_occ_vol_pf2(ispin)*alpha - 1.0_dp) - WRITE (unit_nr, *) "correction alpha: ", alpha - CALL dbcsr_scale(m_delta(ispin), alpha) - - END DO - - END IF - -#endif - DO ispin = 1, nspins ! check whether the step lies entirely in R or Q @@ -8086,44 +6956,6 @@ CONTAINS ! apply pre-computed F_vv and S_vv to X -#if 0 -! RZK-warning: negative sign at penalty_prefactor_local is that -! magical fix for the negative definite problem -! (since penalty_prefactor_local<0 the coeff before S_vv must -! be multiplied by -1 to take the step in the right direction) -!CALL dbcsr_multiply("N","N",-4.0_dp*penalty_prefactor_local,& -! m_s_vv(ispin),& -! m_tmp_x_in,& -! 0.0_dp,m_tmp_no_1,& -! filter_eps=eps_filter) -!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) -!CALL dbcsr_multiply("N","N",1.0_dp,& -! m_tmp_no_1,& -! m_siginv(ispin),& -! 0.0_dp,m_x_out(ispin),& -! retain_sparsity=.TRUE.) - - CALL dbcsr_multiply("N", "N", 1.0_dp, & - m_s(1), & - m_tmp_x_in, & - 0.0_dp, m_tmp_no_1, & - filter_eps=eps_filter) - CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) - CALL dbcsr_multiply("N", "N", 1.0_dp, & - m_tmp_no_1, & - m_siginv(ispin), & - 0.0_dp, m_x_out(ispin), & - retain_sparsity=.TRUE.) - -!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) -!CALL dbcsr_multiply("N","N",1.0_dp,& -! m_s(1),& -! m_tmp_x_in,& -! 0.0_dp,m_x_out(ispin),& -! retain_sparsity=.TRUE.) - -#else - ! debugging: only vv matrices, oo matrices are kronecker CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -8140,75 +6972,6 @@ CONTAINS retain_sparsity=.TRUE.) CALL dbcsr_add(m_x_out(ispin), m_tmp_no_2, & 1.0_dp, -4.0_dp*penalty_prefactor_local + 1.0_dp) -#endif - -! ! F_vv.X.S_oo -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_ks_vv(ispin),& -! m_tmp_x_in,& -! 0.0_dp,m_tmp_no_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_tmp_no_1,& -! m_siginv(ispin),& -! 0.0_dp,m_x_out(ispin),& -! retain_sparsity=.TRUE.,& -! ) -! -! ! S_vv.X.F_oo -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_s_vv(ispin),& -! m_tmp_x_in,& -! 0.0_dp,m_tmp_no_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_tmp_no_1,& -! m_siginvTFTsiginv(ispin),& -! 0.0_dp,m_tmp_no_2,& -! retain_sparsity=.TRUE.,& -! ) -! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& -! 1.0_dp,-1.0_dp) -!! we have to add occ voll penalty here (the Svv termi (i.e. both Svv.D.Soo) -!! and STsiginv terms) -! -! ! S_vo.X^t.F_vo -! CALL dbcsr_multiply("T","N",1.0_dp,& -! m_tmp_x_in,& -! m_g_full(ispin),& -! 0.0_dp,m_tmp_oo_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_STsiginv(ispin),& -! m_tmp_oo_1,& -! 0.0_dp,m_tmp_no_2,& -! retain_sparsity=.TRUE.,& -! ) -! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& -! 1.0_dp,-1.0_dp) -! -! ! S_vo.X^t.F_vo -! CALL dbcsr_multiply("T","N",1.0_dp,& -! m_tmp_x_in,& -! m_STsiginv(ispin),& -! 0.0_dp,m_tmp_oo_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_g_full(ispin),& -! m_tmp_oo_1,& -! 0.0_dp,m_tmp_no_2,& -! retain_sparsity=.TRUE.,& -! ) -! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& -! 1.0_dp,-1.0_dp) ELSE IF (path_num == hessian_path_assemble) THEN @@ -8400,12 +7163,6 @@ CONTAINS WRITE (unit_nr, *) "penalty_prefactor_local: ", penalty_prefactor_local WRITE (unit_nr, *) "penalty_prefactor_2: ", penalty_occ_vol_pf2 - !CALL dbcsr_print(matrix_grad) - !CALL dbcsr_print(matrix_F_ao_sym) - !CALL dbcsr_print(matrix_S_ao_sym) - !CALL dbcsr_print(matrix_F_mo_sym) - !CALL dbcsr_print(matrix_S_mo_sym) - ! loop over domains to find the size of the Hessian H_size = 0 DO col = 1, nblkcols_tot @@ -8505,23 +7262,6 @@ CONTAINS S_mo_block(1:mo_block_sizes(row), 1:mo_block_sizes(col)) = block_p(:, :) END IF - !WRITE(*,*) "F_AO_BLOCK", row, col, ao_domain_sizes(row), ao_domain_sizes(col) - !DO ii=1,ao_domain_sizes(row) - ! WRITE(*,'(100F13.9)') F_ao_block(ii,:) - !ENDDO - !WRITE(*,*) "S_AO_BLOCK", row, col - !DO ii=1,ao_domain_sizes(row) - ! WRITE(*,'(100F13.9)') S_ao_block(ii,:) - !ENDDO - !WRITE(*,*) "F_MO_BLOCK", row, col - !DO ii=1,mo_block_sizes(row) - ! WRITE(*,'(100F13.9)') F_mo_block(ii,:) - !ENDDO - !WRITE(*,*) "S_MO_BLOCK", row, col, mo_block_sizes(row), mo_block_sizes(col) - !DO ii=1,mo_block_sizes(row) - ! WRITE(*,'(100F13.9)') S_mo_block(ii,:) - !ENDDO - ! construct tensor products for the current row-column fragment pair lev2_vert_offset = 0 DO orb_j = 1, mo_block_sizes(row) @@ -8531,16 +7271,8 @@ CONTAINS IF (orb_i == orb_j .AND. row == col) THEN H(lev1_vert_offset + lev2_vert_offset + 1:lev1_vert_offset + lev2_vert_offset + ao_domain_sizes(row), & lev1_hori_offset + lev2_hori_offset + 1:lev1_hori_offset + lev2_hori_offset + ao_domain_sizes(col)) & - != -penalty_prefactor_local*S_ao_block(:,:) = F_ao_block(:, :) + S_ao_block(:, :) -!=S_ao_block(:,:) -!RZK-warning =F_ao_block(:,:)+( 1.0_dp + penalty_prefactor_local )*S_ao_block(:,:) -! =S_mo_block(orb_j,orb_i)*F_ao_block(:,:)& -! -F_mo_block(orb_j,orb_i)*S_ao_block(:,:)& -! +penalty_prefactor_local*S_mo_block(orb_j,orb_i)*S_ao_block(:,:) END IF - !WRITE(*,*) row, col, orb_j, orb_i, lev1_vert_offset+lev2_vert_offset+1, ao_domain_sizes(row),& - ! lev1_hori_offset+lev2_hori_offset+1, ao_domain_sizes(col), S_mo_block(orb_j,orb_i) lev2_hori_offset = lev2_hori_offset + ao_domain_sizes(col) @@ -8568,180 +7300,6 @@ CONTAINS CALL dbcsr_release(matrix_S_mo_sym) CALL dbcsr_release(matrix_F_mo_sym) -!! ! Two more terms of the Hessian: S_vo.D.F_vo and F_vo.D.S_vo -!! ! It seems that these terms break positive definite property of the Hessian -!! ALLOCATE(H1(H_size,H_size)) -!! ALLOCATE(H2(H_size,H_size)) -!! H1=0.0_dp -!! H2=0.0_dp -!! DO row = 1, nblkcols_tot -!! -!! lev1_hori_offset=0 -!! DO col = 1, nblkcols_tot -!! -!! CALL dbcsr_get_block_p(matrix_F_vo,& -!! row, col, block_p, found) -!! CALL dbcsr_get_block_p(matrix_S_vo,& -!! row, col, block_p2, found2) -!! -!! lev1_vert_offset=0 -!! DO block_col = 1, nblkcols_tot -!! -!! CALL dbcsr_get_block_p(quench_t,& -!! row, block_col, p_new_block, found_row) -!! -!! IF (found_row) THEN -!! -!! ! determine offset in this short loop -!! lev2_vert_offset=0 -!! DO block_row=1,row-1 -!! CALL dbcsr_get_block_p(quench_t,& -!! block_row, block_col, p_new_block, found_col) -!! IF (found_col) lev2_vert_offset=lev2_vert_offset+ao_block_sizes(block_row) -!! ENDDO -!! !!!!!!!! short loop -!! -!! ! over all electrons of the block -!! DO orb_i=1, mo_block_sizes(col) -!! -!! ! into all possible locations -!! DO orb_j=1, mo_block_sizes(block_col) -!! -!! ! column is copied several times -!! DO copy=1, ao_domain_sizes(col) -!! -!! IF (found) THEN -!! -!! !WRITE(*,*) row, col, block_col, orb_i, orb_j, copy,& -!! ! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1,& -!! ! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy -!! -!! H1( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& -!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& -!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& -!! =block_p(:,orb_i) -!! -!! ENDIF ! found block in the data matrix -!! -!! IF (found2) THEN -!! -!! H2( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& -!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& -!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& -!! =block_p2(:,orb_i) -!! -!! ENDIF ! found block in the data matrix -!! -!! ENDDO -!! -!! ENDDO -!! -!! ENDDO -!! -!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) -!! -!! ENDIF ! found block in the quench matrix -!! -!! lev1_vert_offset=lev1_vert_offset+& -!! ao_domain_sizes(block_col)*mo_block_sizes(block_col) -!! -!! ENDDO -!! -!! lev1_hori_offset=lev1_hori_offset+& -!! ao_domain_sizes(col)*mo_block_sizes(col) -!! -!! ENDDO -!! -!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) -!! -!! ENDDO -!! H1(:,:)=H1(:,:)*2.0_dp*spin_factor -!! !!!WRITE(*,*) "F_vo" -!! !!!DO ii=1,H_size -!! !!! WRITE(*,'(100F13.9)') H1(ii,:) -!! !!!ENDDO -!! !!!WRITE(*,*) "S_vo" -!! !!!DO ii=1,H_size -!! !!! WRITE(*,'(100F13.9)') H2(ii,:) -!! !!!ENDDO -!! !!!!! add terms to the hessian -!! DO ii=1,H_size -!! DO jj=1,H_size -!!! add penalty_occ_vol term -!! H(ii,jj)=H(ii,jj)-H1(ii,jj)*H2(jj,ii)-H1(jj,ii)*H2(ii,jj) -!! ENDDO -!! ENDDO -!! DEALLOCATE(H1) -!! DEALLOCATE(H2) - -!! ! S_vo.S_vo diagonal component due to determiant constraint -!! ! use grad vector temporarily -!! IF (penalty_occ_vol) THEN -!! ALLOCATE(Grad_vec(H_size)) -!! Grad_vec(:)=0.0_dp -!! lev1_vert_offset=0 -!! ! loop over all electron blocks -!! DO col = 1, nblkcols_tot -!! -!! ! loop over AO-rows of the dbcsr matrix -!! lev2_vert_offset=0 -!! DO row = 1, nblkrows_tot -!! -!! CALL dbcsr_get_block_p(quench_t,& -!! row, col, block_p, found_row) -!! IF (found_row) THEN -!! -!! CALL dbcsr_get_block_p(matrix_S_vo,& -!! row, col, block_p, found) -!! IF (found) THEN -!! ! copy the data into the vector, column by column -!! DO orb_i=1, mo_block_sizes(col) -!! Grad_vec(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& -!! lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& -!! =block_p(:,orb_i) -!! ENDDO -!! -!! ENDIF -!! -!! lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) -!! -!! ENDIF -!! -!! ENDDO -!! -!! lev1_vert_offset=lev1_vert_offset+ao_domain_sizes(col)*mo_block_sizes(col) -!! -!! ENDDO ! loop over electron blocks -!! ! update H now -!! DO ii=1,H_size -!! DO jj=1,H_size -!! H(ii,jj)=H(ii,jj)+penalty_occ_vol_prefactor*& -!! penalty_occ_vol_pf2*Grad_vec(ii)*Grad_vec(jj) -!! ENDDO -!! ENDDO -!! DEALLOCATE(Grad_vec) -!! ENDIF ! penalty_occ_vol - -!S-1.G ! invert S using cholesky -!S-1.G CALL dbcsr_create(m_prec_out,& -!S-1.G template=m_s,& -!S-1.G matrix_type=dbcsr_type_no_symmetry) -!S-1.G CALL dbcsr_copy(m_prec_out,m_s) -!S-1.G CALL dbcsr_cholesky_decompose(m_prec_out,& -!S-1.G para_env=para_env,& -!S-1.G blacs_env=blacs_env) -!S-1.G CALL dbcsr_cholesky_invert(m_prec_out,& -!S-1.G para_env=para_env,& -!S-1.G blacs_env=blacs_env,& -!S-1.G uplo_to_full=.TRUE.) -!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& -!S-1.G m_prec_out,& -!S-1.G matrix_grad,& -!S-1.G 0.0_dp,matrix_step,& -!S-1.G filter_eps=1.0E-10_dp) -!S-1.G !CALL dbcsr_release(m_prec_out) -!S-1.G ALLOCATE(test3(H_size)) - ! convert gradient from the dbcsr matrix to the vector form ALLOCATE (Grad_vec(H_size)) Grad_vec(:) = 0.0_dp @@ -8765,22 +7323,10 @@ CONTAINS Grad_vec(lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + 1: & lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + ao_block_sizes(row)) & = block_p(:, orb_i) -!WRITE(*,*) "GRAD: ", row, col, orb_i, lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1, ao_block_sizes(row) END DO END IF -!S-1.G CALL dbcsr_get_block_p(matrix_step,& -!S-1.G row, col, block_p, found) -!S-1.G IF (found) THEN -!S-1.G ! copy the data into the vector, column by column -!S-1.G DO orb_i=1, mo_block_sizes(col) -!S-1.G test3(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& -!S-1.G lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& -!S-1.G =block_p(:,orb_i) -!S-1.G ENDDO -!S-1.G ENDIF - lev2_vert_offset = lev2_vert_offset + ao_block_sizes(row) END IF @@ -8791,12 +7337,6 @@ CONTAINS END DO ! loop over electron blocks - !WRITE(*,*) "HESSIAN" - !DO ii=1,H_size - ! WRITE(*,*) ii - ! WRITE(*,'(20F14.10)') H(ii,:) - !ENDDO - ! invert the Hessian INFO = 0 ALLOCATE (Hinv(H_size, H_size)) @@ -8824,21 +7364,6 @@ CONTAINS ! Step_vec contains Grad_vec here Step_vec(:) = MATMUL(TRANSPOSE(Hinv), Grad_vec) - ! compute U.tr(U)-1 = error - !ALLOCATE(test(H_size,H_size)) - !test(:,:)=MATMUL(TRANSPOSE(Hinv),Hinv) - !DO ii=1,H_size - ! test(ii,ii)=test(ii,ii)-1.0_dp - !ENDDO - !test_error=0.0_dp - !DO ii=1,H_size - ! DO jj=1,H_size - ! test_error=test_error+test(jj,ii)*test(jj,ii) - ! ENDDO - !ENDDO - !WRITE(*,*) "U.tr(U)-1 error: ", SQRT(test_error) - !DEALLOCATE(test) - ! invert eigenvalues and use eigenvectors to compute the Hessian inverse ! project out zero-eigenvalue directions ALLOCATE (test(H_size, H_size)) @@ -8860,46 +7385,8 @@ CONTAINS Hinv(:, :) = test2(:, :) DEALLOCATE (test, test2) - !! shift to kill singularity - !shift=0.0_dp - !IF (eigenvalues(1).lt.0.0_dp) THEN - ! CPABORT("Negative eigenvalue(s)") - ! shift=abs(eigenvalues(1)) - ! WRITE(*,*) "Lowest eigenvalue: ", eigenvalues(1) - !ENDIF - !DO ii=1, H_size - ! IF (eigenvalues(ii).gt.eps_zero) THEN - ! shift=shift+min(1.0_dp,eigenvalues(ii))*1.0E-4_dp - ! EXIT - ! ENDIF - !ENDDO - !WRITE(*,*) "Hessian shift: ", shift - !DO ii=1, H_size - ! H(ii,ii)=H(ii,ii)+shift - !ENDDO - !! end shift - DEALLOCATE (eigenvalues) -!!!! Hinv=H -!!!! INFO=0 -!!!! CALL dpotrf('L', H_size, Hinv, H_size, INFO ) -!!!! IF( INFO/=0 ) THEN -!!!! WRITE(*,*) 'DPOTRF ERROR MESSAGE: ', INFO -!!!! CPABORT("DPOTRF failed") -!!!! END IF -!!!! CALL dpotri('L', H_size, Hinv, H_size, INFO ) -!!!! IF( INFO/=0 ) THEN -!!!! WRITE(*,*) 'DPOTRI ERROR MESSAGE: ', INFO -!!!! CPABORT("DPOTRI failed") -!!!! END IF -!!!! ! complete the matrix -!!!! DO ii=1,H_size -!!!! DO jj=ii+1,H_size -!!!! Hinv(ii,jj)=Hinv(jj,ii) -!!!! ENDDO -!!!! ENDDO - ! compute the inversion error ALLOCATE (test(H_size, H_size)) test(:, :) = MATMUL(Hinv, H) @@ -8919,7 +7406,6 @@ CONTAINS ALLOCATE (Step_vec(H_size)) ALLOCATE (tmp(H_size)) tmp(:) = MATMUL(Hinv, Grad_vec) - !tmp(:)=MATMUL(Hinv,test3) Step_vec(:) = -1.0_dp*tmp(:) ALLOCATE (tmpr(H_size)) @@ -8977,19 +7463,6 @@ CONTAINS CALL dbcsr_finalize(matrix_step) -!S-1.G CALL dbcsr_create(m_tmp_no_1,& -!S-1.G template=matrix_step,& -!S-1.G matrix_type=dbcsr_type_no_symmetry) -!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& -!S-1.G m_prec_out,& -!S-1.G matrix_step,& -!S-1.G 0.0_dp,m_tmp_no_1,& -!S-1.G filter_eps=1.0E-10_dp,& -!S-1.G ) -!S-1.G CALL dbcsr_copy(matrix_step,m_tmp_no_1) -!S-1.G CALL dbcsr_release(m_tmp_no_1) -!S-1.G CALL dbcsr_release(m_prec_out) - DEALLOCATE (mo_block_sizes, ao_block_sizes) DEALLOCATE (ao_domain_sizes) @@ -9135,8 +7608,6 @@ CONTAINS ! penalty amplitude adjusts the strength of volume conservation penalty_occ_vol = .FALSE. - !(almo_scf_env%penalty%occ_vol_method /= almo_occ_vol_penalty_none .AND. & - ! my_special_case == xalmo_case_fully_deloc) normalize_orbitals = penalty_occ_vol penalty_amplitude = 0.0_dp !almo_scf_env%penalty%occ_vol_coeff ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) @@ -9406,8 +7877,6 @@ CONTAINS ! check convergence and other exit criteria DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin)) - !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & - ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin grad_norm_ref = MAXVAL(grad_norm_spin) @@ -9429,8 +7898,9 @@ CONTAINS scf_converged = .TRUE. border_reached = .FALSE. expected_reduction = 0.0_dp - IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) & + IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) THEN EXIT adjust_r_loop + END IF ELSE scf_converged = .FALSE. END IF @@ -9787,35 +8257,6 @@ CONTAINS END IF ! special_case - ! slower but more reliable way to get inverted hessian - !DO ispin = 1, nspins - ! CALL compute_preconditioner( & - ! domain_prec_out=domain_model_hessian_inv(:, ispin), & - ! m_prec_out=m_model_hessian_inv(ispin), & ! RZK-warning: this one is not inverted if DOMAINs - ! m_ks=almo_scf_env%matrix_ks(ispin), & - ! m_s=almo_scf_env%matrix_s(1), & - ! m_siginv=almo_scf_env%matrix_sigma_inv(ispin), & - ! m_quench_t=quench_t(ispin), & - ! m_FTsiginv=FTsiginv(ispin), & - ! m_siginvTFTsiginv=siginvTFTsiginv(ispin), & - ! m_ST=ST(ispin), & - ! para_env=almo_scf_env%para_env, & - ! blacs_env=almo_scf_env%blacs_env, & - ! nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), & - ! domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), & - ! domain_r_down=domain_r_down(:, ispin), & - ! cpu_of_domain=almo_scf_env%cpu_of_domain, & - ! domain_map=almo_scf_env%domain_map(ispin), & - ! assume_t0_q0x=.FALSE., & - ! penalty_occ_vol=penalty_occ_vol, & - ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), & - ! eps_filter=almo_scf_env%eps_filter, & - ! neg_thr=1.0E10_dp, & - ! spin_factor=spin_factor, & - ! skip_inversion=.FALSE., & - ! special_case=my_special_case) - !ENDDO ! ispin - CASE DEFAULT CPABORT("Unknown preconditioner") @@ -9898,8 +8339,9 @@ CONTAINS ) IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size IF (step_size > 1.0_dp .OR. step_size < 0.0_dp) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Step size (", step_size, ") must lie inside (0,1)" + END IF CPABORT("Wrong dog leg step. We should never end up here.") END IF @@ -9966,8 +8408,6 @@ CONTAINS ! Model grad norm DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(m_model_r(ispin)) - !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & - ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin model_grad_norm = MAXVAL(grad_norm_spin) @@ -10081,7 +8521,6 @@ CONTAINS END DO ! ispin ! compute the energy - !IF (.NOT. same_position) THEN CALL main_var_to_xalmos_and_loss_func( & almo_scf_env=almo_scf_env, & qs_env=qs_env, & @@ -10104,7 +8543,6 @@ CONTAINS do_penalty=penalty_occ_vol, & special_case=my_special_case) loss_trial = energy_trial + penalty_trial - !ENDIF ! not same_position rho = (loss_trial - loss_start)/expected_reduction loss_change_to_report = loss_trial - loss_start diff --git a/src/almo_scf_qs.F b/src/almo_scf_qs.F index 99b41e1c95..82bf191e1c 100644 --- a/src/almo_scf_qs.F +++ b/src/almo_scf_qs.F @@ -288,63 +288,6 @@ CONTAINS CALL dbcsr_work_create(matrix_new, work_mutable=.TRUE.) CALL dbcsr_get_info(matrix_new, nblkrows_total=nblkrows_tot, & row_blk_size=row_blk_size, col_blk_size=col_blk_size) - ! startQQQ - this part of the code scales quadratically - ! therefore it is replaced with a less general but linear scaling algorithm below - ! the quadratic algorithm is kept to be re-written later - !QQQCALL dbcsr_get_info(matrix_new, nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) - !QQQDO row = 1, nblkrows_tot - !QQQ DO col = 1, nblkcols_tot - !QQQ tr = .FALSE. - !QQQ iblock_row = row - !QQQ iblock_col = col - !QQQ CALL dbcsr_get_stored_coordinates(matrix_new, iblock_row, iblock_col, tr, hold) - - !QQQ IF(hold==mynode) THEN - !QQQ - !QQQ ! RZK-warning replace with a function which says if this - !QQQ ! distribution block is active or not - !QQQ ! Translate indeces of distribution blocks to domain blocks - !QQQ if (size_keys(1)==almo_mat_dim_aobasis) then - !QQQ domain_row=almo_scf_env%domain_index_of_ao_block(iblock_row) - !QQQ else if (size_keys(2)==almo_mat_dim_occ .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_disc .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_full) then - !QQQ domain_row=almo_scf_env%domain_index_of_mo_block(iblock_row) - !QQQ else - !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") - !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !QQQ endif - - !QQQ if (size_keys(2)==almo_mat_dim_aobasis) then - !QQQ domain_col=almo_scf_env%domain_index_of_ao_block(iblock_col) - !QQQ else if (size_keys(2)==almo_mat_dim_occ .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_disc .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_full) then - !QQQ domain_col=almo_scf_env%domain_index_of_mo_block(iblock_col) - !QQQ else - !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") - !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !QQQ endif - - !QQQ ! Finds if we need this block - !QQQ ! only the block-diagonal constraint is implemented here - !QQQ active=.false. - !QQQ if (domain_row==domain_col) active=.true. - - !QQQ IF (active) THEN - !QQQ ALLOCATE (new_block(row_blk_size(iblock_row), col_blk_size(iblock_col))) - !QQQ new_block(:, :) = 1.0_dp - !QQQ CALL dbcsr_put_block(matrix_new, iblock_row, iblock_col, new_block) - !QQQ DEALLOCATE (new_block) - !QQQ ENDIF - - !QQQ ENDIF ! mynode - !QQQ ENDDO - !QQQENDDO - !QQQtake care of zero-electron fragments - ! endQQQ - end of the quadratic part ! start linear-scaling replacement: ! works only for molecular blocks AND molecular distributions DO row = 1, nblkrows_tot @@ -611,7 +554,7 @@ CONTAINS n_el_f=REAL(almo_scf_env%nelectrons_total, dp), & maxocc=2.0_dp, & flexible_electron_count=dft_control%relax_multiplicity) - ELSEIF (almo_scf_env%nspins == 2) THEN + ELSE IF (almo_scf_env%nspins == 2) THEN CALL allocate_mo_set(mo_set=mos(ispin), & nao=nrow_fm, & nmo=ncol_fm, & @@ -1496,23 +1439,6 @@ CONTAINS DEALLOCATE (last_atom_of_molecule) END IF - !mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(& - ! dbcsr_distribution(almo_scf_env%quench_t(ispin)))) - !CALL dbcsr_get_info(almo_scf_env%quench_t(ispin), distribution=dist, & - ! nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) - !DO row = 1, nblkrows_tot - ! DO col = 1, nblkcols_tot - ! tr = .FALSE. - ! iblock_row = row - ! iblock_col = col - ! CALL dbcsr_get_stored_coordinates(almo_scf_env%quench_t(ispin),& - ! iblock_row, iblock_col, tr, hold) - ! CALL dbcsr_get_block_p(almo_scf_env%quench_t(ispin),& - ! row, col, p_old_block, found) - ! write(*,*) "RST_NOTE:", mynode, row, col, hold, found - ! ENDDO - !ENDDO - CALL timestop(handle) END SUBROUTINE almo_scf_construct_quencher diff --git a/src/almo_scf_types.F b/src/almo_scf_types.F index d4c9030aa1..a75d2577d9 100644 --- a/src/almo_scf_types.F +++ b/src/almo_scf_types.F @@ -569,8 +569,9 @@ CONTAINS DO istore = 1, MIN(almo_scf_env%almo_history%istore, almo_scf_env%almo_history%nstore) CALL dbcsr_release(almo_scf_env%almo_history%matrix_p_up_down(ispin, istore)) END DO - IF (almo_scf_env%almo_history%istore > 0) & + IF (almo_scf_env%almo_history%istore > 0) THEN CALL dbcsr_release(almo_scf_env%almo_history%matrix_t(ispin)) + END IF END DO DEALLOCATE (almo_scf_env%almo_history%matrix_p_up_down) DEALLOCATE (almo_scf_env%almo_history%matrix_t) @@ -580,8 +581,9 @@ CONTAINS CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_p_up_down(ispin, istore)) !CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_x(ispin, istore)) END DO - IF (almo_scf_env%xalmo_history%istore > 0) & + IF (almo_scf_env%xalmo_history%istore > 0) THEN CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_t(ispin)) + END IF END DO DEALLOCATE (almo_scf_env%xalmo_history%matrix_p_up_down) !DEALLOCATE (almo_scf_env%xalmo_history%matrix_x) diff --git a/src/aobasis/ai_contraction.F b/src/aobasis/ai_contraction.F index 57bacd8e99..02d87a97e3 100644 --- a/src/aobasis/ai_contraction.F +++ b/src/aobasis/ai_contraction.F @@ -439,7 +439,7 @@ CONTAINS ELSE qab(ia:ja, ib:jb) = qab(ia:ja, ib:jb) + sab(1:na, 1:nb) END IF - ELSEIF (dir == "OUT" .OR. dir == "out") THEN + ELSE IF (dir == "OUT" .OR. dir == "out") THEN ! SAB <= QAB(block) ja = ia + na - 1 jb = ib + nb - 1 diff --git a/src/aobasis/ai_eri_debug.F b/src/aobasis/ai_eri_debug.F index 4838e75ed3..ea40188793 100644 --- a/src/aobasis/ai_eri_debug.F +++ b/src/aobasis/ai_eri_debug.F @@ -128,16 +128,16 @@ CONTAINS IF (dn(1) > 0) THEN IABCD = os(an, bn, cn + i1, dn - i1) - (D(1) - C(1))*os(an, bn, cn, dn - i1) - ELSEIF (dn(2) > 0) THEN + ELSE IF (dn(2) > 0) THEN IABCD = os(an, bn, cn + i2, dn - i2) - (D(2) - C(2))*os(an, bn, cn, dn - i2) - ELSEIF (dn(3) > 0) THEN + ELSE IF (dn(3) > 0) THEN IABCD = os(an, bn, cn + i3, dn - i3) - (D(3) - C(3))*os(an, bn, cn, dn - i3) ELSE IF (bn(1) > 0) THEN IABCD = os(an + i1, bn - i1, cn, dn) - (B(1) - A(1))*os(an, bn - i1, cn, dn) - ELSEIF (bn(2) > 0) THEN + ELSE IF (bn(2) > 0) THEN IABCD = os(an + i2, bn - i2, cn, dn) - (B(2) - A(2))*os(an, bn - i2, cn, dn) - ELSEIF (bn(3) > 0) THEN + ELSE IF (bn(3) > 0) THEN IABCD = os(an + i3, bn - i3, cn, dn) - (B(3) - A(3))*os(an, bn - i3, cn, dn) ELSE IF (cn(1) > 0) THEN @@ -145,12 +145,12 @@ CONTAINS 0.5_dp*an(1)/eta*os(an - i1, bn, cn - i1, dn) + & 0.5_dp*(cn(1) - 1)/eta*os(an, bn, cn - i1 - i1, dn) - & xsi/eta*os(an + i1, bn, cn - i1, dn) - ELSEIF (cn(2) > 0) THEN + ELSE IF (cn(2) > 0) THEN IABCD = ((Q(2) - C(2)) + xsi/eta*(P(2) - A(2)))*os(an, bn, cn - i2, dn) + & 0.5_dp*an(2)/eta*os(an - i2, bn, cn - i2, dn) + & 0.5_dp*(cn(2) - 1)/eta*os(an, bn, cn - i2 - i2, dn) - & xsi/eta*os(an + i2, bn, cn - i2, dn) - ELSEIF (cn(3) > 0) THEN + ELSE IF (cn(3) > 0) THEN IABCD = ((Q(3) - C(3)) + xsi/eta*(P(3) - A(3)))*os(an, bn, cn - i3, dn) + & 0.5_dp*an(3)/eta*os(an - i3, bn, cn - i3, dn) + & 0.5_dp*(cn(3) - 1)/eta*os(an, bn, cn - i3 - i3, dn) - & @@ -161,12 +161,12 @@ CONTAINS (W(1) - P(1))*os(an - i1, bn, cn, dn, m + 1) + & 0.5_dp*(an(1) - 1)/xsi*os(an - i1 - i1, bn, cn, dn, m) - & 0.5_dp*(an(1) - 1)/xsi*rho/xsi*os(an - i1 - i1, bn, cn, dn, m + 1) - ELSEIF (an(2) > 0) THEN + ELSE IF (an(2) > 0) THEN IABCD = (P(2) - A(2))*os(an - i2, bn, cn, dn, m) + & (W(2) - P(2))*os(an - i2, bn, cn, dn, m + 1) + & 0.5_dp*(an(2) - 1)/xsi*os(an - i2 - i2, bn, cn, dn, m) - & 0.5_dp*(an(2) - 1)/xsi*rho/xsi*os(an - i2 - i2, bn, cn, dn, m + 1) - ELSEIF (an(3) > 0) THEN + ELSE IF (an(3) > 0) THEN IABCD = (P(3) - A(3))*os(an - i3, bn, cn, dn, m) + & (W(3) - P(3))*os(an - i3, bn, cn, dn, m + 1) + & 0.5_dp*(an(3) - 1)/xsi*os(an - i3 - i3, bn, cn, dn, m) - & diff --git a/src/aobasis/ai_os_rr.F b/src/aobasis/ai_os_rr.F index f5682c7b4c..f515ef089e 100644 --- a/src/aobasis/ai_os_rr.F +++ b/src/aobasis/ai_os_rr.F @@ -162,7 +162,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(az - 1, dp)*(rr(m, coa2z, 1) - rr(m + 1, coa2z, 1)) END DO END IF - ELSEIF (ay > 0) THEN + ELSE IF (ay > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(2)*rr(m, coa1y, 1) - rcp(2)*rr(m + 1, coa1y, 1) END DO @@ -171,7 +171,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(ay - 1, dp)*(rr(m, coa2y, 1) - rr(m + 1, coa2y, 1)) END DO END IF - ELSEIF (ax > 0) THEN + ELSE IF (ax > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(1)*rr(m, coa1x, 1) - rcp(1)*rr(m + 1, coa1x, 1) END DO @@ -225,7 +225,7 @@ CONTAINS rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(az, dp)*(rr(m, coa1z, cob1z) - rr(m + 1, coa1z, cob1z)) END DO END IF - ELSEIF (by > 0) THEN + ELSE IF (by > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(2)*rr(m, coa, cob1y) - rcp(2)*rr(m + 1, coa, cob1y) END DO @@ -239,7 +239,7 @@ CONTAINS rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(ay, dp)*(rr(m, coa1y, cob1y) - rr(m + 1, coa1y, cob1y)) END DO END IF - ELSEIF (bx > 0) THEN + ELSE IF (bx > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(1)*rr(m, coa, cob1x) - rcp(1)*rr(m + 1, coa, cob1x) END DO diff --git a/src/aobasis/ai_overlap.F b/src/aobasis/ai_overlap.F index 29b7a50a38..a3fe82c3e1 100644 --- a/src/aobasis/ai_overlap.F +++ b/src/aobasis/ai_overlap.F @@ -2050,12 +2050,12 @@ CONTAINS DO l = 0, la IF (l == 0) THEN fun(:, l) = z_one - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN fun(:, l) = CMPLX(0.0_dp, 0.5_dp*oa*gval(:), KIND=dp) - ELSEIF (l == 2) THEN + ELSE IF (l == 2) THEN fun(:, l) = CMPLX(-(0.5_dp*oa*gval(:))**2, 0.0_dp, KIND=dp) fun(:, l) = fun(:, l) + CMPLX(0.5_dp*oa, 0.0_dp, KIND=dp) - ELSEIF (l == 3) THEN + ELSE IF (l == 3) THEN fun(:, l) = CMPLX(0.0_dp, -(0.5_dp*oa*gval(:))**3, KIND=dp) fun(:, l) = fun(:, l) + CMPLX(0.0_dp, 0.75_dp*oa*oa*gval(:), KIND=dp) ELSE @@ -2065,12 +2065,12 @@ CONTAINS DO l = 0, lb IF (l == 0) THEN gun(:, l) = z_one - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN gun(:, l) = CMPLX(0.0_dp, 0.5_dp*ob*gval(:), KIND=dp) - ELSEIF (l == 2) THEN + ELSE IF (l == 2) THEN gun(:, l) = CMPLX(-(0.5_dp*ob*gval(:))**2, 0.0_dp, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.5_dp*ob, 0.0_dp, KIND=dp) - ELSEIF (l == 3) THEN + ELSE IF (l == 3) THEN gun(:, l) = CMPLX(0.0_dp, -(0.5_dp*ob*gval(:))**3, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.0_dp, 0.75_dp*ob*ob*gval(:), KIND=dp) ELSE diff --git a/src/aobasis/ai_overlap3_debug.F b/src/aobasis/ai_overlap3_debug.F index 2be04a16d7..76c062b1e8 100644 --- a/src/aobasis/ai_overlap3_debug.F +++ b/src/aobasis/ai_overlap3_debug.F @@ -99,25 +99,25 @@ CONTAINS IF (bn(1) > 0) THEN IACB = os_overlap3(an, cn + i1, bn - i1) + (C(1) - B(1))*os_overlap3(an, cn, bn - i1) - ELSEIF (bn(2) > 0) THEN + ELSE IF (bn(2) > 0) THEN IACB = os_overlap3(an, cn + i2, bn - i2) + (C(2) - B(2))*os_overlap3(an, cn, bn - i2) - ELSEIF (bn(3) > 0) THEN + ELSE IF (bn(3) > 0) THEN IACB = os_overlap3(an, cn + i3, bn - i3) + (C(3) - B(3))*os_overlap3(an, cn, bn - i3) ELSE IF (cn(1) > 0) THEN IACB = os_overlap3(an + i1, cn - i1, bn) + (A(1) - C(1))*os_overlap3(an, cn - i1, bn) - ELSEIF (cn(2) > 0) THEN + ELSE IF (cn(2) > 0) THEN IACB = os_overlap3(an + i2, cn - i2, bn) + (A(2) - C(2))*os_overlap3(an, cn - i2, bn) - ELSEIF (cn(3) > 0) THEN + ELSE IF (cn(3) > 0) THEN IACB = os_overlap3(an + i3, cn - i3, bn) + (A(3) - C(3))*os_overlap3(an, cn - i3, bn) ELSE IF (an(1) > 0) THEN IACB = (G(1) - A(1))*os_overlap3(an - i1, cn, bn) + & 0.5_dp*(an(1) - 1)/(xsi + xc)*os_overlap3(an - i1 - i1, cn, bn) - ELSEIF (an(2) > 0) THEN + ELSE IF (an(2) > 0) THEN IACB = (G(2) - A(2))*os_overlap3(an - i2, cn, bn) + & 0.5_dp*(an(2) - 1)/(xsi + xc)*os_overlap3(an - i2 - i2, cn, bn) - ELSEIF (an(3) > 0) THEN + ELSE IF (an(3) > 0) THEN IACB = (G(3) - A(3))*os_overlap3(an - i3, cn, bn) + & 0.5_dp*(an(3) - 1)/(xsi + xc)*os_overlap3(an - i3 - i3, cn, bn) ELSE diff --git a/src/aobasis/ai_overlap_debug.F b/src/aobasis/ai_overlap_debug.F index e25ec161b7..63bc5f7edc 100644 --- a/src/aobasis/ai_overlap_debug.F +++ b/src/aobasis/ai_overlap_debug.F @@ -87,18 +87,18 @@ CONTAINS IF (bn(1) > 0) THEN IAB = os_overlap2(an + i1, bn - i1) + (A(1) - B(1))*os_overlap2(an, bn - i1) - ELSEIF (bn(2) > 0) THEN + ELSE IF (bn(2) > 0) THEN IAB = os_overlap2(an + i2, bn - i2) + (A(2) - B(2))*os_overlap2(an, bn - i2) - ELSEIF (bn(3) > 0) THEN + ELSE IF (bn(3) > 0) THEN IAB = os_overlap2(an + i3, bn - i3) + (A(3) - B(3))*os_overlap2(an, bn - i3) ELSE IF (an(1) > 0) THEN IAB = (P(1) - A(1))*os_overlap2(an - i1, bn) + & 0.5_dp*(an(1) - 1)/xsi*os_overlap2(an - i1 - i1, bn) - ELSEIF (an(2) > 0) THEN + ELSE IF (an(2) > 0) THEN IAB = (P(2) - A(2))*os_overlap2(an - i2, bn) + & 0.5_dp*(an(2) - 1)/xsi*os_overlap2(an - i2 - i2, bn) - ELSEIF (an(3) > 0) THEN + ELSE IF (an(3) > 0) THEN IAB = (P(3) - A(3))*os_overlap2(an - i3, bn) + & 0.5_dp*(an(3) - 1)/xsi*os_overlap2(an - i3 - i3, bn) ELSE diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 3b2b3555fa..6f25224995 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -1680,8 +1680,9 @@ CONTAINS l(nshell(iset) - ishell + i, iset) = lshell END DO END DO - IF (LEN_TRIM(line_att) /= 0) & + IF (LEN_TRIM(line_att) /= 0) THEN CPABORT("Error reading the Basis from input file!") + END IF DO ipgf = 1, npgf(iset) is_ok = cp_sll_val_next(list, val) IF (.NOT. is_ok) CPABORT("Error reading the Basis set from input file!") @@ -2503,8 +2504,9 @@ CONTAINS ng = gto_basis_set%npgf(1) DO iset = 1, nset - IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) & + IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) THEN CPABORT("different number of primitves") + END IF END DO IF (do_ortho) THEN @@ -2682,7 +2684,7 @@ CONTAINS s00 = ai*aj*(pi*ab)**1.50_dp IF (l == 0) THEN sss = s00 - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN sss = s00*ab*0.5_dp ELSE CPABORT("aovlp lvalue") diff --git a/src/arnoldi/arnoldi_data_methods.F b/src/arnoldi/arnoldi_data_methods.F index 05acfa5bdb..d88400ae01 100644 --- a/src/arnoldi/arnoldi_data_methods.F +++ b/src/arnoldi/arnoldi_data_methods.F @@ -138,13 +138,15 @@ CONTAINS CALL control%mp_group%set_handle(group_handle) CALL control%pcol_group%set_handle(pcol_handle) - IF (.NOT. subgroups_defined) & + IF (.NOT. subgroups_defined) THEN CPABORT("arnoldi only with subgroups") + END IF control%symmetric = .FALSE. ! Will need a fix for complex because there it has to be hermitian - IF (SIZE(matrix) == 1) & + IF (SIZE(matrix) == 1) THEN control%symmetric = dbcsr_get_matrix_type(matrix(1)%matrix) == dbcsr_type_symmetric + END IF ! Set the control parameters control%max_iter = max_iter @@ -158,23 +160,28 @@ CONTAINS control%nrestart = nrestarts control%generalized_ev = generalized_ev - IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) & + IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) THEN CALL cp_abort(__LOCATION__, 'with more than one eigenvalue requested '// & 'internal restarting with a previous EVEC is a bad idea, set IRAM or nrestsart=0') + END IF ! some checks for the generalized EV mode - IF (control%generalized_ev .AND. selection_crit == 1) & + IF (control%generalized_ev .AND. selection_crit == 1) THEN CALL cp_abort(__LOCATION__, & 'generalized ev can only highest OR lowest EV') - IF (control%generalized_ev .AND. nval_request /= 1) & + END IF + IF (control%generalized_ev .AND. nval_request /= 1) THEN CALL cp_abort(__LOCATION__, & 'generalized ev can only compute one EV at the time') - IF (control%generalized_ev .AND. control%nrestart == 0) & + END IF + IF (control%generalized_ev .AND. control%nrestart == 0) THEN CALL cp_abort(__LOCATION__, & 'outer loops are mandatory for generalized EV, set nrestart appropriatly') - IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) & + END IF + IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) THEN CALL cp_abort(__LOCATION__, & 'generalized ev needs exactly two matrices as input (2nd is the metric)') + END IF ALLOCATE (control%selected_ind(max_iter)) CALL set_control(arnoldi_env, control) @@ -386,8 +393,9 @@ CONTAINS INTEGER :: ev_ind INTEGER, DIMENSION(:), POINTER :: selected_ind - IF (ind > get_nval_out(arnoldi_env)) & + IF (ind > get_nval_out(arnoldi_env)) THEN CPABORT('outside range of indexed evals') + END IF selected_ind => get_sel_ind(arnoldi_env) ev_ind = selected_ind(ind) @@ -411,8 +419,9 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: selected_ind NULLIFY (evals) - IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) & + IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) THEN CPABORT('array for eval output too small') + END IF selected_ind => get_sel_ind(arnoldi_env) evals => get_evals(arnoldi_env) diff --git a/src/arnoldi/arnoldi_geev.F b/src/arnoldi/arnoldi_geev.F index 5c014fca00..88390f9e2b 100644 --- a/src/arnoldi/arnoldi_geev.F +++ b/src/arnoldi/arnoldi_geev.F @@ -144,7 +144,7 @@ CONTAINS i = 1 DO WHILE (i <= ndim) IF (ABS(eval2(i)) < EPSILON(REAL(0.0, dp))) THEN - evec_r(:, i) = evec_r(:, i)/SQRT(DOT_PRODUCT(evec_r(:, i), evec_r(:, i))) + evec_r(:, i) = evec_r(:, i)/NORM2(evec_r(:, i)) revec(:, i) = CMPLX(evec_r(:, i), REAL(0.0, dp), dp) levec(:, i) = CMPLX(evec_l(:, i), REAL(0.0, dp), dp) i = i + 1 diff --git a/src/arnoldi/arnoldi_methods.F b/src/arnoldi/arnoldi_methods.F index 3ac3ef9ef7..2790c5d1b8 100644 --- a/src/arnoldi/arnoldi_methods.F +++ b/src/arnoldi/arnoldi_methods.F @@ -561,7 +561,7 @@ CONTAINS ar_data%local_history = Zmat ! broadcast the Hessenberg matrix so we don't need to care later on - DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat); + DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat) DEALLOCATE (Zmat); DEALLOCATE (BZmat) CALL timestop(handle) diff --git a/src/atom_electronic_structure.F b/src/atom_electronic_structure.F index c180ff67a2..d490a9d9f6 100644 --- a/src/atom_electronic_structure.F +++ b/src/atom_electronic_structure.F @@ -343,10 +343,10 @@ CONTAINS xcmat%op = 0._dp CALL calculate_atom_vxc_lda(xcmat, atom, xc_section) ! ZMP added options for the zmp calculations, building external density and vxc potential - ELSEIF (need_zmp) THEN + ELSE IF (need_zmp) THEN xcmat%op = 0._dp CALL calculate_atom_zmp(ext_density=ext_density, atom=atom, lprint=.FALSE., xcmat=xcmat) - ELSEIF (need_vxc) THEN + ELSE IF (need_vxc) THEN xcmat%op = 0._dp CALL calculate_atom_ext_vxc(vxc=ext_vxc, atom=atom, lprint=.FALSE., xcmat=xcmat) ELSE @@ -503,10 +503,10 @@ CONTAINS ne = atom%state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSEIF (ne == 2._dp*nm) THEN !closed shell + ELSE IF (ne == 2._dp*nm) THEN !closed shell atom%state%occa(l, k) = nm atom%state%occb(l, k) = nm - ELSEIF (atom%state%multiplicity == -2) THEN !High spin case + ELSE IF (atom%state%multiplicity == -2) THEN !High spin case atom%state%occa(l, k) = MIN(ne, nm) atom%state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_energy.F b/src/atom_energy.F index 7d2a7b853d..c14bece975 100644 --- a/src/atom_energy.F +++ b/src/atom_energy.F @@ -1103,11 +1103,11 @@ CONTAINS IF (PRESENT(counter)) THEN WRITE (str, "(I12)") counter - ELSEIF (PRESENT(rval)) THEN + ELSE IF (PRESENT(rval)) THEN WRITE (str, "(G18.8)") rval - ELSEIF (PRESENT(ival)) THEN + ELSE IF (PRESENT(ival)) THEN WRITE (str, "(I12)") ival - ELSEIF (PRESENT(cval)) THEN + ELSE IF (PRESENT(cval)) THEN WRITE (str, "(A)") TRIM(ADJUSTL(cval)) ELSE WRITE (str, "(A)") "" diff --git a/src/atom_fit.F b/src/atom_fit.F index b80ba7e82d..0f9bf3b62a 100644 --- a/src/atom_fit.F +++ b/src/atom_fit.F @@ -657,7 +657,7 @@ CONTAINS ntarget = ntarget + 1 wtot = wtot + atom%weight*w_virt/100._dp END IF - ELSEIF (k < atom%state%maxn_occ(l)) THEN + ELSE IF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1) = w_semi atom%orbitals%wrefchg(k, l, 1) = w_semi/100._dp atom%orbitals%crefene(k, l, 1) = t_semi @@ -735,7 +735,7 @@ CONTAINS wtot = wtot + atom%weight*2._dp*w_virt/100._dp ntarget = ntarget + 2 END IF - ELSEIF (k < atom%state%maxn_occ(l)) THEN + ELSE IF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1:2) = w_semi atom%orbitals%wrefchg(k, l, 1:2) = w_semi/100._dp atom%orbitals%crefene(k, l, 1:2) = t_semi diff --git a/src/atom_grb.F b/src/atom_grb.F index 2575d79300..e23bccc669 100644 --- a/src/atom_grb.F +++ b/src/atom_grb.F @@ -152,8 +152,9 @@ CONTAINS CALL allocate_grid_atom(basis%grid) CALL section_vals_val_get(grb_section, "QUADRATURE", i_val=quadtype) CALL section_vals_val_get(grb_section, "GRID_POINTS", i_val=ngp) - IF (ngp <= 0) & + IF (ngp <= 0) THEN CPABORT("# point radial grid < 0") + END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp ! diff --git a/src/atom_kind_orbitals.F b/src/atom_kind_orbitals.F index 25c3265e68..30ceb56c06 100644 --- a/src/atom_kind_orbitals.F +++ b/src/atom_kind_orbitals.F @@ -273,7 +273,7 @@ CONTAINS ! total number of occupied orbitals IF (PRESENT(nocc) .AND. ghost) THEN nocc = 0 - ELSEIF (PRESENT(nocc)) THEN + ELSE IF (PRESENT(nocc)) THEN nocc = 0 DO l = 0, lmat DO k = 1, 7 diff --git a/src/atom_operators.F b/src/atom_operators.F index 3a0e95ab1d..6f1e65e81f 100644 --- a/src/atom_operators.F +++ b/src/atom_operators.F @@ -120,14 +120,14 @@ CONTAINS rc = potential%rcon sc = potential%scon cpot(1:m) = (basis%grid%rad(1:m)/rc)**sc - ELSEIF (potential%conf_type == barrier_conf) THEN + ELSE IF (potential%conf_type == barrier_conf) THEN om = potential%rcon ron = potential%scon rc = ron + om DO i = 1, m IF (basis%grid%rad(i) < ron) THEN cpot(i) = 0.0_dp - ELSEIF (basis%grid%rad(i) < rc) THEN + ELSE IF (basis%grid%rad(i) < rc) THEN x = (basis%grid%rad(i) - ron)/om x = 1._dp - x cpot(i) = -6._dp*x**5 + 15._dp*x**4 - 10._dp*x**3 + 1._dp diff --git a/src/atom_optimization.F b/src/atom_optimization.F index d2ffa6a3fc..8d4986d7a8 100644 --- a/src/atom_optimization.F +++ b/src/atom_optimization.F @@ -221,7 +221,7 @@ CONTAINS IF (nm < 1) nm = history%max_history fmat = a*history%hmat(nnow)%fmat + (1._dp - a)*history%hmat(nm)%fmat END IF - ELSEIF (history%hlen == 1) THEN + ELSE IF (history%hlen == 1) THEN fmat = history%hmat(nnow)%fmat ELSE CPABORT("Length of matrix history hlen < 1") diff --git a/src/atom_output.F b/src/atom_output.F index 59d577c206..8562be639a 100644 --- a/src/atom_output.F +++ b/src/atom_output.F @@ -192,16 +192,19 @@ CONTAINS WRITE (iw, '(T36,A,T61,F20.12)') " Virial (-V/T) ::", -atom%energy%epot/atom%energy%ekin END IF WRITE (iw, '(T36,A,T61,F20.12)') " Core Energy ::", atom%energy%ecore - IF (atom%energy%exc /= 0._dp) & + IF (atom%energy%exc /= 0._dp) THEN WRITE (iw, '(T36,A,T61,F20.12)') " XC Energy ::", atom%energy%exc + END IF WRITE (iw, '(T36,A,T61,F20.12)') " Coulomb Energy ::", atom%energy%ecoulomb - IF (atom%energy%eexchange /= 0._dp) & + IF (atom%energy%eexchange /= 0._dp) THEN WRITE (iw, '(T34,A,T61,F20.12)') "HF Exchange Energy ::", atom%energy%eexchange + END IF IF (atom%potential%ppot_type /= NO_PSEUDO) THEN WRITE (iw, '(T20,A,T61,F20.12)') " Total Pseudopotential Energy ::", atom%energy%epseudo WRITE (iw, '(T20,A,T61,F20.12)') " Local Pseudopotential Energy ::", atom%energy%eploc - IF (atom%energy%elsd /= 0._dp) & + IF (atom%energy%elsd /= 0._dp) THEN WRITE (iw, '(T20,A,T61,F20.12)') " Local Spin-potential Energy ::", atom%energy%elsd + END IF WRITE (iw, '(T20,A,T61,F20.12)') " Nonlocal Pseudopotential Energy ::", atom%energy%epnl END IF IF (atom%potential%confinement) THEN diff --git a/src/atom_pseudo.F b/src/atom_pseudo.F index 7064b7a535..c77de88e67 100644 --- a/src/atom_pseudo.F +++ b/src/atom_pseudo.F @@ -257,10 +257,10 @@ CONTAINS ne = state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSEIF (ne == 2._dp*nm) THEN !closed shell + ELSE IF (ne == 2._dp*nm) THEN !closed shell state%occa(l, k) = nm state%occb(l, k) = nm - ELSEIF (state%multiplicity == -2) THEN !High spin case + ELSE IF (state%multiplicity == -2) THEN !High spin case state%occa(l, k) = MIN(ne, nm) state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_set_basis.F b/src/atom_set_basis.F index 767bc5a76e..f66006b6d4 100644 --- a/src/atom_set_basis.F +++ b/src/atom_set_basis.F @@ -204,7 +204,7 @@ CONTAINS basis%ddbf(k, i, l) = (REAL(l*(l - 1), dp)*rk**(l - 2) - & 2._dp*al*REAL(2*l + 1, dp)*rk**(l) + 4._dp*al*rk**(l + 2))*ear END DO - ELSEIF (basis%basis_type == CGTO_BASIS) THEN + ELSE IF (basis%basis_type == CGTO_BASIS) THEN DO k = 1, nr rk = basis%grid%rad(k) ear = EXP(-al*basis%grid%rad(k)**2) diff --git a/src/atom_sgp.F b/src/atom_sgp.F index 178e7e93bd..2289ec8964 100644 --- a/src/atom_sgp.F +++ b/src/atom_sgp.F @@ -122,7 +122,7 @@ CONTAINS ! generate the transformed potentials IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, basis) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upf_sgp_constr(upf_pot, sgp_pot, basis) ELSE CPABORT("Either ecp_pot or upf_pot is needed for sgp_construction") @@ -137,7 +137,7 @@ CONTAINS ! IF (is_ecp) THEN CALL ecpints(hnl%op, basis, ecp_pot) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upfints(core%op, hnl%op, basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pot or upf_pot is needed for sgp_construction") @@ -246,7 +246,7 @@ CONTAINS IF (do_transform) THEN IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, atom_ref%basis) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upf_sgp_constr(upf_pot, sgp_pot, atom_ref%basis) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") @@ -279,7 +279,7 @@ CONTAINS ! IF (is_ecp) THEN CALL ecpints(hnl%op, atom_ref%basis, ecp_pot) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upfints(core%op, hnl%op, atom_ref%basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") diff --git a/src/atom_types.F b/src/atom_types.F index 502369a13b..a1a2a54115 100644 --- a/src/atom_types.F +++ b/src/atom_types.F @@ -414,8 +414,9 @@ CONTAINS CALL allocate_grid_atom(basis%grid) CALL section_vals_val_get(basis_section, "QUADRATURE", i_val=quadtype) CALL section_vals_val_get(basis_section, "GRID_POINTS", i_val=ngp) - IF (ngp <= 0) & + IF (ngp <= 0) THEN CPABORT("The number of radial grid points must be greater than zero.") + END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp basis%geometrical = .FALSE. @@ -840,8 +841,9 @@ CONTAINS CALL allocate_grid_atom(gbasis%grid) ngp = SIZE(r) quadtype = do_gapw_log - IF (ngp <= 0) & + IF (ngp <= 0) THEN CPABORT("The number of radial grid points must be greater than zero.") + END IF CALL create_grid_atom(gbasis%grid, ngp, 1, 1, 0, quadtype) gbasis%grid%nr = ngp gbasis%grid%rad(:) = r(:) diff --git a/src/atom_upf.F b/src/atom_upf.F index 3a19e15d04..8c226de646 100644 --- a/src/atom_upf.F +++ b/src/atom_upf.F @@ -218,39 +218,39 @@ CONTAINS IF (nametag(2:8) == "PP_INFO") THEN CPASSERT(nametag(9:9) == ">") CALL upf_info_section(parser, pot) - ELSEIF (nametag(2:10) == "PP_HEADER") THEN + ELSE IF (nametag(2:10) == "PP_HEADER") THEN IF (.NOT. (nametag(11:11) == ">")) THEN CALL upf_header_option(parser, pot) END IF - ELSEIF (nametag(2:8) == "PP_MESH") THEN + ELSE IF (nametag(2:8) == "PP_MESH") THEN IF (.NOT. (nametag(9:9) == ">")) THEN CALL upf_mesh_option(parser, pot) END IF CALL upf_mesh_section(parser, pot) - ELSEIF (nametag(2:8) == "PP_NLCC") THEN + ELSE IF (nametag(2:8) == "PP_NLCC") THEN IF (nametag(9:9) == ">") THEN CALL upf_nlcc_section(parser, pot, .FALSE.) ELSE CALL upf_nlcc_section(parser, pot, .TRUE.) END IF - ELSEIF (nametag(2:9) == "PP_LOCAL") THEN + ELSE IF (nametag(2:9) == "PP_LOCAL") THEN IF (nametag(10:10) == ">") THEN CALL upf_local_section(parser, pot, .FALSE.) ELSE CALL upf_local_section(parser, pot, .TRUE.) END IF - ELSEIF (nametag(2:12) == "PP_NONLOCAL") THEN + ELSE IF (nametag(2:12) == "PP_NONLOCAL") THEN CPASSERT(nametag(13:13) == ">") CALL upf_nonlocal_section(parser, pot) - ELSEIF (nametag(2:13) == "PP_SEMILOCAL") THEN + ELSE IF (nametag(2:13) == "PP_SEMILOCAL") THEN CALL upf_semilocal_section(parser, pot) - ELSEIF (nametag(2:9) == "PP_PSWFC") THEN + ELSE IF (nametag(2:9) == "PP_PSWFC") THEN ! skip section for now - ELSEIF (nametag(2:11) == "PP_RHOATOM") THEN + ELSE IF (nametag(2:11) == "PP_RHOATOM") THEN ! skip section for now - ELSEIF (nametag(2:7) == "PP_PAW") THEN + ELSE IF (nametag(2:7) == "PP_PAW") THEN ! skip section for now - ELSEIF (nametag(2:6) == "/UPF>") THEN + ELSE IF (nametag(2:6) == "/UPF>") THEN EXIT END IF END IF @@ -856,7 +856,7 @@ CONTAINS END IF IF (icount > ms) EXIT END DO - ELSEIF (string(1:15) == "") THEN + ELSE IF (string(1:15) == "") THEN EXIT ELSE ! diff --git a/src/atom_utils.F b/src/atom_utils.F index 8465ff388a..ae92b95ee4 100644 --- a/src/atom_utils.F +++ b/src/atom_utils.F @@ -2549,7 +2549,7 @@ CONTAINS ja = ibptr(ia, la) jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) + sab(1:nna, 1:nnb) - ELSEIF (basis%basis_type == CGTO_BASIS) THEN + ELSE IF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) @@ -2572,7 +2572,7 @@ CONTAINS jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) & + sab(1:nna, 1:nnb) - ELSEIF (basis%basis_type == CGTO_BASIS) THEN + ELSE IF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) diff --git a/src/atoms_input.F b/src/atoms_input.F index 4e3b87bbf4..1156efb330 100644 --- a/src/atoms_input.F +++ b/src/atoms_input.F @@ -144,8 +144,9 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN CPABORT("incorrectly formatted line in coord section'"//line_att//"'") + END IF IF (wrd == 1) THEN atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c - 1))) ELSE @@ -195,24 +196,26 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN CALL cp_abort(__LOCATION__, & "Incorrectly formatted input line for atom "// & TRIM(ADJUSTL(cp_to_string(iatom)))// & " found in COORD section. Input line: <"// & TRIM(line_att)//"> ") + END IF SELECT CASE (wrd) CASE (1) atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c - 1))) CASE (2:4) CALL read_float_object(line_att(start_c:end_c - 1), & atom_info%r(wrd - 1, iatom), error_message) - IF (LEN_TRIM(error_message) /= 0) & + IF (LEN_TRIM(error_message) /= 0) THEN CALL cp_abort(__LOCATION__, & "Incorrectly formatted input line for atom "// & TRIM(ADJUSTL(cp_to_string(iatom)))// & " found in COORD section. "//TRIM(error_message)// & " Input line: <"//TRIM(line_att)//"> ") + END IF CASE (5) READ (line_att(start_c:end_c - 1), *) strtmp atom_info%id_molname(iatom) = str2id(strtmp) @@ -343,8 +346,9 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN CPABORT("incorrectly formatted line in coord section'"//line_att//"'") + END IF IF (wrd == 1) THEN at_name(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name(ishell)) @@ -393,8 +397,9 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN CPABORT("incorrectly formatted line in coord section'"//line_att//"'") + END IF IF (wrd == 1) THEN at_name_c(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name_c(ishell)) diff --git a/src/base/base_hooks.F b/src/base/base_hooks.F index dd7931e047..d31f199528 100644 --- a/src/base/base_hooks.F +++ b/src/base/base_hooks.F @@ -145,8 +145,9 @@ CONTAINS IF (ASSOCIATED(timestop_hook)) THEN CALL timestop_hook(handle) ELSE - IF (handle /= -1) & + IF (handle /= -1) THEN CALL cp_abort(cp__l("base_hooks.F", __LINE__), "Got wrong handle") + END IF END IF END SUBROUTINE timestop diff --git a/src/base/machine.F b/src/base/machine.F index 9cadaa31a7..a2e21f7fa0 100644 --- a/src/base/machine.F +++ b/src/base/machine.F @@ -741,14 +741,17 @@ CONTAINS ! on a posix system LOGNAME should be defined CALL get_environment_variable("LOGNAME", value=user, status=istat) ! nope, check alternative - IF (istat /= 0) & + IF (istat /= 0) THEN CALL get_environment_variable("USER", value=user, status=istat) + END IF ! nope, check alternative - IF (istat /= 0) & + IF (istat /= 0) THEN CALL get_environment_variable("USERNAME", value=user, status=istat) + END IF ! fall back - IF (istat /= 0) & + IF (istat /= 0) THEN user = "" + END IF END SUBROUTINE m_getlog diff --git a/src/bse_util.F b/src/bse_util.F index d6d53fbba4..3de6d00855 100644 --- a/src/bse_util.F +++ b/src/bse_util.F @@ -1481,7 +1481,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(A6,I3.3,A5,I2.2,a11)') "_NEXC_", istate, "_NTO_", i, "_Hole_State" - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (filename, '(A6,I3.3,A5,I2.2,a15)') "_NEXC_", istate, "_NTO_", i, "_Particle_State" END IF info_approx_trunc = TRIM(ADJUSTL(info_approximation)) @@ -1493,7 +1493,7 @@ CONTAINS log_filename=.FALSE., ignore_should_output=.TRUE., mpi_io=mpi_io) IF (iset == 1) THEN WRITE (title, *) "Natural Transition Orbital Hole State", i - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr_cube, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/bsse.F b/src/bsse.F index 3abfc8c654..6869888a3d 100644 --- a/src/bsse.F +++ b/src/bsse.F @@ -370,10 +370,10 @@ CONTAINS iw = cp_print_key_unit_nr(logger, bsse_section, "PRINT%PROGRAM_RUN_INFO", & extension=".log") IF (iw > 0) THEN - WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf; + WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf IF (istat /= 0) conf_s = "exceeded" CALL compress(conf_s, full=.TRUE.) - WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc; + WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc IF (istat /= 0) conf_loc_s = "exceeded" CALL compress(conf_loc_s, full=.TRUE.) @@ -429,15 +429,17 @@ CONTAINS IF (explicit) THEN DO i = 1, nconf CALL section_vals_val_get(configurations, "GLB_CONF", i_rep_section=i, i_vals=glb_conf) - IF (SIZE(glb_conf) /= SIZE(conf)) & + IF (SIZE(glb_conf) /= SIZE(conf)) THEN CALL cp_abort(__LOCATION__, & "GLB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") + END IF CALL section_vals_val_get(configurations, "SUB_CONF", i_rep_section=i, i_vals=sub_conf) - IF (SIZE(sub_conf) /= SIZE(conf)) & + IF (SIZE(sub_conf) /= SIZE(conf)) THEN CALL cp_abort(__LOCATION__, & "SUB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") + END IF IF (ALL(conf == glb_conf) .AND. ALL(conf_loc == sub_conf)) THEN CALL section_vals_val_get(configurations, "CHARGE", i_rep_section=i, & i_val=present_charge) diff --git a/src/cell_methods.F b/src/cell_methods.F index fc063a2c1e..1cb33a48c5 100644 --- a/src/cell_methods.F +++ b/src/cell_methods.F @@ -461,11 +461,12 @@ CONTAINS CALL section_vals_val_get(cell_section, "CELL_FILE_NAME", explicit=cell_read_file) IF (cell_read_file) THEN ! Case 1 tmp_comb_cell = (cell_read_abc .OR. (cell_read_a .OR. (cell_read_b .OR. cell_read_c))) - IF (tmp_comb_cell) & + IF (tmp_comb_cell) THEN CALL cp_warn(__LOCATION__, & "Cell Information provided through A, B, C, or ABC in conjunction "// & "with CELL_FILE_NAME. The definition in external file will override "// & "other ones.") + END IF CALL section_vals_val_get(cell_section, "CELL_FILE_NAME", c_val=cell_file_name) CALL section_vals_val_get(cell_section, "CELL_FILE_FORMAT", i_val=cell_file_format) SELECT CASE (cell_file_format) @@ -491,10 +492,11 @@ CONTAINS read_len = cell_par CALL section_vals_val_get(cell_section, "ALPHA_BETA_GAMMA", r_vals=cell_par) read_ang = cell_par - IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) & + IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) THEN CALL cp_warn(__LOCATION__, & "Cell information provided through vectors A, B or C in conjunction with ABC. "// & "The definition of the ABC keyword will override the one provided by A, B and C.") + END IF ELSE ! Case 3 tmp_comb_abc = ((cell_read_a .EQV. cell_read_b) .AND. (cell_read_b .EQV. cell_read_c)) IF (tmp_comb_abc) THEN @@ -504,10 +506,11 @@ CONTAINS read_mat(:, 2) = cell_par(:) CALL section_vals_val_get(cell_section, "C", r_vals=cell_par) read_mat(:, 3) = cell_par(:) - IF (cell_read_alpha_beta_gamma) & + IF (cell_read_alpha_beta_gamma) THEN CALL cp_warn(__LOCATION__, & "The keyword ALPHA_BETA_GAMMA is ignored because it was used without the "// & "keyword ABC.") + END IF ELSE CALL cp_abort(__LOCATION__, & "Neither of the keywords CELL_FILE_NAME or ABC are specified, "// & @@ -722,10 +725,11 @@ CONTAINS CPASSERT(ASSOCIATED(cell)) ! Abort, if one of the value is set to zero - IF (ANY(multiple_unit_cell <= 0)) & + IF (ANY(multiple_unit_cell <= 0)) THEN CALL cp_abort(__LOCATION__, & "CELL%MULTIPLE_UNIT_CELL accepts only integer values larger than 0! "// & "A value of 0 or negative is meaningless!") + END IF ! Scale abc according to user request cell%hmat(:, 1) = cell%hmat(:, 1)*multiple_unit_cell(1) @@ -778,8 +782,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_a", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_length_a or _cell.length_a was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_lengths(1)) cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1), "angstrom") @@ -790,8 +795,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_b", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_length_b or _cell.length_b was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_lengths(2)) cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2), "angstrom") @@ -802,8 +808,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_c", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_length_c or _cell.length_c was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_lengths(3)) cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3), "angstrom") @@ -814,8 +821,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_alpha", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_angle_alpha or _cell.angle_alpha was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_angles(1)) cell_angles(1) = cp_unit_to_cp2k(cell_angles(1), "deg") @@ -826,8 +834,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_beta", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_angle_beta or _cell.angle_beta was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_angles(2)) cell_angles(2) = cp_unit_to_cp2k(cell_angles(2), "deg") @@ -838,8 +847,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_gamma", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_angle_gamma or _cell.angle_gamma was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_angles(3)) cell_angles(3) = cp_unit_to_cp2k(cell_angles(3), "deg") @@ -1192,8 +1202,9 @@ CONTAINS CALL parser_search_string(parser, "CRYST1", ignore_case=.FALSE., found=found, & begin_line=.TRUE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The line was not found in PDB file! ") + END IF periodic = 1 READ (parser%input_line, *, IOSTAT=ios) cryst, cell_lengths(:), cell_angles(:) diff --git a/src/colvar_methods.F b/src/colvar_methods.F index 0489fefb36..b92eebad05 100644 --- a/src/colvar_methods.F +++ b/src/colvar_methods.F @@ -618,11 +618,12 @@ CONTAINS ALLOCATE (colvar%combine_cvs_param%variables(SIZE(my_par))) colvar%combine_cvs_param%variables = my_par ! Check that the number of COLVAR provided is equal to the number of variables.. - IF (SIZE(my_par) /= ncol) & + IF (SIZE(my_par) /= ncol) THEN CALL cp_abort(__LOCATION__, & "Number of defined COLVAR for COMBINE_COLVAR is different from the "// & "number of variables! It is not possible to define COLVARs in a COMBINE_COLVAR "// & "and avoid their usage in the combininig function!") + END IF ! Parameters ALLOCATE (colvar%combine_cvs_param%c_parameters(0)) CALL section_vals_val_get(combine_section, "PARAMETERS", n_rep_val=ncol) @@ -726,8 +727,9 @@ CONTAINS ! Read the specification of the two planes plane_sections => section_vals_get_subs_vals(plane_plane_angle_section, "PLANE") CALL section_vals_get(plane_sections, n_repetition=n_var) - IF (n_var /= 2) & + IF (n_var /= 2) THEN CPABORT("PLANE_PLANE_ANGLE Colvar section: Two PLANE sections must be provided!") + END IF ! Plane 1 CALL section_vals_val_get(plane_sections, "DEF_TYPE", i_rep_section=1, & i_val=colvar%plane_plane_angle_param%plane1%type_of_def) @@ -736,8 +738,9 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane1%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) & + IF (ASSOCIATED(cell)) THEN CALL cell_transform_input_cartesian(cell, colvar%plane_plane_angle_param%plane1%normal_vec) + END IF END IF ELSE CALL section_vals_val_get(plane_sections, "ATOMS", i_rep_section=1, & @@ -753,8 +756,9 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane2%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) & + IF (ASSOCIATED(cell)) THEN CALL cell_transform_input_cartesian(cell, colvar%plane_plane_angle_param%plane2%normal_vec) + END IF END IF ELSE CALL section_vals_val_get(plane_sections, "ATOMS", i_rep_section=2, & @@ -863,9 +867,10 @@ CONTAINS weights(ndim + 1:ndim + SIZE(wei)) = wei ndim = ndim + SIZE(wei) END DO - IF (ndim /= colvar%rmsd_param%n_atoms) & + IF (ndim /= colvar%rmsd_param%n_atoms) THEN CALL cp_abort(__LOCATION__, "CV RMSD: list of atoms and list of "// & "weights need to contain same number of entries. ") + END IF DO i = 1, ndim ii = colvar%rmsd_param%i_rmsd(i) colvar%rmsd_param%weights(ii) = weights(i) @@ -947,11 +952,13 @@ CONTAINS i_val=colvar%ring_puckering_param%iq) ! test the validity of the parameters ndim = colvar%ring_puckering_param%nring - IF (ndim <= 3) & + IF (ndim <= 3) THEN CPABORT("CV Ring Puckering: Ring size has to be 4 or larger. ") + END IF ii = colvar%ring_puckering_param%iq - IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) & + IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) THEN CPABORT("CV Ring Puckering: Invalid coordinate number.") + END IF ELSE IF (my_subsection(23)) THEN ! Minimum Distance wrk_section => mindist_section @@ -1326,7 +1333,7 @@ CONTAINS IF (colvar%ring_puckering_param%iq == 0) THEN WRITE (iw, '( A,T40,A)') ' COLVARS| Ring Puckering >>> coordinate', & ' Total Puckering Amplitude' - ELSEIF (colvar%ring_puckering_param%iq > 0) THEN + ELSE IF (colvar%ring_puckering_param%iq > 0) THEN WRITE (iw, '( A,T35,A,T57,I8)') ' COLVARS| Ring Puckering >>> coordinate', & ' Puckering Amplitude', & colvar%ring_puckering_param%iq @@ -2189,11 +2196,12 @@ CONTAINS CALL put_derivative(colvar, iatom, fi) END DO ELSE - IF (force_env%in_use /= use_mixed_force) & + IF (force_env%in_use /= use_mixed_force) THEN CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' A combination of mixed force_eval energies has been requested as '// & ' collective variable, but the MIXED env is not in use! Aborting.') + END IF CALL force_env_get(force_env, force_env_section=force_env_section) mapping_section => section_vals_get_subs_vals(force_env_section, "MIXED%MAPPING") NULLIFY (values, parameters, subsystems, particles, global_forces, map_index, glob_natoms) @@ -2683,8 +2691,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! evaluation of the angle.. - a = SQRT(DOT_PRODUCT(xij, xij)) - b = SQRT(DOT_PRODUCT(xkj, xkj)) + a = NORM2(xij) + b = NORM2(xkj) t0 = 1.0_dp/(a*b) t1 = 1.0_dp/(a**3.0_dp*b) t2 = 1.0_dp/(a*b**3.0_dp) @@ -2834,8 +2842,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! Evaluation of the angle.. - a = SQRT(DOT_PRODUCT(xij, xij)) - b = SQRT(DOT_PRODUCT(xkj, xkj)) + a = NORM2(xij) + b = NORM2(xkj) t0 = 1.0_dp/(a*b) t1 = 1.0_dp/(a**3.0_dp*b) t2 = 1.0_dp/(a*b**3.0_dp) @@ -3137,10 +3145,6 @@ CONTAINS TYPE(particle_list_type), POINTER :: particles_i TYPE(particle_type), DIMENSION(:), POINTER :: my_particles - ! settings for numerical derivatives - !REAL(KIND=dp) :: ri_step, dx_bond_j, dy_bond_j, dz_bond_j - !INTEGER :: idel - n_atoms_to = colvar%qparm_param%n_atoms_to n_atoms_from = colvar%qparm_param%n_atoms_from rcut = colvar%qparm_param%rcut @@ -3159,10 +3163,6 @@ CONTAINS CPASSERT(r1cut < rcut) denominator_tolerance = 1.0E-8_dp - !ri_step=0.1 - !DO idel=-50, 50 - !ftmp(:) = 0.0_dp - qparm = 0.0_dp inv_n_atoms_from = 1.0_dp/REAL(n_atoms_from, KIND=dp) DO ii = 1, n_atoms_from @@ -3200,11 +3200,10 @@ CONTAINS shift(:) = 0.0_dp shift(idim) = 1.0_dp xij_shift = MATMUL(cell%hmat, shift) - rij_shift = SQRT(DOT_PRODUCT(xij_shift, xij_shift)) + rij_shift = NORM2(xij_shift) ncells(idim) = FLOOR(rcut/rij_shift - 0.5) END DO !idim - !IF (mm.eq.0) WRITE(*,'(A8,3I3,A3,I10)') "Ncells:", ncells, "J:", j shift(1:3) = 0.0_dp DO aa = -ncells(1), ncells(1) DO bb = -ncells(2), ncells(2) @@ -3215,12 +3214,7 @@ CONTAINS shift(2) = REAL(bb, KIND=dp) shift(3) = REAL(cc, KIND=dp) xij = MATMUL(cell%hmat, ss0(:) + shift(:)) - rij = SQRT(DOT_PRODUCT(xij, xij)) - !IF (rij > rcut) THEN - ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " --", shift, rij - !ELSE - ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " ++", shift, rij - !ENDIF + rij = NORM2(xij) IF (rij > rcut) CYCLE ! update qlm @@ -3236,7 +3230,7 @@ CONTAINS IF (i == j) CYCLE jloop xij(:) = xpj(:) - xpi(:) - rij = SQRT(DOT_PRODUCT(xij, xij)) + rij = NORM2(xij) IF (rij > rcut) CYCLE jloop ! update qlm @@ -3251,11 +3245,6 @@ CONTAINS ! this factor is necessary if one whishes to sum over m=0,L ! instead of m=-L,+L. This is off now because it is cheap and safe fact = 1.0_dp - !IF (ABS(mm) > 0) THEN - ! fact = 2.0_dp - !ELSE - ! fact = 1.0_dp - !ENDIF IF (nbond < denominator_tolerance) THEN CPWARN("QPARM: number of neighbors is very close to zero!") @@ -3274,7 +3263,6 @@ CONTAINS END DO ! loop over m pre_fac = (4.0_dp*pi)/(2.0_dp*l + 1) - !WRITE(*,'(A8,2F10.5)') " si = ", SQRT(pre_fac*ql) qparm = qparm + SQRT(pre_fac*ql) ftmp(:) = 0.5_dp*SQRT(pre_fac/ql)*d_ql_dxi(:) ! multiply by -1 because aparently we have to save the force, not the gradient @@ -3287,10 +3275,6 @@ CONTAINS colvar%ss = qparm*inv_n_atoms_from colvar%dsdr(:, :) = colvar%dsdr(:, :)*inv_n_atoms_from - !WRITE(*,'(A15,3E20.10)') "COLVAR+DER = ", ri_step*idel, colvar%ss, -ftmp(1) - - !ENDDO ! numercal derivative - END SUBROUTINE qparm_colvar ! ************************************************************************************************** @@ -3323,7 +3307,6 @@ CONTAINS exp_fac, fi, plm, pre_fac, sqrt_c1 REAL(KIND=dp), DIMENSION(3) :: dcosTheta, dfi - !bond = 1.0_dp/(1.0_dp+EXP(alpha*(rij-rcut))) ! RZK: infinitely differentiable smooth cutoff function ! that is precisely 1.0 below r1cut and precisely 0.0 above rcut IF (rij > rcut) THEN @@ -3366,18 +3349,10 @@ CONTAINS sqrt_c1 = SQRT(((2*ll + 1)*fac(ll - ABS(mm)))/(4*pi*fac(ll + ABS(mm)))) pre_fac = bond*sqrt_c1 dylm = pre_fac*dplm - !WHY? IF (plm < 0.0_dp) THEN - !WHY? dylm = -pre_fac*dplm - !WHY? ELSE - !WHY? dylm = pre_fac*dplm - !WHY? ENDIF re_qlm = re_qlm + pre_fac*plm*COS(mm*fi) im_qlm = im_qlm + pre_fac*plm*SIN(mm*fi) - !WRITE(*,'(A8,2I4,F10.5)') " Qlm = ", mm, j, bond - !WRITE(*,'(A8,2I4,2F10.5)') " Qlm = ", mm, j, re_qlm, im_qlm - dcosTheta(:) = xij(:)*xij(3)/(rij**3) dcosTheta(3) = dcosTheta(3) - 1.0_dp/rij ! use tangent half-angle formula to compute d_fi/d_xi @@ -4595,7 +4570,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL rpath_dist_rmsd(colvar, my_particles) - ELSEIF (colvar%reaction_path_param%rmsd) THEN + ELSE IF (colvar%reaction_path_param%rmsd) THEN CALL rpath_rmsd(colvar, my_particles) ELSE CALL rpath_colvar(colvar, cell, my_particles) @@ -4948,7 +4923,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL dpath_dist_rmsd(colvar, my_particles) - ELSEIF (colvar%reaction_path_param%rmsd) THEN + ELSE IF (colvar%reaction_path_param%rmsd) THEN CALL dpath_rmsd(colvar, my_particles) ELSE CALL dpath_colvar(colvar, cell, my_particles) @@ -5864,11 +5839,12 @@ CONTAINS DO j = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for COORD_A (CV rmsd). Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") + END IF READ (parser%input_line, *) dummy_char, rptr(1:3) r_ref((j - 1)*3 + 1, i) = cp_unit_to_cp2k(rptr(1), "angstrom") r_ref((j - 1)*3 + 2, i) = cp_unit_to_cp2k(rptr(2), "angstrom") @@ -5966,12 +5942,7 @@ CONTAINS iamin = wcai(i) END IF END DO -! zero=0.0_dp -! CALL put_derivative(colvar, 1, zero) -! CALL put_derivative(colvar, 2,zero) -! CALL put_derivative(colvar, 3, zero) -! write(*,'(2(i0,1x),4(f16.8,1x))')idmin,iamin,wc(1)%WannierHamDiag(idmin),wc(1)%WannierHamDiag(iamin),dmin,amin colvar%ss = wc(1)%WannierHamDiag(idmin) - wc(1)%WannierHamDiag(iamin) DEALLOCATE (wcai) DEALLOCATE (wcdi) @@ -5988,7 +5959,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = SQRT(DOT_PRODUCT(xv, xv)) + distance = NORM2(xv) END FUNCTION distance END SUBROUTINE Wc_colvar @@ -6007,8 +5978,8 @@ CONTAINS TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & - OPTIONAL, POINTER :: particles - TYPE(qs_environment_type), POINTER, OPTIONAL :: qs_env ! optional just because I am lazy... but I should get rid of it... + OPTIONAL, POINTER :: particles + TYPE(qs_environment_type), OPTIONAL, POINTER :: qs_env INTEGER :: Od, H, Oa REAL(dp) :: rOd(3), rOa(3), rH(3), & @@ -6105,7 +6076,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = SQRT(DOT_PRODUCT(xv, xv)) + distance = NORM2(xv) END FUNCTION distance END SUBROUTINE HBP_colvar diff --git a/src/common/array_sort.fypp b/src/common/array_sort.fypp index 2b39e3b783..86ebeb1f97 100644 --- a/src/common/array_sort.fypp +++ b/src/common/array_sort.fypp @@ -97,9 +97,9 @@ ! Merge will be performed directly in arr. Need backup of first sublist. tmp_arr(1:m) = arr(1:m) tmp_idx(1:m) = indices(1:m) - i = 1; ! number of elemens consumed from 1st sublist - j = 1; ! number of elemens consumed from 2nd sublist - k = 1; ! number of elemens already merged + i = 1 ! number of elements consumed from 1st sublist + j = 1 ! number of elements consumed from 2nd sublist + k = 1 ! number of elements already merged DO WHILE (i <= m .and. j <= size(arr) - m) IF (${prefix}$_less_than(arr(m + j), tmp_arr(i))) THEN diff --git a/src/common/cp_array_utils.F b/src/common/cp_array_utils.F index 87fd4d9949..a2bbe6c591 100644 --- a/src/common/cp_array_utils.F +++ b/src/common/cp_array_utils.F @@ -152,8 +152,9 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) & + IF (SIZE(array) > 0) THEN WRITE (unit=unit_nr, fmt=el_format, advance="no") array(SIZE(array)) + END IF ELSE DO i = 1, SIZE(array) - 1 WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(i) @@ -163,8 +164,9 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) & + IF (SIZE(array) > 0) THEN WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(SIZE(array)) + END IF END IF WRITE (unit=unit_nr, fmt="(' )')") call m_flush(unit_nr) @@ -289,8 +291,7 @@ CONTAINS !> \note !> the array should be ordered in growing order ! ************************************************************************************************** - FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) & - result(res) + FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) result(res) ${type1}$, intent(in) :: array(:) ${type1}$, intent(in) :: el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index diff --git a/src/common/cp_error_handling.F b/src/common/cp_error_handling.F index 2d0192f8e0..e54780c0d3 100644 --- a/src/common/cp_error_handling.F +++ b/src/common/cp_error_handling.F @@ -63,8 +63,9 @@ CONTAINS CALL delay_non_master() ! cleaner output if all ranks abort simultaneously unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) & - unit_nr = default_output_unit ! fall back to stdout + IF (unit_nr <= 0) THEN + unit_nr = default_output_unit + END IF ! fall back to stdout CALL print_abort_message(message, location, unit_nr) CALL print_stack(unit_nr) @@ -125,8 +126,9 @@ CONTAINS ! we (ab)use the logger to determine the first MPI rank unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) & - wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second. + IF (unit_nr <= 0) THEN + wait_time = wait_time + 1.0_dp + END IF ! rank-0 gets a head start of one second. !$ IF (omp_get_thread_num() /= 0) & !$ wait_time = wait_time + 1.0_dp ! master threads gets another second diff --git a/src/common/cp_log_handling.F b/src/common/cp_log_handling.F index be0caf7b9e..b8ea2ea26e 100644 --- a/src/common/cp_log_handling.F +++ b/src/common/cp_log_handling.F @@ -303,8 +303,9 @@ CONTAINS logger%ref_count = 1 IF (PRESENT(template_logger)) THEN - IF (template_logger%ref_count < 1) & + IF (template_logger%ref_count < 1) THEN CPABORT(routineP//" template_logger%ref_count<1") + END IF logger%print_level = template_logger%print_level logger%default_global_unit_nr = template_logger%default_global_unit_nr logger%close_local_unit_on_dealloc = template_logger%close_local_unit_on_dealloc @@ -339,16 +340,19 @@ CONTAINS logger%suffix = "" END IF IF (PRESENT(para_env)) logger%para_env => para_env - IF (.NOT. ASSOCIATED(logger%para_env)) & + IF (.NOT. ASSOCIATED(logger%para_env)) THEN CPABORT(routineP//" para env not associated") - IF (.NOT. logger%para_env%is_valid()) & + END IF + IF (.NOT. logger%para_env%is_valid()) THEN CPABORT(routineP//" para_env%ref_count<1") + END IF CALL logger%para_env%retain() IF (PRESENT(print_level)) logger%print_level = print_level - IF (PRESENT(default_global_unit_nr)) & + IF (PRESENT(default_global_unit_nr)) THEN logger%default_global_unit_nr = default_global_unit_nr + END IF IF (PRESENT(global_filename)) THEN logger%global_filename = global_filename logger%close_global_unit_on_dealloc = .TRUE. @@ -362,8 +366,9 @@ CONTAINS END IF END IF - IF (PRESENT(default_local_unit_nr)) & + IF (PRESENT(default_local_unit_nr)) THEN logger%default_local_unit_nr = default_local_unit_nr + END IF IF (PRESENT(local_filename)) THEN logger%local_filename = local_filename logger%close_local_unit_on_dealloc = .TRUE. @@ -407,8 +412,9 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_retain', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) & + IF (logger%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF logger%ref_count = logger%ref_count + 1 END SUBROUTINE cp_logger_retain @@ -426,8 +432,9 @@ CONTAINS routineP = moduleN//':'//routineN IF (ASSOCIATED(logger)) THEN - IF (logger%ref_count < 1) & + IF (logger%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF logger%ref_count = logger%ref_count - 1 IF (logger%ref_count == 0) THEN IF (logger%close_global_unit_on_dealloc .AND. & @@ -476,8 +483,9 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) & + IF (lggr%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF res = level >= lggr%print_level END FUNCTION cp_logger_would_log @@ -547,8 +555,9 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_set_log_level', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) & + IF (logger%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF logger%print_level = level END SUBROUTINE cp_logger_set_log_level @@ -584,8 +593,9 @@ CONTAINS NULLIFY (lggr) END IF IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) & + IF (lggr%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF IF (PRESENT(local)) loc = local IF (PRESENT(skip_not_ionode)) skip = skip_not_ionode @@ -692,8 +702,9 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) & + IF (lggr%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF IF (PRESENT(local)) loc = local IF (loc) THEN res = TRIM(root)//TRIM(lggr%suffix)//'_p'// & diff --git a/src/common/cp_result_methods.F b/src/common/cp_result_methods.F index c62fe15576..8b943915df 100644 --- a/src/common/cp_result_methods.F +++ b/src/common/cp_result_methods.F @@ -178,14 +178,16 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) & + IF (nrep <= 0) THEN CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") + END IF DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) THEN - IF (results%result_value(i)%value%type_in_use /= result_type_real) & + IF (results%result_value(i)%value%type_in_use /= result_type_real) THEN CPABORT("Attempt to retrieve a RESULT which is not a REAL!") + END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT @@ -251,14 +253,16 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) & + IF (nrep <= 0) THEN CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") + END IF DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) THEN - IF (results%result_value(i)%value%type_in_use /= result_type_real) & + IF (results%result_value(i)%value%type_in_use /= result_type_real) THEN CPABORT("Attempt to retrieve a RESULT which is not a REAL!") + END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT diff --git a/src/common/cp_units.F b/src/common/cp_units.F index 9677341fd4..d398b9f92f 100644 --- a/src/common/cp_units.F +++ b/src/common/cp_units.F @@ -650,10 +650,11 @@ CONTAINS CPABORT("unknown electric field unit:"//TRIM(cp_to_string(basic_unit))) END SELECT CASE (cp_ukind_none) - IF (basic_unit /= cp_units_none) & + IF (basic_unit /= cp_units_none) THEN CALL cp_abort(__LOCATION__, & "if the kind of the unit is none also unit must be undefined,not:" & //TRIM(cp_to_string(basic_unit))) + END IF CASE default CPABORT("unknown kind of unit:"//TRIM(cp_to_string(basic_kind))) END SELECT @@ -679,10 +680,11 @@ CONTAINS my_power = 1 IF (PRESENT(power)) my_power = power IF (basic_unit == cp_units_none .AND. basic_kind /= cp_ukind_undef) THEN - IF (basic_kind /= cp_units_none) & + IF (basic_kind /= cp_units_none) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(cp_to_string(basic_unit))) + END IF END IF SELECT CASE (basic_kind) CASE (cp_ukind_undef) @@ -862,9 +864,10 @@ CONTAINS IF (accept_undefined) my_accept_undefined = accept_undefined IF (PRESENT(power)) my_power = power IF (basic_unit == cp_units_none) THEN - IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) & + IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) THEN CALL cp_abort(__LOCATION__, "unit not yet fully specified, unit of kind "// & TRIM(cp_to_string(basic_kind))) + END IF END IF SELECT CASE (basic_kind) CASE (cp_ukind_undef) @@ -900,10 +903,11 @@ CONTAINS res = "K_e" CASE (cp_units_none) res = "energy" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown energy unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -931,10 +935,11 @@ CONTAINS res = "au_temp" CASE (cp_units_none) res = "temperature" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown temperature unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -956,10 +961,11 @@ CONTAINS res = "au_p" CASE (cp_units_none) res = "pressure" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown pressure unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -971,10 +977,11 @@ CONTAINS res = "deg" CASE (cp_units_none) res = "angle" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown angle unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -992,10 +999,11 @@ CONTAINS res = "wavenumber_t" CASE (cp_units_none) res = "time" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown time unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1009,10 +1017,11 @@ CONTAINS res = "m_e" CASE (cp_units_none) res = "mass" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown mass unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1024,10 +1033,11 @@ CONTAINS res = "au_pot" CASE (cp_units_none) res = "potential" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown potential unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1041,10 +1051,11 @@ CONTAINS res = "au_f" CASE (cp_units_none) res = "force" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown potential unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1060,10 +1071,11 @@ CONTAINS res = "au_efield" CASE (cp_units_none) res = "electric field" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown efield unit:"//TRIM(cp_to_string(basic_unit))) END SELECT diff --git a/src/common/distribution_1d_types.F b/src/common/distribution_1d_types.F index 8e23f4b29f..c875a3129f 100644 --- a/src/common/distribution_1d_types.F +++ b/src/common/distribution_1d_types.F @@ -104,8 +104,9 @@ CONTAINS CALL para_env%retain() distribution_1d%listbased_distribution = .FALSE. - IF (PRESENT(listbased_distribution)) & + IF (PRESENT(listbased_distribution)) THEN distribution_1d%listbased_distribution = listbased_distribution + END IF ALLOCATE (distribution_1d%n_el(my_n_lists), distribution_1d%list(my_n_lists)) diff --git a/src/common/fparser.F b/src/common/fparser.F index 2e373db097..04f4f47f12 100644 --- a/src/common/fparser.F +++ b/src/common/fparser.F @@ -407,10 +407,10 @@ CONTAINS DO j = b, e IF (Func(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSEIF (Func(j:j) == ')') THEN + ELSE IF (Func(j:j) == ')') THEN ParCnt = ParCnt - 1 IF (ParCnt == 0) EXIT - ELSEIF (ParCnt == 1 .AND. Func(j:j) == ',') THEN + ELSE IF (ParCnt == 1 .AND. Func(j:j) == ',') THEN ArgPos = j ArgCnt = ArgCnt + 1 END IF @@ -748,7 +748,7 @@ CONTAINS DO j = b + 1, e - 1 IF (F(j:j) == '(') THEN k = k + 1 - ELSEIF (F(j:j) == ')') THEN + ELSE IF (F(j:j) == ')') THEN k = k - 1 END IF IF (k < 0) EXIT @@ -792,11 +792,11 @@ CONTAINS ! WRITE(*,*)'1. F(b:e) = "+..."' CALL CompileSubstr(i, F, b + 1, e, Var) RETURN - ELSEIF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' + ELSE IF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' ! WRITE(*,*)'2. F(b:e) = "(...)"' CALL CompileSubstr(i, F, b + 1, e - 1, Var) RETURN - ELSEIF (SCAN(F(b:b), calpha) > 0) THEN + ELSE IF (SCAN(F(b:b), calpha) > 0) THEN n = MathFunctionIndex(F(b:e)) IF (n > 0) THEN b2 = b + INDEX(F(b:e), '(') - 1 @@ -807,13 +807,13 @@ CONTAINS RETURN END IF END IF - ELSEIF (F(b:b) == '-') THEN + ELSE IF (F(b:b) == '-') THEN IF (CompletelyEnclosed(F, b + 1, e)) THEN ! Case 4: F(b:e) = '-(...)' ! WRITE(*,*)'4. F(b:e) = "-(...)"' CALL CompileSubstr(i, F, b + 2, e - 1, Var) CALL AddCompiledByte(i, cNeg) RETURN - ELSEIF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN + ELSE IF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN n = MathFunctionIndex(F(b + 1:e)) IF (n > 0) THEN b2 = b + INDEX(F(b + 1:e), '(') @@ -835,7 +835,7 @@ CONTAINS DO j = e, b, -1 IF (F(j:j) == ')') THEN k = k + 1 - ELSEIF (F(j:j) == '(') THEN + ELSE IF (F(j:j) == '(') THEN k = k - 1 END IF IF (k == 0 .AND. F(j:j) == Ops(io) .AND. IsBinaryOp(j, F)) THEN @@ -900,9 +900,9 @@ CONTAINS DO j = b, e IF (F(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSEIF (F(j:j) == ')') THEN + ELSE IF (F(j:j) == ')') THEN ParCnt = ParCnt - 1 - ELSEIF (ParCnt == 0 .AND. F(j:j) == ',') THEN + ELSE IF (ParCnt == 0 .AND. F(j:j) == ',') THEN CALL CompileSubstr(i, F, b2, j - 1, Var) b2 = j + 1 END IF @@ -938,17 +938,17 @@ CONTAINS IF (F(j:j) == '+' .OR. F(j:j) == '-') THEN ! Plus or minus sign: IF (j == 1) THEN ! - leading unary operator ? res = .FALSE. - ELSEIF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? + ELSE IF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? res = .FALSE. - ELSEIF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? - SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN + ELSE IF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? + SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN Dflag = .FALSE.; Pflag = .FALSE. k = j - 1 DO WHILE (k > 1) ! step to the left in mantissa k = k - 1 IF (SCAN(F(k:k), '0123456789') > 0) THEN Dflag = .TRUE. - ELSEIF (F(k:k) == '.') THEN + ELSE IF (F(k:k) == '.') THEN IF (Pflag) THEN EXIT ! * EXIT: 2nd appearance of '.' ELSE @@ -1011,7 +1011,7 @@ CONTAINS CASE ('+', '-') ! Permitted only IF (Bflag) THEN InMan = .TRUE.; Bflag = .FALSE. ! - at beginning of mantissa - ELSEIF (Eflag) THEN + ELSE IF (Eflag) THEN InExp = .TRUE.; Eflag = .FALSE. ! - at beginning of exponent ELSE EXIT ! - otherwise STOP @@ -1019,7 +1019,7 @@ CONTAINS CASE ('0':'9') ! Mark IF (Bflag) THEN InMan = .TRUE.; Bflag = .FALSE. ! - beginning of mantissa - ELSEIF (Eflag) THEN + ELSE IF (Eflag) THEN InExp = .TRUE.; Eflag = .FALSE. ! - beginning of exponent END IF IF (InMan) DInMan = .TRUE. ! Mantissa contains digit @@ -1028,7 +1028,7 @@ CONTAINS IF (Bflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' InMan = .TRUE.; Bflag = .FALSE. ! mark beginning of mantissa - ELSEIF (InMan .AND. .NOT. Pflag) THEN + ELSE IF (InMan .AND. .NOT. Pflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' ELSE EXIT ! - otherwise STOP diff --git a/src/common/gfun.F b/src/common/gfun.F index 55c55bf64b..515c79098e 100644 --- a/src/common/gfun.F +++ b/src/common/gfun.F @@ -62,7 +62,7 @@ CONTAINS IF (t <= 12.0_dp) THEN ! downward recursion - g(nmax) = gfun_taylor(nmax, t); + g(nmax) = gfun_taylor(nmax, t) DO i = nmax, 1, -1 g(i - 1) = (1.0_dp - 2.0_dp*t*g(i))/(2.0_dp*i - 1.0_dp) END DO diff --git a/src/common/hash_map.fypp b/src/common/hash_map.fypp index ee755920b3..ff5e066b74 100644 --- a/src/common/hash_map.fypp +++ b/src/common/hash_map.fypp @@ -81,11 +81,13 @@ initial_capacity_ = 11 END IF - IF (initial_capacity_ < 1) & + IF (initial_capacity_ < 1) THEN CPABORT("initial_capacity < 1") + END IF - IF (ASSOCIATED(hash_map%buckets)) & + IF (ASSOCIATED(hash_map%buckets)) THEN CPABORT("hash map is already initialized.") + END IF ALLOCATE (hash_map%buckets(initial_capacity_)) hash_map%size = 0 diff --git a/src/common/list.fypp b/src/common/list.fypp index 37524a2570..f0adb39843 100644 --- a/src/common/list.fypp +++ b/src/common/list.fypp @@ -87,15 +87,18 @@ initial_capacity_ = 11 If (PRESENT(initial_capacity)) initial_capacity_ = initial_capacity - IF (initial_capacity_ < 0) & + IF (initial_capacity_ < 0) THEN CPABORT("list_${valuetype}$_create: initial_capacity < 0") + END IF - IF (ASSOCIATED(list%arr)) & + IF (ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_create: list is already initialized.") + END IF ALLOCATE (list%arr(initial_capacity_), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_init: allocation failed") + END IF list%size = 0 END SUBROUTINE list_${valuetype}$_init @@ -112,8 +115,9 @@ SUBROUTINE list_${valuetype}$_destroy(list) TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_destroy: list is not initialized.") + END IF do i = 1, list%size deallocate (list%arr(i)%p) @@ -137,12 +141,15 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_in}$, intent(in) :: value INTEGER, intent(in) :: pos - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_set: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_set: pos < 1") - IF (pos > list%size) & + END IF + IF (pos > list%size) THEN CPABORT("list_${valuetype}$_set: pos > size") + END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_set @@ -159,15 +166,18 @@ ${valuetype_in}$, intent(in) :: value INTEGER :: stat - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_push: list is not initialized.") - if (list%size == size(list%arr)) & - call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) + END IF + IF (list%size == size(list%arr)) THEN + CALL change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) + END IF list%size = list%size + 1 ALLOCATE (list%arr(list%size)%p, stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_push: allocation failed") + END IF list%arr(list%size)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_push @@ -187,15 +197,19 @@ INTEGER, intent(in) :: pos INTEGER :: i, stat - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_insert: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_insert: pos < 1") - IF (pos > list%size + 1) & + END IF + IF (pos > list%size + 1) THEN CPABORT("list_${valuetype}$_insert: pos > size+1") + END IF - if (list%size == size(list%arr)) & + if (list%size == size(list%arr)) THEN call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) + END IF list%size = list%size + 1 do i = list%size, pos + 1, -1 @@ -203,8 +217,9 @@ end do ALLOCATE (list%arr(pos)%p, stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_insert: allocation failed.") + END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_insert @@ -221,10 +236,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_peek: list is not initialized.") - IF (list%size < 1) & + END IF + IF (list%size < 1) THEN CPABORT("list_${valuetype}$_peek: list is empty.") + END IF value ${value_assign}$list%arr(list%size)%p%value END FUNCTION list_${valuetype}$_peek @@ -245,10 +262,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_pop: list is not initialized.") - IF (list%size < 1) & + END IF + IF (list%size < 1) THEN CPABORT("list_${valuetype}$_pop: list is empty.") + END IF value ${value_assign}$list%arr(list%size)%p%value deallocate (list%arr(list%size)%p) @@ -266,12 +285,13 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_clear: list is not initialized.") + END IF - do i = 1, list%size + DO i = 1, list%size deallocate (list%arr(i)%p) - end do + END DO list%size = 0 END SUBROUTINE list_${valuetype}$_clear @@ -290,12 +310,15 @@ INTEGER, intent(in) :: pos ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_get: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_get: pos < 1") - IF (pos > list%size) & + END IF + IF (pos > list%size) THEN CPABORT("list_${valuetype}$_get: pos > size") + END IF value ${value_assign}$list%arr(pos)%p%value @@ -314,17 +337,20 @@ INTEGER, intent(in) :: pos INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_del: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_det: pos < 1") - IF (pos > list%size) & + END IF + IF (pos > list%size) THEN CPABORT("list_${valuetype}$_det: pos > size") + END IF deallocate (list%arr(pos)%p) - do i = pos, list%size - 1 + DO i = pos, list%size - 1 list%arr(i)%p => list%arr(i + 1)%p - end do + END DO list%size = list%size - 1 @@ -342,8 +368,9 @@ TYPE(list_${valuetype}$_type), intent(in) :: list INTEGER :: size - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_size: list is not initialized.") + END IF size = list%size END FUNCTION list_${valuetype}$_size @@ -363,29 +390,34 @@ TYPE(private_item_p_type_${valuetype}$), DIMENSION(:), POINTER :: old_arr new_cap = new_capacity - IF (new_cap < 0) & + IF (new_cap < 0) THEN CPABORT("list_${valuetype}$_change_capacity: new_capacity < 0") - IF (new_cap < list%size) & + END IF + IF (new_cap < list%size) THEN CPABORT("list_${valuetype}$_change_capacity: new_capacity < size") + END IF IF (new_cap > HUGE(i)) THEN - IF (size(list%arr) == HUGE(i)) & + IF (size(list%arr) == HUGE(i)) THEN CPABORT("list_${valuetype}$_change_capacity: list has reached integer limit.") + END IF new_cap = HUGE(i) ! grow as far as possible END IF old_arr => list%arr allocate (list%arr(new_cap), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_change_capacity: allocation failed") + END IF - do i = 1, list%size + DO i = 1, list%size allocate (list%arr(i)%p, stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_change_capacity: allocation failed") + END IF list%arr(i)%p%value ${value_assign}$old_arr(i)%p%value - deallocate (old_arr(i)%p) - end do - deallocate (old_arr) + DEALLOCATE (old_arr(i)%p) + END DO + DEALLOCATE (old_arr) END SUBROUTINE change_capacity_${valuetype}$ #:enddef diff --git a/src/common/mathlib.F b/src/common/mathlib.F index adf19a3a6e..e1c5791b79 100644 --- a/src/common/mathlib.F +++ b/src/common/mathlib.F @@ -187,8 +187,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = SQRT(DOT_PRODUCT(a, a)) - length_of_b = SQRT(DOT_PRODUCT(b, b)) + length_of_a = NORM2(a) + length_of_b = NORM2(b) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a @@ -997,8 +997,9 @@ CONTAINS ! set singular values that are too small to zero DO i = 1, n IF (sig(i) > rskip*MAXVAL(sig)) THEN - IF (PRESENT(determinant)) & + IF (PRESENT(determinant)) THEN determinant = determinant*sig(i) + END IF sig_plus(i, i) = 1._dp/sig(i) ELSE sig_plus(i, i) = 0.0_dp @@ -1975,12 +1976,14 @@ CONTAINS IF (n /= SIZE(C_out, 2)) CPABORT("Incompatible (cols) result array 3 (C).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF CALL timeset(routineN, handle) @@ -2018,12 +2021,14 @@ CONTAINS IF (n /= SIZE(C_out, 2)) CPABORT("Incompatible (cols) result array 3 (C).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF CALL timeset(routineN, handle) @@ -2068,16 +2073,19 @@ CONTAINS IF (n /= SIZE(D_out, 2)) CPABORT("Incompatible (cols) result array 4 (D).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF IF (.NOT. (C_trans == 'N' .OR. C_trans == 'n' .OR. & C_trans == 'T' .OR. C_trans == 't' .OR. & - C_trans == 'C' .OR. C_trans == 'c')) & + C_trans == 'C' .OR. C_trans == 'c')) THEN CPABORT("Unknown transpose character for array 3 (C).") + END IF CALL timeset(routineN, handle) @@ -2127,16 +2135,19 @@ CONTAINS IF (n /= SIZE(D_out, 2)) CPABORT("Incompatible (cols) result array 4 (D).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF IF (.NOT. (C_trans == 'N' .OR. C_trans == 'n' .OR. & C_trans == 'T' .OR. C_trans == 't' .OR. & - C_trans == 'C' .OR. C_trans == 'c')) & + C_trans == 'C' .OR. C_trans == 'c')) THEN CPABORT("Unknown transpose character for array 3 (C).") + END IF CALL timeset(routineN, handle) diff --git a/src/common/memory_utilities_unittest.F b/src/common/memory_utilities_unittest.F index 5534658c10..7aeb64e973 100644 --- a/src/common/memory_utilities_unittest.F +++ b/src/common/memory_utilities_unittest.F @@ -32,11 +32,13 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) & + IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) THEN ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values" + END IF - IF (.NOT. ALL(real_arr(11:20) == 0.)) & + IF (.NOT. ALL(real_arr(11:20) == 0.)) THEN ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -53,8 +55,9 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:20) == 0.)) & + IF (.NOT. ALL(real_arr(1:20) == 0.)) THEN ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -73,11 +76,13 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) & + IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) THEN ERROR STOP "check_real_rank2_allocated: reallocating changed the initial values" + END IF - IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) & + IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) THEN ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -94,8 +99,9 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) & + IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) THEN ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -114,11 +120,13 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) & + IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) THEN ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values" + END IF - IF (.NOT. ALL(str_arr(11:20) == "")) & + IF (.NOT. ALL(str_arr(11:20) == "")) THEN ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." + END IF DEALLOCATE (str_arr) @@ -135,8 +143,9 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:20) == "")) & + IF (.NOT. ALL(str_arr(1:20) == "")) THEN ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." + END IF DEALLOCATE (str_arr) diff --git a/src/common/parallel_rng_types.F b/src/common/parallel_rng_types.F index 970e64ec22..e969d79b88 100644 --- a/src/common/parallel_rng_types.F +++ b/src/common/parallel_rng_types.F @@ -512,8 +512,9 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision TYPE(rng_stream_type) :: rng_stream - IF (LEN_TRIM(name) > rng_name_length) & + IF (LEN_TRIM(name) > rng_name_length) THEN CPABORT("given random number generator name is too long") + END IF rng_stream%name = TRIM(name) @@ -630,14 +631,16 @@ CONTAINS LOGICAL, INTENT(OUT), OPTIONAL :: buffer_filled IF (PRESENT(name)) name = self%name - IF (PRESENT(distribution_type)) & + IF (PRESENT(distribution_type)) THEN distribution_type = self%distribution_type + END IF IF (PRESENT(bg)) bg = self%bg IF (PRESENT(cg)) cg = self%cg IF (PRESENT(ig)) ig = self%ig IF (PRESENT(antithetic)) antithetic = self%antithetic - IF (PRESENT(extended_precision)) & + IF (PRESENT(extended_precision)) THEN extended_precision = self%extended_precision + END IF IF (PRESENT(buffer)) buffer = self%buffer IF (PRESENT(buffer_filled)) buffer_filled = self%buffer_filled END SUBROUTINE get @@ -1131,8 +1134,9 @@ CONTAINS my_write_all = .FALSE. - IF (PRESENT(write_all)) & + IF (PRESENT(write_all)) THEN my_write_all = write_all + END IF WRITE (UNIT=output_unit, FMT="(/,T2,A,/)") & "Random number stream <"//TRIM(self%name)//">:" diff --git a/src/common/parallel_rng_types_unittest.F b/src/common/parallel_rng_types_unittest.F index 87cf2640f7..142e5f2ab9 100644 --- a/src/common/parallel_rng_types_unittest.F +++ b/src/common/parallel_rng_types_unittest.F @@ -32,14 +32,16 @@ PROGRAM parallel_rng_types_TEST nsamples = 1000 nargs = command_argument_count() - IF (nargs > 1) & + IF (nargs > 1) then ERROR STOP "Usage: parallel_rng_types_TEST []" + end if IF (nargs == 1) THEN CALL get_command_argument(1, arg) READ (arg, *, iostat=stat) nsamples - IF (stat /= 0) & + IF (stat /= 0) then ERROR STOP "Usage: parallel_rng_types_TEST []" + end if END IF CALL mp_world_init(mpi_comm) @@ -60,8 +62,9 @@ PROGRAM parallel_rng_types_TEST distribution_type=UNIFORM, & extended_precision=.TRUE.) - IF (ionode) & + IF (ionode) then CALL rng_stream%write(default_output_unit) + end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -94,8 +97,9 @@ PROGRAM parallel_rng_types_TEST distribution_type=GAUSSIAN, & extended_precision=.TRUE.) - IF (ionode) & + IF (ionode) then CALL rng_stream%write(default_output_unit) + end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -162,8 +166,9 @@ CONTAINS CALL rng_stream%get(ig=ig, cg=cg, bg=bg, name=name) IF (ANY(ig /= ig_orig) .OR. ANY(cg /= cg_orig) .OR. ANY(bg /= bg_orig) & - .OR. (name /= name_orig)) & + .OR. (name /= name_orig)) then ERROR STOP "Stream dump and load roundtrip failed" + end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Roundtrip successful" @@ -185,8 +190,9 @@ CONTAINS WRITE (UNIT=default_output_unit, FMT="(T4,A10,A433)") & "GENERATED:", rng_record - IF (rng_record /= serialized_string) & + IF (rng_record /= serialized_string) then ERROR STOP "Serialized record does not match the expected output" + end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Serialized record matches the expected output" @@ -214,19 +220,22 @@ CONTAINS arr = orig CALL rng_stream%shuffle(arr) - IF (ALL(arr == orig)) & + IF (ALL(arr == orig)) then ERROR STOP "shuffle failed: array was left untouched" + end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." - IF (ANY(arr /= orig(arr))) & + IF (ANY(arr /= orig(arr))) then ERROR STOP "shuffle failed: the shuffled original is not the shuffled original" + end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." ! sort and compare to orig mask = .TRUE. DO idx = 1, size(orig) - IF (MINVAL(arr, mask) /= orig(idx)) & + IF (MINVAL(arr, mask) /= orig(idx)) then ERROR STOP "shuffle failed: there is at least one unknown index" + end if mask(MINLOC(arr, mask)) = .FALSE. END DO WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." @@ -235,8 +244,9 @@ CONTAINS CALL rng_stream%reset() CALL rng_stream%shuffle(arr2) - IF (ANY(arr2 /= arr)) & + IF (ANY(arr2 /= arr)) then ERROR STOP "shuffle failed: array was shuffled differently with same rng state" + end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." WRITE (UNIT=default_output_unit, FMT="(T4,A)") & diff --git a/src/common/reference_manager.F b/src/common/reference_manager.F index f900554659..8ba42beaff 100644 --- a/src/common/reference_manager.F +++ b/src/common/reference_manager.F @@ -332,14 +332,18 @@ CONTAINS WRITE (unit, '(T3,A)') ''//thebib(i)%ref%source//'' ! DOI, volume, pages, year, month. - IF (ALLOCATED(thebib(i)%ref%doi)) & + IF (ALLOCATED(thebib(i)%ref%doi)) THEN WRITE (unit, '(T3,A)') ''//TRIM(substitute_special_xml_tokens(thebib(i)%ref%doi))//'' - IF (ALLOCATED(thebib(i)%ref%volume)) & + END IF + IF (ALLOCATED(thebib(i)%ref%volume)) THEN WRITE (unit, '(T3,A)') ''//thebib(i)%ref%volume//'' - IF (ALLOCATED(thebib(i)%ref%pages)) & + END IF + IF (ALLOCATED(thebib(i)%ref%pages)) THEN WRITE (unit, '(T3,A)') ''//thebib(i)%ref%pages//'' - IF (thebib(i)%ref%year > 0) & + END IF + IF (thebib(i)%ref%year > 0) THEN WRITE (unit, '(T3,A,I4.4,A)') '', thebib(i)%ref%year, '' + END IF WRITE (unit, '(T2,A)') '' END DO diff --git a/src/common/spherical_harmonics.F b/src/common/spherical_harmonics.F index 52d62548c6..96bd808f89 100644 --- a/src/common/spherical_harmonics.F +++ b/src/common/spherical_harmonics.F @@ -1805,30 +1805,42 @@ CONTAINS REAL(KIND=dp) :: sumk, t ! Check validity of the input parameters - IF (j1 < 0.0_dp) & + IF (j1 < 0.0_dp) THEN CPABORT("The angular momentum quantum number j1 has to be nonnegative") - IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) & + END IF + IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) THEN CPABORT("The angular momentum quantum number j1 has to be integer or half-integer") - IF (j2 < 0.0_dp) & + END IF + IF (j2 < 0.0_dp) THEN CPABORT("The angular momentum quantum number j2 has to be nonnegative") - IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) & + END IF + IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) THEN CPABORT("The angular momentum quantum number j2 has to be integer or half-integer") - IF (J < 0.0_dp) & + END IF + IF (J < 0.0_dp) THEN CPABORT("The angular momentum quantum number J has to be nonnegative") - IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) & + END IF + IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) THEN CPABORT("The angular momentum quantum number J has to be integer or half-integer") - IF ((ABS(m1) - j1) > EPSILON(m1)) & + END IF + IF ((ABS(m1) - j1) > EPSILON(m1)) THEN CPABORT("The angular momentum quantum number m1 has to satisfy -j1 <= m1 <= j1") - IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) & + END IF + IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) THEN CPABORT("The angular momentum quantum number m1 has to be integer or half-integer") - IF ((ABS(m2) - j2) > EPSILON(m2)) & + END IF + IF ((ABS(m2) - j2) > EPSILON(m2)) THEN CPABORT("The angular momentum quantum number m2 has to satisfy -j2 <= m1 <= j2") - IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) & + END IF + IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) THEN CPABORT("The angular momentum quantum number m2 has to be integer or half-integer") - IF ((ABS(M) - J) > EPSILON(M)) & + END IF + IF ((ABS(M) - J) > EPSILON(M)) THEN CPABORT("The angular momentum quantum number M has to satisfy -J <= M <= J") - IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) & + END IF + IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) THEN CPABORT("The angular momentum quantum number M has to be integer or half-integer") + END IF IF (is_integer(j1 + j2 + J) .AND. & is_integer(j1 + m1) .AND. & @@ -1872,8 +1884,8 @@ CONTAINS ! ************************************************************************************************** !> \brief Compute the Wigner 3-j symbol -!> / j1 j2 j3 \ -!> \ m1 m2 m3 / +!> ( j1 j2 j3 ) +!> ( m1 m2 m3 ) !> using the Clebsch-Gordon coefficients !> \param j1 Angular momentum quantum number of the first state | j1 m1 > !> \param m1 Magnetic quantum number of the first first state | j1 m1 > diff --git a/src/common/splines.F b/src/common/splines.F index 6d808dfad9..bcfc9252d5 100644 --- a/src/common/splines.F +++ b/src/common/splines.F @@ -311,21 +311,21 @@ CONTAINS i1 = 1 IF (n < 2) THEN CALL stop_error("error in iix: n < 2") - ELSEIF (n == 2) THEN + ELSE IF (n == 2) THEN i1 = 1 - ELSEIF (n == 3) THEN + ELSE IF (n == 3) THEN IF (x <= xi(2)) THEN ! first element i1 = 1 ELSE i1 = 2 END IF - ELSEIF (x <= xi(1)) THEN ! left end + ELSE IF (x <= xi(1)) THEN ! left end i1 = 1 - ELSEIF (x <= xi(2)) THEN ! first element + ELSE IF (x <= xi(2)) THEN ! first element i1 = 1 - ELSEIF (x <= xi(3)) THEN ! second element + ELSE IF (x <= xi(3)) THEN ! second element i1 = 2 - ELSEIF (x >= xi(n)) THEN ! right end + ELSE IF (x >= xi(n)) THEN ! right end i1 = n - 1 ELSE ! bisection: xi(i1) <= x < xi(i2) diff --git a/src/common/timings.F b/src/common/timings.F index fb81e07f11..d327324b23 100644 --- a/src/common/timings.F +++ b/src/common/timings.F @@ -96,8 +96,9 @@ CONTAINS IF (PRESENT(timer_env)) timer_env_ => timer_env IF (.NOT. PRESENT(timer_env)) CALL timer_env_create(timer_env_) - IF (.NOT. ASSOCIATED(timer_env_)) & + IF (.NOT. ASSOCIATED(timer_env_)) THEN CPABORT("add_timer_env: not associated") + END IF CALL timer_env_retain(timer_env_) IF (.NOT. list_isready(timers_stack)) CALL list_init(timers_stack) @@ -157,10 +158,12 @@ CONTAINS SUBROUTINE timer_env_retain(timer_env) TYPE(timer_env_type), POINTER :: timer_env - IF (.NOT. ASSOCIATED(timer_env)) & + IF (.NOT. ASSOCIATED(timer_env)) THEN CPABORT("timer_env_retain: not associated") - IF (timer_env%ref_count < 0) & + END IF + IF (timer_env%ref_count < 0) THEN CPABORT("timer_env_retain: negativ ref_count") + END IF timer_env%ref_count = timer_env%ref_count + 1 END SUBROUTINE timer_env_retain @@ -176,10 +179,12 @@ CONTAINS TYPE(callgraph_item_type), DIMENSION(:), POINTER :: ct_items TYPE(routine_stat_type), POINTER :: r_stat - IF (.NOT. ASSOCIATED(timer_env)) & + IF (.NOT. ASSOCIATED(timer_env)) THEN CPABORT("timer_env_release: not associated") - IF (timer_env%ref_count < 0) & + END IF + IF (timer_env%ref_count < 0) THEN CPABORT("timer_env_release: negativ ref_count") + END IF timer_env%ref_count = timer_env%ref_count - 1 IF (timer_env%ref_count > 0) RETURN @@ -437,10 +442,12 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env ! catch edge cases where timer_env is not yet/anymore available - IF (.NOT. list_isready(timers_stack)) & + IF (.NOT. list_isready(timers_stack)) THEN RETURN - IF (list_size(timers_stack) == 0) & + END IF + IF (list_size(timers_stack) == 0) THEN RETURN + END IF timer_env => list_peek(timers_stack) WRITE (unit_nr, '(/,A,/)') " ===== Routine Calling Stack ===== " diff --git a/src/common/timings_report.F b/src/common/timings_report.F index eedcf3e659..03b5a4166d 100644 --- a/src/common/timings_report.F +++ b/src/common/timings_report.F @@ -77,8 +77,9 @@ CONTAINS CALL list_init(reports) CALL collect_reports_from_ranks(reports, cost_type, para_env) - IF (list_size(reports) > 0 .AND. iw > 0) & + IF (list_size(reports) > 0 .AND. iw > 0) THEN CALL print_reports(reports, iw, r_timings, sort_by_self_time, cost_type, report_maxloc, para_env) + END IF ! deallocate reports DO WHILE (list_size(reports) > 0) @@ -111,8 +112,9 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env NULLIFY (r_stat, r_report, timer_env) - IF (.NOT. list_isready(reports)) & + IF (.NOT. list_isready(reports)) THEN CPABORT("BUG") + END IF timer_env => get_timer_env() @@ -232,8 +234,9 @@ CONTAINS TYPE(routine_report_type), POINTER :: r_report_i, r_report_j NULLIFY (r_report_i, r_report_j) - IF (.NOT. list_isready(reports)) & + IF (.NOT. list_isready(reports)) THEN CPABORT("BUG") + END IF ! are we printing timing or energy ? SELECT CASE (cost_type) diff --git a/src/common/util.F b/src/common/util.F index f20e1ebfff..1c1988135b 100644 --- a/src/common/util.F +++ b/src/common/util.F @@ -174,7 +174,7 @@ CONTAINS IF (j == 1) THEN DO i = 1, isize INDEX(i) = i - ENDDO + END DO END IF ! Allocate scratch arrays diff --git a/src/commutator_rpnl.F b/src/commutator_rpnl.F index db7084cbf9..669f952309 100644 --- a/src/commutator_rpnl.F +++ b/src/commutator_rpnl.F @@ -217,7 +217,7 @@ CONTAINS nprj_ppnl => gpotential(kkind)%gth_potential%nprj_ppnl ppnl_radius = gpotential(kkind)%gth_potential%ppnl_radius vprj_ppnl => gpotential(kkind)%gth_potential%vprj_ppnl - ELSEIF (spot) THEN + ELSE IF (spot) THEN CPABORT('SGP not implemented') ELSE CPABORT('PPNL unknown') @@ -868,282 +868,304 @@ CONTAINS IF (my_rxrv) THEN ! x-component (y [z,Vnl] - z [y, Vnl]) - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 9), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! yzV - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 3), na, & - ! bcint(1, 1, 4), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! -yVz - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 9), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! -zyV - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 4), na, & - ! bcint(1, 1, 3), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! zVy - ! with MATMUL IF (iatom <= jatom) THEN + ! yzV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! -yVz blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! -yVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) + ! -zyV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -zyV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zVy blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! zVy + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) ELSE + ! yzV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! -yVz blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! -yVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) + ! -zyV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! -zyV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zVy blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) ! zVy + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) END IF ! y-component (z [x,Vnl] - x [z, Vnl]) - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 7), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! zxV - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 4), na, & - ! bcint(1, 1, 2), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! -zVx - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 7), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! -xzV - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 2), na, & - ! bcint(1, 1, 4), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! xVz - ! with MATMUL IF (iatom <= jatom) THEN + ! zxV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zxV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! -zVx blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! -zVx + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) + ! -xzV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -xzV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xVz blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ELSE + ! zxV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! zxV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! -zVx blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) ! -zVx + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) + ! -xzV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! -xzV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xVz blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) END IF ! z-component (x [y,Vnl] - y [x, Vnl]) - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 6), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! xyV - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 2), na, & - ! bcint(1, 1, 3), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! -xVy - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 6), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! -yxV - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 3), na, & - ! bcint(1, 1, 2), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! yVx - ! with MATMUL IF (iatom <= jatom) THEN + ! xyV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! -xVy blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! -xVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) + ! -yxV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -yxV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zVx blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! zVx + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) ELSE + ! xyV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! -xVy blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! -xVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) + ! -yxV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! -yxV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zVx blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) ! zVx + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) END IF END IF IF (my_rrv) THEN ! r_alpha * r_beta * Vnl - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 5), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(1)%block, SIZE(blocks_rrv(1)%block, 1)) ! xxV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 6), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(2)%block, SIZE(blocks_rrv(2)%block, 1)) ! xyV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 7), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(3)%block, SIZE(blocks_rrv(3)%block, 1)) ! xzV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 8), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(4)%block, SIZE(blocks_rrv(4)%block, 1)) ! yyV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 9), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(5)%block, SIZE(blocks_rrv(5)%block, 1)) ! yzV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 10), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(6)%block, SIZE(blocks_rrv(6)%block, 1)) ! zzV - ! with MATMUL IF (iatom <= jatom) THEN + ! xxV blocks_rrv(1)%block(1:na, 1:nb) = blocks_rrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xyV blocks_rrv(2)%block(1:na, 1:nb) = blocks_rrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xzV blocks_rrv(3)%block(1:na, 1:nb) = blocks_rrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yyV blocks_rrv(4)%block(1:na, 1:nb) = blocks_rrv(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yzV blocks_rrv(5)%block(1:na, 1:nb) = blocks_rrv(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zzV blocks_rrv(6)%block(1:na, 1:nb) = blocks_rrv(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ELSE + ! xxV blocks_rrv(1)%block(1:nb, 1:na) = blocks_rrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xyV blocks_rrv(2)%block(1:nb, 1:na) = blocks_rrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xzV blocks_rrv(3)%block(1:nb, 1:na) = blocks_rrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yyV blocks_rrv(4)%block(1:nb, 1:na) = blocks_rrv(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yzV blocks_rrv(5)%block(1:nb, 1:na) = blocks_rrv(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zzV blocks_rrv(6)%block(1:nb, 1:na) = blocks_rrv(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) END IF ! - Vnl * r_alpha * r_beta - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 5), nb, 1.0_dp, blocks_rrv(1)%block, SIZE(blocks_rrv(1)%block, 1)) ! Vxx - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 6), nb, 1.0_dp, blocks_rrv(2)%block, SIZE(blocks_rrv(2)%block, 1)) ! Vxy - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 7), nb, 1.0_dp, blocks_rrv(3)%block, SIZE(blocks_rrv(3)%block, 1)) ! Vxz - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 8), nb, 1.0_dp, blocks_rrv(4)%block, SIZE(blocks_rrv(4)%block, 1)) ! Vyy - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 9), nb, 1.0_dp, blocks_rrv(5)%block, SIZE(blocks_rrv(5)%block, 1)) ! Vyz - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 10), nb, 1.0_dp, blocks_rrv(6)%block, SIZE(blocks_rrv(6)%block, 1)) ! Vzz - ! with MATMUL IF (iatom <= jatom) THEN + ! -Vxx blocks_rrv(1)%block(1:na, 1:nb) = blocks_rrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! -Vxx + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) + ! -Vxy blocks_rrv(2)%block(1:na, 1:nb) = blocks_rrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! -Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) + ! -Vxz blocks_rrv(3)%block(1:na, 1:nb) = blocks_rrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! -Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) + ! -Vyy blocks_rrv(4)%block(1:na, 1:nb) = blocks_rrv(4)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! -Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) + ! -Vyz blocks_rrv(5)%block(1:na, 1:nb) = blocks_rrv(5)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! -Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) + ! -Vzz blocks_rrv(6)%block(1:na, 1:nb) = blocks_rrv(6)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! -Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ELSE + ! -Vxx blocks_rrv(1)%block(1:nb, 1:na) = blocks_rrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! -Vxx + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) + ! -Vxy blocks_rrv(2)%block(1:nb, 1:na) = blocks_rrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! -Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) + ! -Vxz blocks_rrv(3)%block(1:nb, 1:na) = blocks_rrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! -Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) + ! -Vyy blocks_rrv(4)%block(1:nb, 1:na) = blocks_rrv(4)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! -Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) + ! -Vyz blocks_rrv(5)%block(1:nb, 1:na) = blocks_rrv(5)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! -Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) + ! -Vzz blocks_rrv(6)%block(1:nb, 1:na) = blocks_rrv(6)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! -Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) END IF END IF IF (my_rvr) THEN ! r_alpha * Vnl * r_beta IF (iatom <= jatom) THEN + ! xVx blocks_rvr(1)%block(1:na, 1:nb) = blocks_rvr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! xVx + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) + ! xVy blocks_rvr(2)%block(1:na, 1:nb) = blocks_rvr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! xVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) + ! xVz blocks_rvr(3)%block(1:na, 1:nb) = blocks_rvr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) + ! yVy blocks_rvr(4)%block(1:na, 1:nb) = blocks_rvr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! yVy + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) + ! yVz blocks_rvr(5)%block(1:na, 1:nb) = blocks_rvr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! yVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) + ! zVz blocks_rvr(6)%block(1:na, 1:nb) = blocks_rvr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! zVz + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) ELSE + ! xVx blocks_rvr(1)%block(1:nb, 1:na) = blocks_rvr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) ! xVx + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) + ! xVy blocks_rvr(2)%block(1:nb, 1:na) = blocks_rvr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! xVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) + ! xVz blocks_rvr(3)%block(1:nb, 1:na) = blocks_rvr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) + ! yVy blocks_rvr(4)%block(1:nb, 1:na) = blocks_rvr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) ! yVy + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) + ! yVz blocks_rvr(5)%block(1:nb, 1:na) = blocks_rvr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! yVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) + ! zVz blocks_rvr(6)%block(1:nb, 1:na) = blocks_rvr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) ! zVz + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) END IF END IF IF (my_rrv_vrr) THEN ! r_alpha * r_beta * Vnl IF (iatom <= jatom) THEN + ! xxV blocks_rrv_vrr(1)%block(1:na, 1:nb) = blocks_rrv_vrr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xyV blocks_rrv_vrr(2)%block(1:na, 1:nb) = blocks_rrv_vrr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xzV blocks_rrv_vrr(3)%block(1:na, 1:nb) = blocks_rrv_vrr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yyV blocks_rrv_vrr(4)%block(1:na, 1:nb) = blocks_rrv_vrr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yzV blocks_rrv_vrr(5)%block(1:na, 1:nb) = blocks_rrv_vrr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zzV blocks_rrv_vrr(6)%block(1:na, 1:nb) = blocks_rrv_vrr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ELSE + ! xxV blocks_rrv_vrr(1)%block(1:nb, 1:na) = blocks_rrv_vrr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xyV blocks_rrv_vrr(2)%block(1:nb, 1:na) = blocks_rrv_vrr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xzV blocks_rrv_vrr(3)%block(1:nb, 1:na) = blocks_rrv_vrr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yyV blocks_rrv_vrr(4)%block(1:nb, 1:na) = blocks_rrv_vrr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yzV blocks_rrv_vrr(5)%block(1:nb, 1:na) = blocks_rrv_vrr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zzV blocks_rrv_vrr(6)%block(1:nb, 1:na) = blocks_rrv_vrr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) END IF ! + Vnl * r_alpha * r_beta IF (iatom <= jatom) THEN + ! +Vxx blocks_rrv_vrr(1)%block(1:na, 1:nb) = blocks_rrv_vrr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! +Vxx + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) + ! +Vxy blocks_rrv_vrr(2)%block(1:na, 1:nb) = blocks_rrv_vrr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! +Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) + ! +Vxz blocks_rrv_vrr(3)%block(1:na, 1:nb) = blocks_rrv_vrr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! +Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) + ! +Vyy blocks_rrv_vrr(4)%block(1:na, 1:nb) = blocks_rrv_vrr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! +Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) + ! +Vyz blocks_rrv_vrr(5)%block(1:na, 1:nb) = blocks_rrv_vrr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! +Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) + ! +Vzz blocks_rrv_vrr(6)%block(1:na, 1:nb) = blocks_rrv_vrr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! +Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ELSE + ! +Vxx blocks_rrv_vrr(1)%block(1:nb, 1:na) = blocks_rrv_vrr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! +Vxx + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) + ! +Vxy blocks_rrv_vrr(2)%block(1:nb, 1:na) = blocks_rrv_vrr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! +Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) + ! +Vxz blocks_rrv_vrr(3)%block(1:nb, 1:na) = blocks_rrv_vrr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! +Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) + ! +Vyy blocks_rrv_vrr(4)%block(1:nb, 1:na) = blocks_rrv_vrr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! +Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) + ! +Vyz blocks_rrv_vrr(5)%block(1:nb, 1:na) = blocks_rrv_vrr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! +Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) + ! +Vzz blocks_rrv_vrr(6)%block(1:nb, 1:na) = blocks_rrv_vrr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! +Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) END IF END IF ! The indices are stored in i_1, i_x, ..., i_zzz - ! matrix_r_rxvr(alpha, beta) - ! = sum_(gamma delta) epsilon_(alpha gamma delta) - ! (r_beta * r_gamma * V_nl * r_delta - r_beta * r_gamma * r_delta * V_nl) - ! = sum_(gamma delta) epsilon_(alpha gamma delta) r_beta * r_gamma * V_nl * r_delta ! TODO: is this set to zero before? IF (my_r_rxvr) THEN diff --git a/src/constraint.F b/src/constraint.F index e6d1308ea4..c8bdc9e2fa 100644 --- a/src/constraint.F +++ b/src/constraint.F @@ -157,43 +157,51 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL shake_3x3_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL shake_4x6_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL shake_colv_int(molecule, particle_set, pos, vel, dt, ishake_int, & cell, imass, int_max_sigma) + END IF END DO Shake_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL shake_int_info(log_unit, i, ishake_int, max_sigma) ! Virtual Site - IF (nvsitecon /= 0) & + IF (nvsitecon /= 0) THEN CALL shake_vsite_int(molecule, pos) + END IF END DO END DO MOL ! Intermolecular constraints IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL shake_3x3_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL shake_4x6_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL shake_colv_ext(gci, particle_set, pos, vel, dt, ishake_ext, & cell, imass, max_sigma) + END IF ! Virtual Site - IF (gci%nvsite /= 0) & + IF (gci%nvsite /= 0) THEN CALL shake_vsite_ext(gci, pos) + END IF CALL restore_temporary_set(particle_set, local_particles, pos=pos, vel=vel) END IF CALL shake_ext_info(log_unit, ishake_ext, max_sigma) @@ -283,15 +291,18 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL rattle_3x3_int(molecule, particle_set, vel, dt) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL rattle_4x6_int(molecule, particle_set, vel, dt) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL rattle_colv_int(molecule, particle_set, vel, dt, & irattle_int, cell, imass, int_max_sigma) + END IF END DO Rattle_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL rattle_int_info(log_unit, i, irattle_int, max_sigma) @@ -301,15 +312,18 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL rattle_3x3_ext(gci, particle_set, vel, dt) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL rattle_4x6_ext(gci, particle_set, vel, dt) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL rattle_colv_ext(gci, particle_set, vel, dt, & irattle_ext, cell, imass, max_sigma) + END IF CALL restore_temporary_set(particle_set, local_particles, vel=vel) END IF CALL rattle_ext_info(log_unit, irattle_ext, max_sigma) @@ -417,17 +431,20 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL shake_roll_3x3_int(molecule, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_int, int_max_sigma) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL shake_roll_4x6_int(molecule, particle_set, pos, vel, r_shake, & dt, ishake_int, int_max_sigma) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL shake_roll_colv_int(molecule, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_int, cell, imass, int_max_sigma) + END IF END DO Shake_Roll_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL shake_int_info(log_unit, i, ishake_int, max_sigma) @@ -441,20 +458,24 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL shake_roll_3x3_ext(gci, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_ext, max_sigma) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL shake_roll_4x6_ext(gci, particle_set, pos, vel, r_shake, & dt, ishake_ext, max_sigma) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL shake_roll_colv_ext(gci, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_ext, cell, imass, max_sigma) + END IF ! Virtual Site - IF (gci%nvsite /= 0) & + IF (gci%nvsite /= 0) THEN CPABORT("Virtual Site Constraint/Restraint not implemented for SHAKE_ROLL!") + END IF CALL restore_temporary_set(particle_set, local_particles, pos=pos, vel=vel) END IF CALL shake_ext_info(log_unit, ishake_ext, max_sigma) @@ -564,17 +585,20 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL rattle_roll_3x3_int(molecule, particle_set, vel, r_rattle, dt, & veps) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL rattle_roll_4x6_int(molecule, particle_set, vel, r_rattle, dt, & veps) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL rattle_roll_colv_int(molecule, particle_set, vel, r_rattle, dt, & irattle_int, veps, cell, imass, int_max_sigma) + END IF END DO Rattle_Roll_Intramolecular max_sigma = MAX(max_sigma, int_max_sigma) CALL rattle_int_info(log_unit, i, irattle_int, max_sigma) @@ -584,17 +608,20 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(para_env, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL rattle_roll_3x3_ext(gci, particle_set, vel, r_rattle, dt, & veps) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL rattle_roll_4x6_ext(gci, particle_set, vel, r_rattle, dt, & veps) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL rattle_roll_colv_ext(gci, particle_set, vel, r_rattle, dt, & irattle_ext, veps, cell, imass, max_sigma) + END IF CALL restore_temporary_set(particle_set, local_particles, vel=vel) END IF CALL rattle_ext_info(log_unit, irattle_ext, max_sigma) @@ -708,7 +735,7 @@ CONTAINS IF (log_unit > 0) THEN IF (id_type == "S") THEN label = "Shake Lagrangian Multipliers:" - ELSEIF (id_type == "R") THEN + ELSE IF (id_type == "R") THEN label = "Rattle Lagrangian Multipliers:" ELSE CPABORT("Only S for Shake or R for Rattle are supported for Lagrangian Multipliers") @@ -743,11 +770,12 @@ CONTAINS "Molecule Nr.:", i, " Nr. Iterations:", ishake_int, " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_int > Max_Shake_Iter) & + IF (ishake_int > Max_Shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Shake NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intramolecular constraint loop for Molecule nr. "//cp_to_string(i)// & ". CP2K continues but results could be meaningless. ") + END IF END SUBROUTINE shake_int_info ! ************************************************************************************************** @@ -769,10 +797,11 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_ext > Max_Shake_Iter) & + IF (ishake_ext > Max_Shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Shake NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") + END IF END SUBROUTINE shake_ext_info ! ************************************************************************************************** @@ -794,11 +823,12 @@ CONTAINS "Molecule Nr.:", i, " Nr. Iterations:", irattle_int, " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_int > Max_shake_Iter) & + IF (irattle_int > Max_shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intramolecular constraint loop for Molecule nr. "//cp_to_string(i)// & ". CP2K continues but results could be meaningless.") + END IF END SUBROUTINE rattle_int_info ! ************************************************************************************************** @@ -820,10 +850,11 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_ext > Max_shake_Iter) & + IF (irattle_ext > Max_shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") + END IF END SUBROUTINE rattle_ext_info ! ************************************************************************************************** diff --git a/src/constraint_fxd.F b/src/constraint_fxd.F index 225416d12d..b4f9e7b7e8 100644 --- a/src/constraint_fxd.F +++ b/src/constraint_fxd.F @@ -398,8 +398,9 @@ CONTAINS DO k = 1, SIZE(fixd_list) IF (fixd_list(k)%fixd == j) THEN IF (fixd_list(k)%itype /= use_perd_xyz) CYCLE - IF (.NOT. fixd_list(k)%restraint%active) & + IF (.NOT. fixd_list(k)%restraint%active) THEN colvar%dsdr(:, i) = 0.0_dp + END IF EXIT END IF END DO diff --git a/src/constraint_util.F b/src/constraint_util.F index 0570c248f1..dec377128b 100644 --- a/src/constraint_util.F +++ b/src/constraint_util.F @@ -554,8 +554,8 @@ CONTAINS v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) diag = MATMUL(r_shake, v_shake) r_shake = diag - ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & - PRESENT(vector_r)) THEN + ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & + PRESENT(vector_r)) THEN DO i = 1, 3 r_shake(i, i) = vector_r(i)*vector_v(i) v_shake(i, i) = vector_v(i) @@ -569,7 +569,7 @@ CONTAINS diag(2, 2) = vector_v(2) diag(3, 3) = vector_v(3) v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) - ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN + ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN DO i = 1, 3 v_shake(i, i) = vector_v(i) END DO diff --git a/src/constraint_vsite.F b/src/constraint_vsite.F index 12c4cd96c5..ffdbb8ba52 100644 --- a/src/constraint_vsite.F +++ b/src/constraint_vsite.F @@ -94,14 +94,16 @@ CONTAINS molecule_kind => molecule%molecule_kind CALL get_molecule_kind(molecule_kind, nconstraint=nconstraint, nvsite=nvsitecon) IF (nconstraint == 0) CYCLE - IF (nvsitecon /= 0) & + IF (nvsitecon /= 0) THEN CALL force_vsite_int(molecule, particle_set) + END IF END DO END DO MOL ! Intermolecular Virtual Site Constraints IF (do_ext_constraint) THEN - IF (gci%nvsite /= 0) & + IF (gci%nvsite /= 0) THEN CALL force_vsite_ext(gci, particle_set) + END IF END IF END SUBROUTINE vsite_force_control diff --git a/src/core_ppl.F b/src/core_ppl.F index c1041e16d2..e47510449d 100644 --- a/src/core_ppl.F +++ b/src/core_ppl.F @@ -448,7 +448,7 @@ CONTAINS IF (ecp_semi_local) THEN CALL get_potential(potential=sgp_potential, sl_lmax=slmax, & npot=npot, nrpot=nrpot, apot=apot, bpot=bpot) - ELSEIF (ecp_local) THEN + ELSE IF (ecp_local) THEN IF (SUM(ABS(aloc(1:nloc))) < 1.0e-12_dp) CYCLE END IF ELSE @@ -498,7 +498,7 @@ CONTAINS rab, dab, rac, dac, rbc, dbc, & hab(:, :, iset, jset), ppl_work, pab(:, :, iset, jset), & force_a, force_b, ppl_fwork) - ELSEIF (libgrpp_local) THEN + ELSE IF (libgrpp_local) THEN !$OMP CRITICAL(type1) CALL libgrpp_local_forces_ref(la_max(iset), la_min(iset), npgfa(iset), & rpgfa(:, iset), zeta(:, iset), & @@ -556,7 +556,7 @@ CONTAINS CALL virial_pair_force(pv_thread, f0, force_a, rac) CALL virial_pair_force(pv_thread, f0, force_b, rbc) END IF - ELSEIF (do_dR) THEN + ELSE IF (do_dR) THEN hab2_w = 0._dp CALL ppl_integral( & la_max(iset), la_min(iset), npgfa(iset), & @@ -584,7 +584,7 @@ CONTAINS nexp_ppl, alpha_ppl, nct_ppl, cval_ppl, ppl_radius, & rab, dab, rac, dac, rbc, dbc, hab(:, :, iset, jset), ppl_work) - ELSEIF (libgrpp_local) THEN + ELSE IF (libgrpp_local) THEN !If the local part of the potential is more complex, we need libgrpp !$OMP CRITICAL(type1) CALL libgrpp_local_integrals(la_max(iset), la_min(iset), npgfa(iset), & diff --git a/src/core_ppnl.F b/src/core_ppnl.F index 906658762a..7fc2104d7e 100644 --- a/src/core_ppnl.F +++ b/src/core_ppnl.F @@ -667,7 +667,7 @@ CONTAINS END IF IF (do_dR) THEN - i = 1; j = 2; + i = 1; j = 2 katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + & @@ -686,7 +686,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 2; j = 3; + i = 2; j = 3 katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_2block(1:na, 1:nb) = r_2block(1:na, 1:nb) + & @@ -705,7 +705,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 3; j = 4; + i = 3; j = 4 katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_3block(1:na, 1:nb) = r_3block(1:na, 1:nb) + & diff --git a/src/cp2k_debug.F b/src/cp2k_debug.F index 3d288eeb82..c426ba1006 100644 --- a/src/cp2k_debug.F +++ b/src/cp2k_debug.F @@ -612,7 +612,7 @@ CONTAINS IF (dft_control%apply_efield) THEN dft_control%efield_fields(1)%efield%strength = amplitude dft_control%efield_fields(1)%efield%polarisation(1:3) = poldir(1:3) - ELSEIF (dft_control%apply_period_efield) THEN + ELSE IF (dft_control%apply_period_efield) THEN dft_control%period_efield%strength = amplitude dft_control%period_efield%polarisation(1:3) = poldir(1:3) ELSE diff --git a/src/cp_control_types.F b/src/cp_control_types.F index 47d3cb3bf7..4470a26447 100644 --- a/src/cp_control_types.F +++ b/src/cp_control_types.F @@ -891,8 +891,9 @@ CONTAINS SUBROUTINE mulliken_control_release(mulliken_restraint_control) TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken_restraint_control - IF (ASSOCIATED(mulliken_restraint_control%atoms)) & + IF (ASSOCIATED(mulliken_restraint_control%atoms)) THEN DEALLOCATE (mulliken_restraint_control%atoms) + END IF mulliken_restraint_control%strength = 0.0_dp mulliken_restraint_control%target = 0.0_dp mulliken_restraint_control%natoms = 0 @@ -927,10 +928,12 @@ CONTAINS SUBROUTINE ddapc_control_release(ddapc_restraint_control) TYPE(ddapc_restraint_type), INTENT(INOUT) :: ddapc_restraint_control - IF (ASSOCIATED(ddapc_restraint_control%atoms)) & + IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN DEALLOCATE (ddapc_restraint_control%atoms) - IF (ASSOCIATED(ddapc_restraint_control%coeff)) & + END IF + IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN DEALLOCATE (ddapc_restraint_control%coeff) + END IF ddapc_restraint_control%strength = 0.0_dp ddapc_restraint_control%target = 0.0_dp ddapc_restraint_control%natoms = 0 @@ -1207,18 +1210,21 @@ CONTAINS IF (ASSOCIATED(proj_mo_list)) THEN DO i = 1, SIZE(proj_mo_list) IF (ASSOCIATED(proj_mo_list(i)%proj_mo)) THEN - IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) & + IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) THEN DEALLOCATE (proj_mo_list(i)%proj_mo%ref_mo_index) + END IF IF (ALLOCATED(proj_mo_list(i)%proj_mo%mo_ref)) THEN DO mo_ref_nbr = 1, SIZE(proj_mo_list(i)%proj_mo%mo_ref) CALL cp_fm_release(proj_mo_list(i)%proj_mo%mo_ref(mo_ref_nbr)) END DO DEALLOCATE (proj_mo_list(i)%proj_mo%mo_ref) END IF - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) & + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) THEN DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_index) - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) & + END IF + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) THEN DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_occ) + END IF DEALLOCATE (proj_mo_list(i)%proj_mo) END IF END DO @@ -1244,8 +1250,9 @@ CONTAINS IF (ASSOCIATED(efield_fields(i)%efield%envelop_i_vars)) THEN DEALLOCATE (efield_fields(i)%efield%envelop_i_vars) END IF - IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) & + IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) THEN DEALLOCATE (efield_fields(i)%efield%polarisation) + END IF DEALLOCATE (efield_fields(i)%efield) END IF END DO diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index 23cc7d56b5..abe607899e 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -164,20 +164,23 @@ CONTAINS CALL section_vals_val_get(xc_section, "gradient_cutoff", r_val=gradient_cut) CALL section_vals_val_get(xc_section, "tau_cutoff", r_val=tau_cut) ! Perform numerical stability checks and possibly correct the issues - IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) & + IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) THEN CALL cp_warn(__LOCATION__, & "DENSITY_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") + END IF density_cut = MAX(EPSILON(0.0_dp)*100.0_dp, density_cut) - IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) & + IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) THEN CALL cp_warn(__LOCATION__, & "GRADIENT_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") + END IF gradient_cut = MAX(EPSILON(0.0_dp)*100.0_dp, gradient_cut) - IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) & + IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) THEN CALL cp_warn(__LOCATION__, & "TAU_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") + END IF tau_cut = MAX(EPSILON(0.0_dp)*100.0_dp, tau_cut) CALL section_vals_val_set(xc_section, "density_cutoff", r_val=density_cut) CALL section_vals_val_set(xc_section, "gradient_cutoff", r_val=gradient_cut) @@ -416,8 +419,9 @@ CONTAINS IF (dft_control%admm_control%purification_method == do_admm_purify_mo_diag .OR. & dft_control%admm_control%purification_method == do_admm_purify_mo_no_diag) THEN - IF (dft_control%admm_control%method /= do_admm_basis_projection) & + IF (dft_control%admm_control%method /= do_admm_basis_projection) THEN CPABORT("ADMM: Chosen purification requires BASIS_PROJECTION") + END IF IF (.NOT. do_ot) CPABORT("ADMM: MO-based purification requires OT.") END IF @@ -440,9 +444,10 @@ CONTAINS CALL section_vals_val_get(dft_section, "MULTIPLICITY", i_val=dft_control%multiplicity) CALL section_vals_val_get(dft_section, "RELAX_MULTIPLICITY", r_val=dft_control%relax_multiplicity) IF (dft_control%relax_multiplicity > 0.0_dp) THEN - IF (.NOT. dft_control%uks) & + IF (.NOT. dft_control%uks) THEN CALL cp_abort(__LOCATION__, "The option RELAX_MULTIPLICITY is only valid for "// & "unrestricted Kohn-Sham (UKS) calculations") + END IF END IF !Read the HAIR PROBES input section if present @@ -578,8 +583,9 @@ CONTAINS CALL section_vals_val_get(tmp_section, "POLARISATION", r_vals=pol) dft_control%period_efield%polarisation(1:3) = pol(1:3) IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) & + IF (ASSOCIATED(cell)) THEN CALL cell_transform_input_cartesian(cell, dft_control%period_efield%polarisation(1:3)) + END IF END IF CALL section_vals_val_get(tmp_section, "D_FILTER", r_vals=pol) dft_control%period_efield%d_filter(1:3) = pol(1:3) @@ -659,11 +665,12 @@ CONTAINS END IF ! periodic fields don't work with RTP - IF (do_rtp) & + IF (do_rtp) THEN CALL cp_abort(__LOCATION__, & "Periodic efield cannot be used with RTP. When restarting a "// & "run with periodic efield, set RESTART_RTP under &EXT_RESTART "// & "section to .FALSE. explicitly if RESTART_DEFAULT is .TRUE.") + END IF IF (dft_control%period_efield%displacement_field) THEN CALL cite_reference(Stengel2009) ELSE @@ -1232,8 +1239,9 @@ CONTAINS jj = jj + SIZE(tmplist) END DO qs_control%mulliken_restraint_control%natoms = jj - IF (qs_control%mulliken_restraint_control%natoms < 1) & + IF (qs_control%mulliken_restraint_control%natoms < 1) THEN CPABORT("Need at least 1 atom to use mulliken constraints") + END IF ALLOCATE (qs_control%mulliken_restraint_control%atoms(qs_control%mulliken_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -1281,10 +1289,11 @@ CONTAINS CALL section_vals_val_get(se_section, "INTEGRAL_SCREENING", & i_val=qs_control%se_control%integral_screening) IF (qs_control%method_id == do_method_pnnl) THEN - IF (qs_control%se_control%integral_screening /= do_se_IS_slater) & + IF (qs_control%se_control%integral_screening /= do_se_IS_slater) THEN CALL cp_warn(__LOCATION__, & "PNNL semi-empirical parameterization supports only the Slater type "// & "integral scheme. Revert to Slater and continue the calculation.") + END IF qs_control%se_control%integral_screening = do_se_IS_slater END IF ! Global Arrays variable @@ -1349,21 +1358,23 @@ CONTAINS qs_control%se_control%do_ewald = .FALSE. qs_control%se_control%do_ewald_r3 = .FALSE. qs_control%se_control%do_ewald_gks = .TRUE. - IF (qs_control%method_id /= do_method_pnnl) & + IF (qs_control%method_id /= do_method_pnnl) THEN CALL cp_abort(__LOCATION__, & "A periodic semi-empirical calculation was requested with a long-range "// & "summation on the single integral evaluation. This scheme is supported "// & "only by the PNNL parameterization.") + END IF CASE (do_se_lr_ewald_r3) qs_control%se_control%do_ewald = .TRUE. qs_control%se_control%do_ewald_r3 = .TRUE. qs_control%se_control%do_ewald_gks = .FALSE. - IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) & + IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) THEN CALL cp_abort(__LOCATION__, & "A periodic semi-empirical calculation was requested with a long-range "// & "summation for the slowly convergent part 1/R^3, which is not congruent "// & "with the integral screening chosen. The only integral screening supported "// & "by this periodic type calculation is the standard Klopman-Dewar-Sabelli-Ohno.") + END IF END SELECT ! dispersion pair potentials @@ -1427,18 +1438,21 @@ CONTAINS "DFTB/TBLITE_MIXER") IF (qs_control%do_ls_scf) THEN IF (dftb_scc_mixer_explicit .AND. & - qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & + qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN CALL cp_warn(__LOCATION__, & "DFTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - IF (dftb_tblite_mixer_explicit) & + END IF + IF (dftb_tblite_mixer_explicit) THEN CALL cp_warn(__LOCATION__, & "DFTB/TBLITE_MIXER settings are ignored with QS/LS_SCF; LS_SCF controls "// & "the density-matrix optimization.") + END IF qs_control%dftb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF - IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) & + IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) THEN CPABORT("DFTB/TBLITE_MIXER/DAMPING must be positive") + END IF CALL section_vals_val_get(dftb_section, "EPS_DISP", & r_val=qs_control%dftb_control%eps_disp) CALL section_vals_val_get(dftb_section, "DO_EWALD", explicit=explicit) @@ -1498,8 +1512,9 @@ CONTAINS CALL section_vals_val_get(xtb_tblite, "_SECTION_PARAMETERS_", l_val=tblite_section_active) qs_control%xtb_control%do_tblite = (qs_control%xtb_control%gfn_type == gfn_tblite) IF (qs_control%xtb_control%do_tblite) THEN - IF (.NOT. tblite_section_active) & + IF (.NOT. tblite_section_active) THEN CPABORT("XTB/GFN_TYPE TBLITE requires an XTB/TBLITE section") + END IF ! The CP2K-internal GFN1 defaults are still used to initialize shared xTB fields. qs_control%xtb_control%gfn_type = gfn1xtb ELSE IF (tblite_section_active) THEN @@ -1520,37 +1535,43 @@ CONTAINS qs_control%xtb_control%tblite_mixer_max_weight, & qs_control%xtb_control%tblite_mixer_weight_factor, & "XTB/TBLITE_MIXER") - IF (xtb_tblite_mixer_explicit) & + IF (xtb_tblite_mixer_explicit) THEN CALL section_vals_val_get(xtb_tblite_mixer, "DAMPING", & explicit=qs_control%xtb_control%tblite_mixer_damping_explicit) + END IF IF ((.NOT. qs_control%xtb_control%do_tblite) .AND. & qs_control%xtb_control%gfn_type == 0) THEN IF (xtb_scc_mixer_explicit .AND. & qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_auto .AND. & - qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") - IF (xtb_tblite_mixer_explicit) & + END IF + IF (xtb_tblite_mixer_explicit) THEN CALL cp_warn(__LOCATION__, & "XTB/TBLITE_MIXER settings are ignored for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") + END IF qs_control%xtb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF IF (qs_control%do_ls_scf) THEN IF (xtb_scc_mixer_explicit .AND. & - qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - IF (xtb_tblite_mixer_explicit) & + END IF + IF (xtb_tblite_mixer_explicit) THEN CALL cp_warn(__LOCATION__, & "XTB/TBLITE_MIXER settings are ignored with QS/LS_SCF; LS_SCF controls "// & "the density-matrix optimization.") + END IF qs_control%xtb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN CPABORT("XTB/TBLITE_MIXER/DAMPING must be positive") + END IF CALL section_vals_val_get(xtb_section, "DO_EWALD", explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(xtb_section, "DO_EWALD", & @@ -1870,14 +1891,17 @@ CONTAINS c_val=qs_control%xtb_control%tblite_param_file) CALL section_vals_val_get(xtb_tblite, "ACCURACY", & r_val=qs_control%xtb_control%tblite_accuracy) - IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) & + IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) THEN CPABORT("XTB/TBLITE/ACCURACY must be positive") - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & + END IF + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN CPABORT("XTB/TBLITE_MIXER/DAMPING must be positive") + END IF CALL section_vals_val_get(xtb_tblite, "REFERENCE_CLI", l_val=tblite_reference_cli) CALL section_vals_get(xtb_tblite_ref_cli, explicit=tblite_reference_cli_section) - IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) & + IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI keyword requires an XTB/TBLITE/REFERENCE_CLI section") + END IF IF (tblite_reference_cli .OR. tblite_reference_cli_section) THEN CALL read_xtb_reference_cli_section(xtb_tblite_ref_cli, qs_control%xtb_control%reference_cli, cell) qs_control%xtb_control%reference_cli%enabled = .TRUE. @@ -1941,8 +1965,9 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT(TRIM(section_name)//"/OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT(TRIM(section_name)//"/MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT(TRIM(section_name)//"/MAX_WEIGHT must be positive") - IF (max_weight < min_weight) & + IF (max_weight < min_weight) THEN CPABORT(TRIM(section_name)//"/MAX_WEIGHT must not be smaller than MIN_WEIGHT") + END IF IF (weight_factor <= 0.0_dp) CPABORT(TRIM(section_name)//"/WEIGHT_FACTOR must be positive") END SUBROUTINE read_tblite_mixer_section @@ -1991,11 +2016,13 @@ CONTAINS CALL section_vals_val_get(solvation_section, "SOLVENT", c_val=ref_cli%solvation_solvent) CALL section_vals_val_get(solvation_section, "BORN_KERNEL", i_val=ref_cli%solvation_born_kernel) CALL section_vals_val_get(solvation_section, "SOLUTION_STATE", i_val=ref_cli%solvation_state) - IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) & + IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) THEN CPABORT("REFERENCE_CLI implicit solvation needs SOLVENT") + END IF IF (ref_cli%solvation_model == tblite_cli_solvation_cpcm .AND. & - ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) & + ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) THEN CPABORT("BORN_KERNEL is invalid with MODEL CPCM") + END IF IF (ref_cli%solvation_state /= tblite_cli_solution_state_gsolv) THEN SELECT CASE (ref_cli%solvation_model) CASE (tblite_cli_solvation_alpb, tblite_cli_solvation_gbsa) @@ -2007,18 +2034,21 @@ CONTAINS END IF CALL section_vals_val_get(ref_cli_section, "ELECTRONIC_TEMPERATURE_GUESS", & r_val=ref_cli%electronic_temperature_guess) - IF (ref_cli%electronic_temperature_guess < 0.0_dp) & + IF (ref_cli%electronic_temperature_guess < 0.0_dp) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") - IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) & + END IF + IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS requires GUESS CEH") + END IF guess_section => section_vals_get_subs_vals(ref_cli_section, "GUESS_CLI") CALL section_vals_get(guess_section, explicit=ref_cli%guess_cli%enabled) IF (ref_cli%guess_cli%enabled) THEN CALL section_vals_val_get(guess_section, "METHOD", i_val=ref_cli%guess_cli%method) CALL section_vals_val_get(guess_section, "ELECTRONIC_TEMPERATURE_GUESS", & r_val=ref_cli%guess_cli%electronic_temperature_guess) - IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) & + IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) THEN CPABORT("REFERENCE_CLI/GUESS_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") + END IF CALL section_vals_val_get(guess_section, "SOLVER", i_val=ref_cli%guess_cli%solver) CALL section_vals_val_get(guess_section, "EFIELD", explicit=ref_cli%guess_cli%efield_active) IF (ref_cli%guess_cli%efield_active) THEN @@ -2049,10 +2079,12 @@ CONTAINS CALL section_vals_val_get(fit_section, "INPUT_FILE", c_val=ref_cli%fit_cli%input_file) CALL section_vals_val_get(fit_section, "DRY_RUN", l_val=ref_cli%fit_cli%dry_run) CALL section_vals_val_get(fit_section, "COPY", c_val=ref_cli%fit_cli%copy_file) - IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) & + IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs PARAM_FILE") - IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) & + END IF + IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs INPUT_FILE") + END IF END IF tagdiff_section => section_vals_get_subs_vals(ref_cli_section, "TAGDIFF_CLI") CALL section_vals_get(tagdiff_section, explicit=ref_cli%tagdiff_cli%enabled) @@ -2060,10 +2092,12 @@ CONTAINS CALL section_vals_val_get(tagdiff_section, "ACTUAL", c_val=ref_cli%tagdiff_cli%actual_file) CALL section_vals_val_get(tagdiff_section, "REFERENCE", c_val=ref_cli%tagdiff_cli%reference_file) CALL section_vals_val_get(tagdiff_section, "FIT", l_val=ref_cli%tagdiff_cli%fit) - IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) & + IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs ACTUAL") - IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) & + END IF + IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs REFERENCE") + END IF END IF CALL section_vals_val_get(ref_cli_section, "KEEP_FILES", l_val=ref_cli%keep_files) CALL section_vals_val_get(ref_cli_section, "ERROR_LIMIT", r_val=ref_cli%error_limit) @@ -2174,8 +2208,9 @@ CONTAINS END IF END DO - IF (t_control%conv < 0) & + IF (t_control%conv < 0) THEN t_control%conv = ABS(t_control%conv) + END IF ! DIPOLE_MOMENTS subsection dipole_section => section_vals_get_subs_vals(t_section, "DIPOLE_MOMENTS") @@ -2217,9 +2252,10 @@ CONTAINS CALL section_vals_val_get(mgrid_section, "PROGRESSION_FACTOR", & r_val=t_control%mgrid_progression_factor, explicit=explicit) IF (explicit) THEN - IF (t_control%mgrid_progression_factor <= 1.0_dp) & + IF (t_control%mgrid_progression_factor <= 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "Progression factor should be greater then 1.0 to ensure multi-grid ordering") + END IF ELSE t_control%mgrid_progression_factor = qs_control%progression_factor END IF @@ -2253,8 +2289,9 @@ CONTAINS IF (.NOT. explicit) t_control%mgrid_skip_load_balance = qs_control%skip_load_balance_distributed IF (ASSOCIATED(t_control%mgrid_e_cutoff)) THEN - IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) & + IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) THEN CPABORT("Inconsistent values for number of multi-grids") + END IF ! sort multi-grids in descending order according to their cutoff values t_control%mgrid_e_cutoff = -t_control%mgrid_e_cutoff @@ -2269,8 +2306,9 @@ CONTAINS xc_section => section_vals_get_subs_vals(t_section, "XC") xc_func => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL") CALL section_vals_get(xc_func, explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL xc_functionals_expand(xc_func, xc_section) + END IF ! sTDA subsection stda_section => section_vals_get_subs_vals(t_section, "STDA") @@ -2490,8 +2528,7 @@ CONTAINS dft_control%period_efield%strength END IF - IF (SQRT(DOT_PRODUCT(dft_control%period_efield%polarisation, & - dft_control%period_efield%polarisation)) < EPSILON(0.0_dp)) THEN + IF (NORM2(dft_control%period_efield%polarisation) < EPSILON(0.0_dp)) THEN CPABORT("Invalid (too small) polarisation vector specified for PERIODIC_EFIELD") END IF END IF @@ -2900,8 +2937,9 @@ CONTAINS ELSE WRITE (UNIT=output_unit, FMT="(T2,A,T71,F10.1)") & "QS| Density cutoff [a.u.]:", qs_control%cutoff - IF (qs_control%commensurate_mgrids) & + IF (qs_control%commensurate_mgrids) THEN WRITE (UNIT=output_unit, FMT="(T2,A)") "QS| Using commensurate multigrids" + END IF WRITE (UNIT=output_unit, FMT="(T2,A,T71,F10.1)") & "QS| Multi grid cutoff [a.u.]: 1) grid level", qs_control%e_cutoff(1) WRITE (UNIT=output_unit, FMT="(T2,A,I3,A,T71,F10.1)") & @@ -3031,9 +3069,10 @@ CONTAINS IF (qs_control%ddapc_restraint) THEN DO i = 1, SIZE(qs_control%ddapc_restraint_control) ddapc_restraint_control => qs_control%ddapc_restraint_control(i) - IF (SIZE(qs_control%ddapc_restraint_control) > 1) & + IF (SIZE(qs_control%ddapc_restraint_control) > 1) THEN WRITE (UNIT=output_unit, FMT="(T2,A,T3,I8)") & - "QS| parameters for DDAPC restraint number", i + "QS| parameters for DDAPC restraint number", i + END IF WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & "QS| ddapc restraint target", ddapc_restraint_control%target WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & @@ -3104,8 +3143,9 @@ CONTAINS IF (PRESENT(ddapc_restraint_section)) THEN IF (ASSOCIATED(qs_control%ddapc_restraint_control)) THEN - IF (SIZE(qs_control%ddapc_restraint_control) >= 2) & + IF (SIZE(qs_control%ddapc_restraint_control) >= 2) THEN CPABORT("ET_COUPLING cannot be used in combination with a normal restraint") + END IF ELSE ddapc_section => ddapc_restraint_section ALLOCATE (qs_control%ddapc_restraint_control(1)) @@ -3144,8 +3184,9 @@ CONTAINS END DO IF (jj < 1) CPABORT("Need at least 1 atom to use ddapc constraints") ddapc_restraint_control%natoms = jj - IF (ASSOCIATED(ddapc_restraint_control%atoms)) & + IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN DEALLOCATE (ddapc_restraint_control%atoms) + END IF ALLOCATE (ddapc_restraint_control%atoms(ddapc_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -3157,8 +3198,9 @@ CONTAINS END DO END DO - IF (ASSOCIATED(ddapc_restraint_control%coeff)) & + IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN DEALLOCATE (ddapc_restraint_control%coeff) + END IF ALLOCATE (ddapc_restraint_control%coeff(ddapc_restraint_control%natoms)) ddapc_restraint_control%coeff = 1.0_dp @@ -3170,13 +3212,15 @@ CONTAINS i_rep_val=k, r_vals=rtmplist) DO j = 1, SIZE(rtmplist) jj = jj + 1 - IF (jj > ddapc_restraint_control%natoms) & + IF (jj > ddapc_restraint_control%natoms) THEN CPABORT("Need the same number of coeff as there are atoms ") + END IF ddapc_restraint_control%coeff(jj) = rtmplist(j) END DO END DO - IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) & + IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) THEN CPABORT("Need no or the same number of coeff as there are atoms.") + END IF END DO k = 0 DO i = 1, SIZE(qs_control%ddapc_restraint_control) @@ -3365,12 +3409,13 @@ CONTAINS proj_mo_section => section_vals_get_subs_vals(rtp_section, "PRINT%PROJECTION_MO") CALL section_vals_get(proj_mo_section, explicit=is_present) IF (is_present) THEN - IF (dft_control%rtp_control%linear_scaling) & + IF (dft_control%rtp_control%linear_scaling) THEN CALL cp_abort(__LOCATION__, & "You have defined a time dependent projection of mos, but "// & "only the density matrix is propagated (DENSITY_PROPAGATION "// & ".TRUE.). Please either use MO-based real time DFT or do not "// & "define any PRINT%PROJECTION_MO section") + END IF dft_control%rtp_control%is_proj_mo = .TRUE. ELSE dft_control%rtp_control%is_proj_mo = .FALSE. @@ -3455,8 +3500,9 @@ CONTAINS DO i = 1, n_elems DO j = 1, 2 IF (dft_control%rtp_control%print_pol_elements(i, j) > 3 .OR. & - dft_control%rtp_control%print_pol_elements(i, j) < 1) & + dft_control%rtp_control%print_pol_elements(i, j) < 1) THEN CPABORT("Polarisation tensor element not 1,2 or 3 in at least one index") + END IF END DO END DO END IF @@ -3579,8 +3625,9 @@ CONTAINS END DO dft_control%probe(i)%natoms = jj - IF (dft_control%probe(i)%natoms < 1) & + IF (dft_control%probe(i)%natoms < 1) THEN CPABORT("Need at least 1 atom to use hair probes formalism") + END IF ALLOCATE (dft_control%probe(i)%atom_ids(dft_control%probe(i)%natoms)) jj = 0 diff --git a/src/cp_dbcsr_cholesky.F b/src/cp_dbcsr_cholesky.F index 5ba00f221a..8fdcc256cc 100644 --- a/src/cp_dbcsr_cholesky.F +++ b/src/cp_dbcsr_cholesky.F @@ -214,8 +214,9 @@ CONTAINS CALL copy_dbcsr_to_fm(matrixb, fm_matrixb) !CALL copy_dbcsr_to_fm(matrixout, fm_matrixout) - IF (op /= "SOLVE" .AND. op /= "MULTIPLY") & + IF (op /= "SOLVE" .AND. op /= "MULTIPLY") THEN CPABORT("wrong argument op") + END IF IF (PRESENT(pos)) THEN SELECT CASE (pos) diff --git a/src/cp_dbcsr_operations.F b/src/cp_dbcsr_operations.F index 46f66297ec..bb6ba62a78 100644 --- a/src/cp_dbcsr_operations.F +++ b/src/cp_dbcsr_operations.F @@ -611,8 +611,9 @@ CONTAINS row_blk_size, col_blk_size_right_out) CALL copy_fm_to_dbcsr(fm_in, in) - IF (ncol /= k_out .OR. my_beta /= 0.0_dp) & + IF (ncol /= k_out .OR. my_beta /= 0.0_dp) THEN CALL copy_fm_to_dbcsr(fm_out, out) + END IF CALL timeset(routineN//'_core', timing_handle_mult) CALL dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out, & @@ -648,8 +649,9 @@ CONTAINS n1 = SIZE(sizes1) n2 = SIZE(sizes2) - IF (n1 /= n2) & + IF (n1 /= n2) THEN CPABORT("distributions must be equal!") + END IF sizes1(1:n1) = sizes2(1:n1) used = SUM(sizes1(1:n1)) ! If sizes1 does not cover everything, then we increase the @@ -723,8 +725,9 @@ CONTAINS NULLIFY (col_dist_left) IF (ncol > 0) THEN - IF (.NOT. dbcsr_valid_index(sparse_matrix)) & + IF (.NOT. dbcsr_valid_index(sparse_matrix)) THEN CPABORT("sparse_matrix must pre-exist") + END IF ! ! Setup matrix_v CALL cp_fm_get_info(matrix_v, ncol_global=k) @@ -830,25 +833,6 @@ CONTAINS WRITE (*, *) 'PRESENT (matrix_g)', PRESENT(matrix_g) WRITE (*, *) 'matrix_type=', dbcsr_get_matrix_type(sparse_matrix) WRITE (*, *) 'norm(sm+alpha*v*g^t - fm+alpha*v*g^t)/n=', norm/REAL(nao, dp) - IF (norm/REAL(nao, dp) > 1e-12_dp) THEN - !WRITE(*,*) 'fm_matrix' - !DO j=1,SIZE(fm_matrix%local_data,2) - ! DO i=1,SIZE(fm_matrix%local_data,1) - ! WRITE(*,'(A,I3,A,I3,A,E26.16,A)') 'a(',i,',',j,')=',fm_matrix%local_data(i,j),';' - ! ENDDO - !ENDDO - !WRITE(*,*) 'mat_v' - !CALL dbcsr_print(mat_v) - !WRITE(*,*) 'mat_g' - !CALL dbcsr_print(mat_g) - !WRITE(*,*) 'sparse_matrix' - !CALL dbcsr_print(sparse_matrix) - !WRITE(*,*) 'sparse_matrix2 (-sm + sparse(fm))' - !CALL dbcsr_print(sparse_matrix2) - !WRITE(*,*) 'sparse_matrix3 (copy of sm input)' - !CALL dbcsr_print(sparse_matrix3) - !stop - END IF CALL dbcsr_release(sparse_matrix2) CALL dbcsr_release(sparse_matrix3) CALL cp_fm_release(fm_matrix) @@ -1025,11 +1009,13 @@ CONTAINS estimated_blocks = max_blocks_per_bin*nbins ALLOCATE (blk_dist(estimated_blocks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_dist") + END IF ALLOCATE (blk_sizes(estimated_blocks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_sizes") + END IF element_stack = 0 nblks = 0 DO blk_layer = 1, max_blocks_per_bin @@ -1051,23 +1037,27 @@ CONTAINS block_size => blk_sizes ELSE ALLOCATE (block_distribution(nblks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_dist") + END IF block_distribution(:) = blk_dist(1:nblks) DEALLOCATE (blk_dist) ALLOCATE (block_size(nblks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_sizes") + END IF block_size(:) = blk_sizes(1:nblks) DEALLOCATE (blk_sizes) END IF ELSE ALLOCATE (block_distribution(0), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_dist") + END IF ALLOCATE (block_size(0), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_sizes") + END IF END IF 1579 FORMAT(I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5) IF (debug_mod) THEN diff --git a/src/cp_ddapc_forces.F b/src/cp_ddapc_forces.F index 979571da7f..7c30a8d718 100644 --- a/src/cp_ddapc_forces.F +++ b/src/cp_ddapc_forces.F @@ -217,7 +217,7 @@ CONTAINS END IF IF (iparticle1 /= iparticle2) THEN ra = rvec - r = SQRT(DOT_PRODUCT(ra, ra)) + r = NORM2(ra) t2 = -1.0_dp/(r*r)*factor drvec = ra/r*q1t*q2t d_el(1:3, iparticle1) = d_el(1:3, iparticle1) + t2*drvec diff --git a/src/cp_ddapc_methods.F b/src/cp_ddapc_methods.F index 5265a249ed..c8630ca686 100644 --- a/src/cp_ddapc_methods.F +++ b/src/cp_ddapc_methods.F @@ -204,7 +204,7 @@ CONTAINS iparticle2, istart_g, s_dim REAL(KIND=dp) :: g2, gcut2, tmp REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: my_Am, my_Amw - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq(:, :, :) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq !NB precalculate as many things outside of the innermost loop as possible, in particular w(ig)*gfunc(ig,igauus1)*gfunc(ig,igauss2) @@ -766,7 +766,7 @@ CONTAINS ! IF (iparticle1 /= iparticle2) THEN ra = rvec - r = SQRT(DOT_PRODUCT(ra, ra)) + r = NORM2(ra) my_val = factor/r END IF EwM(idim) = my_val - factor*g_ewald diff --git a/src/cp_ddapc_util.F b/src/cp_ddapc_util.F index 7fe0888cdc..d9ff69876d 100644 --- a/src/cp_ddapc_util.F +++ b/src/cp_ddapc_util.F @@ -355,7 +355,8 @@ CONTAINS bv(:) = 0.0_dp cv(:) = 1.0_dp/Vol CALL build_b_vector(bv, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut); bv(:) = bv(:)/Vol + particle_set, radii, rho_tot_g, gcut) + bv(:) = bv(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv) c1 = DOT_PRODUCT(cv, MATMUL(cp_ddapc_env%AmI, bv)) - ch_dens c1 = c1/cp_ddapc_env%c0 @@ -718,11 +719,13 @@ CONTAINS bv2(:) = 0.0_dp particle_set(iparticle)%r(i) = rvec(i) + dx CALL build_b_vector(bv1, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut); bv1(:) = bv1(:)/Vol + particle_set, radii, rho_tot_g, gcut) + bv1(:) = bv1(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv1) particle_set(iparticle)%r(i) = rvec(i) - dx CALL build_b_vector(bv2, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut); bv2(:) = bv2(:)/Vol + particle_set, radii, rho_tot_g, gcut) + bv2(:) = bv2(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv2) ddbv(:) = (bv1(:) - bv2(:))/(2.0_dp*dx) DO kk = 1, SIZE(ddbv) diff --git a/src/cp_eri_mme_interface.F b/src/cp_eri_mme_interface.F index b94212c6d3..d7e45fb6dc 100644 --- a/src/cp_eri_mme_interface.F +++ b/src/cp_eri_mme_interface.F @@ -563,8 +563,9 @@ CONTAINS WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Cutoff error:", param%par%err_c WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Total error (minimax + cutoff):", param%par%err_mm + param%par%err_c END IF - IF (param%par%print_calib) & + IF (param%par%print_calib) THEN WRITE (unit_nr, '(T2, A, T68, F13.10)') "ERI_MME| Minimax scaling constant in AM-GM estimate:", param%par%C_mm + END IF END IF END IF @@ -786,8 +787,9 @@ CONTAINS CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL", i_val=potential) CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL_PARAM", r_val=pot_par) - IF (nzet <= 0) & + IF (nzet <= 0) THEN CPABORT("Number of exponents NZET must be greater than 0.") + END IF CALL init_orbital_pointers(l_max) diff --git a/src/cp_external_control.F b/src/cp_external_control.F index 4b32395cde..3ae0189fef 100644 --- a/src/cp_external_control.F +++ b/src/cp_external_control.F @@ -63,8 +63,9 @@ CONTAINS external_comm = comm external_master_id = in_external_master_id - IF (PRESENT(in_scf_energy_message_tag)) & + IF (PRESENT(in_scf_energy_message_tag)) THEN scf_energy_message_tag = in_scf_energy_message_tag + END IF IF (PRESENT(in_exit_tag)) THEN ! the exit tag should be different from the mpi_probe tag default CPASSERT(in_exit_tag /= -1) @@ -203,7 +204,7 @@ CONTAINS IF (PRESENT(target_time)) THEN my_target_time = target_time my_start_time = start_time - ELSEIF (PRESENT(globenv)) THEN + ELSE IF (PRESENT(globenv)) THEN my_target_time = globenv%cp2k_target_time my_start_time = globenv%cp2k_start_time ELSE diff --git a/src/cp_subsys_methods.F b/src/cp_subsys_methods.F index e85b894a4c..73ce1a9e0a 100644 --- a/src/cp_subsys_methods.F +++ b/src/cp_subsys_methods.F @@ -128,16 +128,19 @@ CONTAINS subsys%para_env => para_env my_use_motion_section = .FALSE. - IF (PRESENT(use_motion_section)) & + IF (PRESENT(use_motion_section)) THEN my_use_motion_section = use_motion_section + END IF my_force_env_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL") - IF (PRESENT(force_env_section)) & + IF (PRESENT(force_env_section)) THEN my_force_env_section => force_env_section + END IF my_subsys_section => section_vals_get_subs_vals(my_force_env_section, "SUBSYS") - IF (PRESENT(subsys_section)) & + IF (PRESENT(subsys_section)) THEN my_subsys_section => subsys_section + END IF CALL section_vals_val_get(my_subsys_section, "SEED", i_vals=seed_vals) IF (SIZE(seed_vals) == 1) THEN @@ -288,8 +291,9 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(small_subsys)) CPASSERT(ASSOCIATED(big_subsys)) - IF (big_subsys%para_env /= small_para_env) & + IF (big_subsys%para_env /= small_para_env) THEN CPABORT("big_subsys%para_env==small_para_env") + END IF !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- diff --git a/src/cryssym.F b/src/cryssym.F index 4c28f5b550..5f8c7e52e5 100644 --- a/src/cryssym.F +++ b/src/cryssym.F @@ -1755,7 +1755,7 @@ CONTAINS csym%kplink(1, j) = i wkp(i) = wkp(i) + 1.0_dp kpop(j) = kr - ELSEIF (csym%kplink(1, j) /= i) THEN + ELSE IF (csym%kplink(1, j) /= i) THEN ! Approximate K290 operation sets need not be closed for structures whose ! coordinates lie close to several symmetry tolerances. Keep the existing ! disjoint orbit instead of aborting or double-counting this mesh point. diff --git a/src/csvr_system_types.F b/src/csvr_system_types.F index e4e349bce2..4095fc67c4 100644 --- a/src/csvr_system_types.F +++ b/src/csvr_system_types.F @@ -148,8 +148,9 @@ CONTAINS SUBROUTINE csvr_thermo_dealloc(nvt) TYPE(csvr_thermo_type), DIMENSION(:), POINTER :: nvt - IF (ASSOCIATED(nvt)) & + IF (ASSOCIATED(nvt)) THEN DEALLOCATE (nvt) + END IF END SUBROUTINE csvr_thermo_dealloc END MODULE csvr_system_types diff --git a/src/ct_methods.F b/src/ct_methods.F index 2aa855445a..22bc2f77a4 100644 --- a/src/ct_methods.F +++ b/src/ct_methods.F @@ -39,6 +39,7 @@ MODULE ct_methods USE iterate_matrix, ONLY: matrix_sqrt_Newton_Schulz USE kinds, ONLY: dp USE machine, ONLY: m_walltime + USE mathconstants, ONLY: pi #include "./base/base_uses.f90" IMPLICIT NONE @@ -1378,14 +1379,12 @@ CONTAINS INTEGER, INTENT(OUT) :: nmins INTEGER :: i, nroots - REAL(KIND=dp) :: DD, der, p, phi, pi, q, temp1, temp2, u, & - v, y1, y2, y2i, y2r, y3 + REAL(KIND=dp) :: DD, der, p, phi, q, temp1, temp2, u, v, & + y1, y2, y2i, y2r, y3 REAL(KIND=dp), DIMENSION(3) :: x ! CALL timeset(routineN,handle) - pi = ACOS(-1.0_dp) - ! Step 0: Check coefficients and find the true order of the eq IF (a == 0.0_dp) THEN IF (b == 0.0_dp) THEN @@ -1520,8 +1519,9 @@ CONTAINS ! create a matrix for eigenvectors CALL dbcsr_work_create(c, work_mutable=.TRUE.) - IF (do_eigenvalues) & + IF (do_eigenvalues) THEN CALL dbcsr_work_create(e, work_mutable=.TRUE.) + END IF CALL dbcsr_iterator_readonly_start(iter, matrix) diff --git a/src/ct_types.F b/src/ct_types.F index 2d93d0acc8..120685b60b 100644 --- a/src/ct_types.F +++ b/src/ct_types.F @@ -66,31 +66,6 @@ MODULE ct_types REAL(KIND=dp) :: energy_correction = 0.0_dp -!SPIN!!! ! metric matrices for covariant to contravariant transformations -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_up=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_down=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_up=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_down=>NULL() -!SPIN!!! -!SPIN!!! ! kohn-sham, covariant-covariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_ks=>NULL() -!SPIN!!! ! density, contravariant-contravariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_p=>NULL() -!SPIN!!! ! occ orbitals, contravariant-covariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_t=>NULL() -!SPIN!!! ! virt orbitals, contravariant-covariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_v=>NULL() -!SPIN!!! -!SPIN!!! ! to avoid building Occ-by-N and Virt-vy-N matrices inside -!SPIN!!! ! the ct routines get them from the external code -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_qp_template=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_pq_template=>NULL() -!SPIN!!! -!SPIN!!! ! single excitation amplitudes -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_x -!SPIN!!! ! residuals -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_res - ! metric matrices for covariant to contravariant transformations TYPE(dbcsr_type), POINTER :: p_index_up => NULL() TYPE(dbcsr_type), POINTER :: p_index_down => NULL() @@ -154,7 +129,6 @@ CONTAINS env%order_lanczos = 3 env%eps_lancsoz = 1.0E-4_dp env%max_iter_lanczos = 40 - !env%nspins = -1 env%converged = .FALSE. env%conjugator = cg_polak_ribiere @@ -231,22 +205,6 @@ CONTAINS qq_preconditioner_full, & pp_preconditioner_full -!INTEGER , OPTIONAL :: nspins -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_up -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_down -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_up -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_down -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_ks -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_p -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_t -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_v -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_qp_template -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_pq_template -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_x -!SPIN!!! -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), OPTIONAL :: copy_matrix_x -!INTEGER :: ispin - IF (PRESENT(use_occ_orbs)) use_occ_orbs = env%use_occ_orbs IF (PRESENT(use_virt_orbs)) use_virt_orbs = env%use_virt_orbs IF (PRESENT(occ_orbs_orthogonal)) occ_orbs_orthogonal = & @@ -267,7 +225,6 @@ CONTAINS IF (PRESENT(eps_convergence)) eps_convergence = env%eps_convergence IF (PRESENT(eps_filter)) eps_filter = env%eps_filter IF (PRESENT(max_iter)) max_iter = env%max_iter - !IF (PRESENT(nspins)) nspins = env%nspins IF (PRESENT(matrix_ks)) matrix_ks => env%matrix_ks IF (PRESENT(matrix_p)) matrix_p => env%matrix_p IF (PRESENT(matrix_t)) matrix_t => env%matrix_t @@ -281,12 +238,8 @@ CONTAINS IF (PRESENT(p_index_down)) p_index_down => env%p_index_down IF (PRESENT(q_index_down)) q_index_down => env%q_index_down IF (PRESENT(copy_matrix_x)) THEN - !DO ispin=1,env%nspins - !CALL dbcsr_copy(copy_matrix_x(ispin),env%matrix_x(ispin)) CALL dbcsr_copy(copy_matrix_x, env%matrix_x) - !ENDDO END IF - !IF (PRESENT(matrix_x)) matrix_x => env%matrix_x IF (PRESENT(energy_correction)) energy_correction = env%energy_correction IF (PRESENT(converged)) converged = env%converged @@ -352,20 +305,6 @@ CONTAINS LOGICAL, OPTIONAL :: qq_preconditioner_full, & pp_preconditioner_full -!INTEGER , OPTIONAL :: nspins -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_up -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_down -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_up -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_down -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_ks -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_p -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_t -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_v -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_qp_template -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_pq_template -! set para_env and blacs_env which are needed to operate with full matrices -! it would be nice to have everything with cp_dbcsr matrices, well maybe later - env%para_env => para_env env%blacs_env => blacs_env @@ -389,7 +328,6 @@ CONTAINS IF (PRESENT(eps_convergence)) env%eps_convergence = eps_convergence IF (PRESENT(eps_filter)) env%eps_filter = eps_filter IF (PRESENT(max_iter)) env%max_iter = max_iter - !IF (PRESENT(nspins)) env%nspins = nspins IF (PRESENT(conjugator)) env%conjugator = conjugator IF (PRESENT(matrix_ks)) env%matrix_ks => matrix_ks IF (PRESENT(matrix_p)) env%matrix_p => matrix_p @@ -415,18 +353,12 @@ CONTAINS TYPE(ct_step_env_type) :: env -!INTEGER :: ispin - NULLIFY (env%para_env) NULLIFY (env%blacs_env) !DO ispin=1,env%nspins CALL dbcsr_release(env%matrix_x) CALL dbcsr_release(env%matrix_res) - !CALL dbcsr_release(env%matrix_x(ispin)) - !CALL dbcsr_release(env%matrix_res(ispin)) - !ENDDO - !DEALLOCATE(env%matrix_x,env%matrix_res) NULLIFY (env%p_index_up) NULLIFY (env%p_index_down) diff --git a/src/dbm/dbm_api.F b/src/dbm/dbm_api.F index 7cb521797f..af1f6bc705 100644 --- a/src/dbm/dbm_api.F +++ b/src/dbm/dbm_api.F @@ -182,8 +182,9 @@ CONTAINS num_blocks_diff = ABS(num_blocks - num_blocks_dbcsr) IF (num_blocks_diff /= 0) THEN WRITE (*, *) "num_blocks mismatch dbcsr:", num_blocks_dbcsr, "new:", num_blocks - IF (DBM_VALIDATE_NBLOCKS_MATCH) & + IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN CPABORT("num_blocks mismatch") + END IF END IF IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN diff --git a/src/dbm/dbm_tests.F b/src/dbm/dbm_tests.F index ed7e5efcd3..ee10d2ee4d 100644 --- a/src/dbm/dbm_tests.F +++ b/src/dbm/dbm_tests.F @@ -439,7 +439,7 @@ CONTAINS INTEGER(KIND=int_8) :: map map = ((irow - 1 + icol*INT(nrow, int_8))*(1 + MODULO(ival, 2**16)))*2 + 1 + 0*ncol ! ncol used - iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12; ! keep odd + iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12 ! keep odd iseed(3) = INT(MODULO(IEOR(map, 3541_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(2) = INT(MODULO(IEOR(map, 1153_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(1) = INT(MODULO(IEOR(map, 2029_int_8), 2_int_8**12)); map = map/2_int_8**12 diff --git a/src/dbt/dbt_allocate_wrap.F b/src/dbt/dbt_allocate_wrap.F index a4e10a477b..19e02c8664 100644 --- a/src/dbt/dbt_allocate_wrap.F +++ b/src/dbt/dbt_allocate_wrap.F @@ -56,7 +56,7 @@ CONTAINS ELSE shape_prv = shape_spec END IF - ELSEIF (PRESENT(source)) THEN + ELSE IF (PRESENT(source)) THEN IF (PRESENT(order)) THEN shape_prv(order) = SHAPE(source) ELSE diff --git a/src/dbt/dbt_array_list_methods.F b/src/dbt/dbt_array_list_methods.F index e607940865..8b24135672 100644 --- a/src/dbt/dbt_array_list_methods.F +++ b/src/dbt/dbt_array_list_methods.F @@ -51,7 +51,7 @@ MODULE dbt_array_list_methods TYPE array_list INTEGER, DIMENSION(:), ALLOCATABLE :: col_data INTEGER, DIMENSION(:), ALLOCATABLE :: ptr - END TYPE + END TYPE array_list INTERFACE get_ith_array MODULE PROCEDURE allocate_and_get_ith_array @@ -128,7 +128,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE + END SUBROUTINE create_array_list ! ************************************************************************************************** !> \brief extract a subset of arrays @@ -151,7 +151,7 @@ CONTAINS CALL create_array_list(array_sublist, ndata, ${varlist("data", nmax=dim)}$) END IF #:endfor - END FUNCTION + END FUNCTION array_sublist ! ************************************************************************************************** !> \brief destroy array list. @@ -161,7 +161,7 @@ CONTAINS TYPE(array_list), INTENT(INOUT) :: list DEALLOCATE (list%ptr, list%col_data) - END SUBROUTINE + END SUBROUTINE destroy_array_list ! ************************************************************************************************** !> \brief Get all arrays contained in list @@ -185,7 +185,7 @@ CONTAINS o(1:ndata) = i_selected(:) ELSE ndata = number_of_arrays(list) - o(1:ndata) = (/(i, i=1, ndata)/) + o(1:ndata) = [(i, i=1, ndata)] END IF ASSOCIATE (ptr => list%ptr, col_data => list%col_data) @@ -215,7 +215,7 @@ CONTAINS END ASSOCIATE - END SUBROUTINE + END SUBROUTINE get_ith_array ! ************************************************************************************************** !> \brief get ith array @@ -231,7 +231,7 @@ CONTAINS ALLOCATE (array, source=col_data(ptr(i):ptr(i + 1) - 1)) END ASSOCIATE - END SUBROUTINE + END SUBROUTINE allocate_and_get_ith_array ! ************************************************************************************************** !> \brief sizes of arrays stored in list @@ -288,7 +288,7 @@ CONTAINS partial_sum = partial_sum + list_in%col_data(i_ptr) END DO END DO - END SUBROUTINE + END SUBROUTINE array_offsets ! ************************************************************************************************** !> \brief reorder array list. @@ -309,7 +309,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE + END SUBROUTINE reorder_arrays ! ************************************************************************************************** !> \brief check whether two array lists are equal @@ -320,7 +320,7 @@ CONTAINS LOGICAL :: check_equal check_equal = array_eq_i(list1%col_data, list2%col_data) .AND. array_eq_i(list1%ptr, list2%ptr) - END FUNCTION + END FUNCTION check_equal ! ************************************************************************************************** !> \brief check whether two arrays are equal @@ -337,6 +337,6 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION + END FUNCTION array_eq_i END MODULE dbt_array_list_methods diff --git a/src/dbt/dbt_methods.F b/src/dbt/dbt_methods.F index 1acfd36763..13cc921049 100644 --- a/src/dbt/dbt_methods.F +++ b/src/dbt/dbt_methods.F @@ -231,7 +231,7 @@ CONTAINS IF (.NOT. PRESENT(order)) THEN IF (array_eq_i(map1_in_1, map2_in_1) .AND. array_eq_i(map1_in_2, map2_in_2)) THEN dist_compatible_tas = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) - ELSEIF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN + ELSE IF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN dist_compatible_tensor = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) END IF END IF @@ -239,7 +239,7 @@ CONTAINS IF (dist_compatible_tas) THEN CALL dbt_tas_copy(out_tmp_1%matrix_rep, in_tmp_3%matrix_rep, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) - ELSEIF (dist_compatible_tensor) THEN + ELSE IF (dist_compatible_tensor) THEN CALL dbt_copy_nocomm(in_tmp_3, out_tmp_1, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) ELSE @@ -1274,7 +1274,7 @@ CONTAINS ALLOCATE (tensor2_out) CALL dbt_remap(tensor2, ind2_linked, ind2_free, tensor2_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata2, move_data=move_data_2) - ELSEIF (compat1 == 2) THEN ! linked index is second 2d dimension + ELSE IF (compat1 == 2) THEN ! linked index is second 2d dimension ! get distribution of linked index, tensor 2 must adopt this distribution ! get grid dimensions of linked index ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) @@ -1315,7 +1315,7 @@ CONTAINS ALLOCATE (tensor1_out) CALL dbt_remap(tensor1, ind1_linked, ind1_free, tensor1_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata1, move_data=move_data_1) - ELSEIF (compat2 == 2) THEN + ELSE IF (compat2 == 2) THEN ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) CALL dbt_get_mapping_info(dist_in%pgrid%nd_index_grid, dims2_2d=mp_dims) ALLOCATE (tensor1_out) @@ -1419,7 +1419,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_in%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN + ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1442,7 +1442,7 @@ CONTAINS IF (compat1 == 1 .AND. compat2 == 2) THEN trans = .FALSE. - ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN + ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN trans = .TRUE. ELSE CPABORT("this should not happen") @@ -1453,7 +1453,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_out%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN + ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1526,7 +1526,7 @@ CONTAINS compat_map = 0 IF (array_eq_i(map1, compat_ind)) THEN compat_map = 1 - ELSEIF (array_eq_i(map2, compat_ind)) THEN + ELSE IF (array_eq_i(map2, compat_ind)) THEN compat_map = 2 END IF diff --git a/src/dbt/dbt_split.F b/src/dbt/dbt_split.F index 20cd9d4d81..e3ac768476 100644 --- a/src/dbt/dbt_split.F +++ b/src/dbt/dbt_split.F @@ -272,7 +272,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE dbt_split_blocks_generic ! ************************************************************************************************** !> \brief Split tensor blocks into smaller blocks of maximum size PRODUCT(block_sizes). @@ -331,7 +331,7 @@ CONTAINS nodata=nodata) #:endfor - END SUBROUTINE + END SUBROUTINE dbt_split_blocks ! ************************************************************************************************** !> \brief Copy tensor with split blocks to tensor with original block sizes. @@ -480,7 +480,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE dbt_split_copyback ! ************************************************************************************************** !> \brief split two tensors with same total sizes but different block sizes such that they have @@ -503,7 +503,8 @@ CONTAINS INTEGER, DIMENSION(ndims_tensor(tensor1)), & INTENT(IN), OPTIONAL :: order LOGICAL, INTENT(IN), OPTIONAL :: nodata1, nodata2, move_data - INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, ${varlist("blk_size_split_2")}$, & + INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, & + ${varlist("blk_size_split_2")}$, & blk_size_d_1, blk_size_d_2, blk_size_d_split INTEGER :: size_sum_1, size_sum_2, size_sum, bind_1, bind_2, isplit, bs, idim, i LOGICAL :: move_prv, nodata1_prv, nodata2_prv @@ -551,7 +552,7 @@ CONTAINS size_sum = size_sum + bs isplit = isplit + 1 blk_size_d_split(isplit) = bs - ELSEIF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN + ELSE IF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN bind_2 = bind_2 + 1 bs = blk_size_d_2(bind_2) blk_size_d_1(bind_1 + 1) = blk_size_d_1(bind_1 + 1) - bs @@ -608,7 +609,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE + END SUBROUTINE dbt_make_compatible_blocks ! ************************************************************************************************** !> \author Patrick Seewald @@ -698,6 +699,6 @@ CONTAINS CALL dbt_copy_contraction_storage(tensor_in, tensor_out) CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE dbt_crop - END MODULE + END MODULE dbt_split diff --git a/src/dbt/dbt_types.F b/src/dbt/dbt_types.F index a7aa6929ad..1a7d1b14ba 100644 --- a/src/dbt/dbt_types.F +++ b/src/dbt/dbt_types.F @@ -211,7 +211,7 @@ CONTAINS CALL dbt_get_mapping_info(map_grid, & dims_2d=grid_dims, & dims1_2d=new_dbt_tas_dist_t%dims_grid) - ELSEIF (which_dim == 2) THEN + ELSE IF (which_dim == 2) THEN ALLOCATE (new_dbt_tas_dist_t%dims(ndims_mapping_column(map_blks))) ALLOCATE (index_map(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -335,7 +335,7 @@ CONTAINS dims_2d_i8=matrix_dims, & map1_2d=index_map, & dims1_2d=new_dbt_tas_blk_size_t%dims) - ELSEIF (which_dim == 2) THEN + ELSE IF (which_dim == 2) THEN ALLOCATE (index_map(ndims_mapping_column(map_blks))) ALLOCATE (new_dbt_tas_blk_size_t%dims(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -455,7 +455,7 @@ CONTAINS IF (idim /= SIZE(tensor_dims_sorted)) THEN dims(idim + 1:) = 0 CALL mp_dims_create(pdims_rem, dims(idim + 1:)) - ELSEIF (lb_ratio_prv < 0.5_dp) THEN + ELSE IF (lb_ratio_prv < 0.5_dp) THEN ! resort to a less strict load imbalance factor dims(:) = dims_store CALL dbt_mp_dims_create(nodes, dims, tensor_dims, 0.5_dp) @@ -836,7 +836,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(dist%refcount)) THEN abort = .TRUE. - ELSEIF (dist%refcount < 1) THEN + ELSE IF (dist%refcount < 1) THEN abort = .TRUE. END IF @@ -1264,7 +1264,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(tensor%refcount)) THEN abort = .TRUE. - ELSEIF (tensor%refcount < 1) THEN + ELSE IF (tensor%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_mm.F b/src/dbt/tas/dbt_tas_mm.F index 12d8654603..1050765b34 100644 --- a/src/dbt/tas/dbt_tas_mm.F +++ b/src/dbt/tas/dbt_tas_mm.F @@ -276,7 +276,7 @@ CONTAINS WRITE (unit_nr_prv, "(T4,A,T68,I13)") "Est. optimal split factor:", nsplit END IF - ELSEIF (batched_repl > 0) THEN + ELSE IF (batched_repl > 0) THEN nsplit = nsplit_batched nsplit_opt = nsplit max_mm_dim = max_mm_dim_batched @@ -342,7 +342,7 @@ CONTAINS IF (matrix_c%do_batched == 1) THEN matrix_c%mm_storage%batched_beta = beta - ELSEIF (matrix_c%do_batched > 1) THEN + ELSE IF (matrix_c%do_batched > 1) THEN matrix_c%mm_storage%batched_beta = matrix_c%mm_storage%batched_beta*beta END IF @@ -355,7 +355,7 @@ CONTAINS IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rs%matrix) IF (matrix_c%do_batched >= 1) matrix_c%mm_storage%store_batched => matrix_c_rs - ELSEIF (matrix_c%do_batched == 3) THEN + ELSE IF (matrix_c%do_batched == 3) THEN matrix_c_rs => matrix_c%mm_storage%store_batched END IF @@ -446,7 +446,7 @@ CONTAINS matrix_b%mm_storage%store_batched_repl => matrix_b_rep CALL dbt_tas_set_batched_state(matrix_b, state=3) END IF - ELSEIF (matrix_b%do_batched == 3) THEN + ELSE IF (matrix_b%do_batched == 3) THEN matrix_b_rep => matrix_b%mm_storage%store_batched_repl END IF @@ -532,14 +532,14 @@ CONTAINS matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) END IF - ELSEIF (matrix_c%do_batched == 2) THEN + ELSE IF (matrix_c%do_batched == 2) THEN ALLOCATE (matrix_c_rep) CALL dbt_tas_replicate(matrix_c_rs%matrix, dbt_tas_info(matrix_a_rs), matrix_c_rep, nodata=nodata_3) ! just leave sparsity structure for retain sparsity but no values IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rep%matrix) matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) - ELSEIF (matrix_c%do_batched == 3) THEN + ELSE IF (matrix_c%do_batched == 3) THEN matrix_c_rep => matrix_c%mm_storage%store_batched_repl END IF @@ -625,7 +625,7 @@ CONTAINS matrix_a%mm_storage%store_batched_repl => matrix_a_rep CALL dbt_tas_set_batched_state(matrix_a, state=3) END IF - ELSEIF (matrix_a%do_batched == 3) THEN + ELSE IF (matrix_a%do_batched == 3) THEN matrix_a_rep => matrix_a%mm_storage%store_batched_repl END IF @@ -740,7 +740,7 @@ CONTAINS CALL dbt_tas_destroy(matrix_c_rs) DEALLOCATE (matrix_c_rs) IF (PRESENT(filter_eps)) CALL dbt_tas_filter(matrix_c, filter_eps) - ELSEIF (matrix_c%do_batched > 0) THEN + ELSE IF (matrix_c%do_batched > 0) THEN IF (matrix_c%mm_storage%batched_out) THEN matrix_c%mm_storage%batched_trans = (transc_prv .NEQV. transc) END IF diff --git a/src/dbt/tas/dbt_tas_split.F b/src/dbt/tas/dbt_tas_split.F index aa7522631e..c9e7d8fb28 100644 --- a/src/dbt/tas/dbt_tas_split.F +++ b/src/dbt/tas/dbt_tas_split.F @@ -266,7 +266,7 @@ CONTAINS nsplit_list_square(count_square) = split count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split - ELSEIF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN + ELSE IF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split END IF @@ -277,10 +277,10 @@ CONTAINS IF (count_square > 0) THEN minpos = MINLOC(ABS(nsplit_list_square(1:count_square) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_square(minpos) - ELSEIF (count_accept > 0) THEN + ELSE IF (count_accept > 0) THEN minpos = MINLOC(ABS(nsplit_list_accept(1:count_accept) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_accept(minpos) - ELSEIF (count > 0) THEN + ELSE IF (count > 0) THEN minpos = MINLOC(ABS(nsplit_list(1:count) - nsplit), DIM=1) get_opt_nsplit = nsplit_list(minpos) ELSE @@ -462,7 +462,7 @@ CONTAINS IF (.NOT. ASSOCIATED(split_info%refcount)) THEN abort = .TRUE. - ELSEIF (split_info%refcount < 1) THEN + ELSE IF (split_info%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_util.F b/src/dbt/tas/dbt_tas_util.F index 0f8d27acd9..60f323a9d1 100644 --- a/src/dbt/tas/dbt_tas_util.F +++ b/src/dbt/tas/dbt_tas_util.F @@ -53,7 +53,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE + END SUBROUTINE swap_i8 ! ************************************************************************************************** !> \brief ... @@ -68,7 +68,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE + END SUBROUTINE swap_i ! ************************************************************************************************** !> \brief ... @@ -87,7 +87,7 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION + END FUNCTION array_eq_i ! ************************************************************************************************** !> \brief ... @@ -106,6 +106,6 @@ CONTAINS array_eq_i8 = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i8 = ALL(arr1 == arr2) #endif - END FUNCTION + END FUNCTION array_eq_i8 END MODULE diff --git a/src/dbx/cp_dbcsr_api.F b/src/dbx/cp_dbcsr_api.F index cdd57dca4e..bd02f16ab1 100644 --- a/src/dbx/cp_dbcsr_api.F +++ b/src/dbx/cp_dbcsr_api.F @@ -235,10 +235,11 @@ CONTAINS TYPE(dbcsr_type), POINTER :: matrix CALL dbcsr_release(matrix) - IF (dbcsr_valid_index(matrix)) & + IF (dbcsr_valid_index(matrix)) THEN CALL cp_abort(__LOCATION__, & 'You should not "deallocate" a referenced matrix. '// & 'Avoid pointers to DBCSR matrices.') + END IF DEALLOCATE (matrix) END SUBROUTINE dbcsr_deallocate_matrix diff --git a/src/debug_os_integrals.F b/src/debug_os_integrals.F index 49887cda40..19c1160f8f 100644 --- a/src/debug_os_integrals.F +++ b/src/debug_os_integrals.F @@ -75,7 +75,7 @@ CONTAINS ALLOCATE (swork(lds, lds, 1)) sab = 0._dp rab(:) = B(:) - A(:) - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) xa_work(1) = xa xb_work(1) = xb rpgfa = 20._dp @@ -219,11 +219,11 @@ CONTAINS !--------------------------------------- rab(:) = B(:) - A(:) - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) rac(:) = C(:) - A(:) - dac = SQRT(DOT_PRODUCT(rac, rac)) + dac = NORM2(rac) rbc(:) = C(:) - B(:) - dbc = SQRT(DOT_PRODUCT(rbc, rbc)) + dbc = NORM2(rbc) ALLOCATE (sabc(ncoset(la_max), ncoset(lb_max), ncoset(lc_max))) xa_work(1) = xa xb_work(1) = xb @@ -422,7 +422,7 @@ CONTAINS ALLOCATE (swork(lds, lds)) saabb = 0._dp rab(:) = B(:) - A(:) - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) xa_work1(1) = xa1 xa_work2(1) = xa2 xb_work1(1) = xb1 diff --git a/src/dft_plus_u.F b/src/dft_plus_u.F index de3bec26f0..0337c70cd1 100644 --- a/src/dft_plus_u.F +++ b/src/dft_plus_u.F @@ -189,7 +189,7 @@ CONTAINS !> \date 02.07.2008 !> \par !> \f{eqnarray*}{ -!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U}\\\ +!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U} !> & = & E^{\rm DFT} + \frac{1}{2}(U - J)\sum_\mu (q_\mu - q_\mu^2)\\[1ex] !> V_{\mu\nu}^{\rm DFT+U} & = & V_{\mu\nu}^{\rm DFT} + V_{\mu\nu}^{\rm U}\\\ !> & = & \frac{\partial E^{\rm DFT}} @@ -766,10 +766,11 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) & + IF (energy%dft_plus_u < 0.0_dp) THEN CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Lowdin charges!") + END IF ! Release (local) full matrices NULLIFY (fm_s_half) @@ -1991,10 +1992,11 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) & + IF (energy%dft_plus_u < 0.0_dp) THEN CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Mulliken charges!") + END IF ! Release local work storage diff --git a/src/distribution_2d_types.F b/src/distribution_2d_types.F index 8473cd37f5..a02fb10510 100644 --- a/src/distribution_2d_types.F +++ b/src/distribution_2d_types.F @@ -132,8 +132,9 @@ CONTAINS END IF IF (PRESENT(n_col_distribution)) THEN IF (ASSOCIATED(distribution_2d%col_distribution)) THEN - IF (n_col_distribution > distribution_2d%n_col_distribution) & + IF (n_col_distribution > distribution_2d%n_col_distribution) THEN CPABORT("n_col_distribution<=distribution_2d%n_col_distribution") + END IF ! else alloc col_distribution? END IF distribution_2d%n_col_distribution = n_col_distribution @@ -145,15 +146,17 @@ CONTAINS END IF IF (PRESENT(n_row_distribution)) THEN IF (ASSOCIATED(distribution_2d%row_distribution)) THEN - IF (n_row_distribution > distribution_2d%n_row_distribution) & + IF (n_row_distribution > distribution_2d%n_row_distribution) THEN CPABORT("n_row_distribution<=distribution_2d%n_row_distribution") + END IF ! else alloc row_distribution? END IF distribution_2d%n_row_distribution = n_row_distribution END IF - IF (PRESENT(local_rows_ptr)) & + IF (PRESENT(local_rows_ptr)) THEN distribution_2d%local_rows => local_rows_ptr + END IF IF (.NOT. ASSOCIATED(distribution_2d%local_rows)) THEN CPASSERT(PRESENT(n_local_rows)) ALLOCATE (distribution_2d%local_rows(SIZE(n_local_rows))) @@ -164,11 +167,13 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_rows(SIZE(distribution_2d%local_rows))) IF (PRESENT(n_local_rows)) THEN - IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) & + IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) THEN CPABORT("SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows)") + END IF DO i = 1, SIZE(distribution_2d%n_local_rows) - IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) & + IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) THEN CPABORT("SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i)") + END IF distribution_2d%n_local_rows(i) = n_local_rows(i) END DO ELSE @@ -178,8 +183,9 @@ CONTAINS END DO END IF - IF (PRESENT(local_cols_ptr)) & + IF (PRESENT(local_cols_ptr)) THEN distribution_2d%local_cols => local_cols_ptr + END IF IF (.NOT. ASSOCIATED(distribution_2d%local_cols)) THEN CPASSERT(PRESENT(n_local_cols)) ALLOCATE (distribution_2d%local_cols(SIZE(n_local_cols))) @@ -190,11 +196,13 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_cols(SIZE(distribution_2d%local_cols))) IF (PRESENT(n_local_cols)) THEN - IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) & + IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) THEN CPABORT("SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols)") + END IF DO i = 1, SIZE(distribution_2d%n_local_cols) - IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) & + IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) THEN CPABORT("SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i)") + END IF distribution_2d%n_local_cols(i) = n_local_cols(i) END DO ELSE @@ -315,8 +323,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%row_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%row_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) & + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -336,8 +345,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%col_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%col_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) & + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -355,8 +365,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_rows) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_rows(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) & + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -395,8 +406,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_cols) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_cols(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) & + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE diff --git a/src/distribution_methods.F b/src/distribution_methods.F index c2a143497c..6442052837 100644 --- a/src/distribution_methods.F +++ b/src/distribution_methods.F @@ -207,12 +207,14 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_count, bin, bin_price, found) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("No topmost heap element found.") + END IF ipe = bin - IF (bin_price /= workload_count(ipe)) & + IF (bin_price /= workload_count(ipe)) THEN CPABORT("inconsistent heap") + END IF workload_count(ipe) = workload_count(ipe) + nload IF (ipe == mype) THEN @@ -245,12 +247,14 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_fill, bin, bin_price, found) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("No topmost heap element found.") + END IF ipe = bin - IF (bin_price /= workload_fill(ipe)) & + IF (bin_price /= workload_fill(ipe)) THEN CPABORT("inconsistent heap") + END IF workload_fill(ipe) = workload_fill(ipe) + nload is_local = (ipe == mype) @@ -275,8 +279,9 @@ CONTAINS END DO - IF (ANY(workload_fill /= workload_count)) & + IF (ANY(workload_fill /= workload_count)) THEN CPABORT("Inconsistent heaps encountered") + END IF CALL cp_heap_release(bin_heap_count) CALL cp_heap_release(bin_heap_fill) @@ -563,8 +568,9 @@ CONTAINS CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model) IF (.NOT. molecular_distribution) THEN DO iatom = 1, natom - IF (iatom > nclusters) & + IF (iatom > nclusters) THEN CPABORT("Bounds error") + END IF CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) cluster_list(iatom) = iatom SELECT CASE (cost_model) @@ -619,8 +625,9 @@ CONTAINS nprow, cluster_row_distribution(:, 1), npcol, cluster_col_distribution(:, 1)) ELSE IF (basic_cluster_optimization) THEN - IF (molecular_distribution) & + IF (molecular_distribution) THEN CPABORT("clustering and molecular blocking NYI") + END IF ALLOCATE (pbc_scaled_coords(3, natom), coords(3, natom)) DO iatom = 1, natom CALL real_to_scaled(pbc_scaled_coords(:, iatom), pbc(particle_set(iatom)%r(:), cell), cell) @@ -864,15 +871,18 @@ CONTAINS DO cluster_index = nclusters, 1, -1 cluster = cluster_list(cluster_index) CALL cp_heap_get_first(bin_heap, bin, bin_price, found) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("No topmost heap element found.") + END IF ! prow = INT((bin - 1)*pgrid_gcd/npcols) - IF (prow >= nprows) & + IF (prow >= nprows) THEN CPABORT("Invalid process row.") + END IF pcol = INT((bin - 1)*pgrid_gcd/nprows) - IF (pcol >= npcols) & + IF (pcol >= npcols) THEN CPABORT("Invalid process column.") + END IF row_distribution(cluster) = prow + 1 col_distribution(cluster) = pcol + 1 ! @@ -1197,7 +1207,7 @@ CONTAINS balance_new = MAXVAL(REAL(nat_cluster, KIND=dp))/MINVAL(REAL(nat_cluster, KIND=dp)) IF (balance_new < balance) THEN balance = balance_new - min_seed = seed + i*40; + min_seed = seed + i*40 END IF ELSE found = .TRUE. @@ -1314,7 +1324,7 @@ CONTAINS devi = HUGE(1.0_dp) DO j = 1, i - 1 dvec = pbc(cent_coord(:, j), cent_coord(:, i), cell) - dist = SQRT(DOT_PRODUCT(dvec, dvec)) + dist = NORM2(dvec) IF (dist < devi) devi = dist END DO rn = rng_stream%next() diff --git a/src/dm_ls_chebyshev.F b/src/dm_ls_chebyshev.F index 0b707213c6..ea57800af1 100644 --- a/src/dm_ls_chebyshev.F +++ b/src/dm_ls_chebyshev.F @@ -263,27 +263,33 @@ CONTAINS DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp1) - CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) !matrix_dummy2= - CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) !first term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) !second term of chebyshev poly(matrix) + !matrix_dummy2= + CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) + !first term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) + !second term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) END DO DO icheb = 2, ncheb - 1 t1 = m_walltime() + !matrix multiplication(Recursion) CALL dbcsr_multiply("N", "N", 2.0_dp, matrix_F, matrix_tmp2, & - -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) !matrix multiplication(Recursion) + -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL dbcsr_copy(matrix_tmp3, matrix_tmp1) CALL dbcsr_copy(matrix_tmp1, matrix_tmp2) CALL dbcsr_copy(matrix_tmp2, matrix_tmp3) - CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) !icheb+1 th coefficient + !icheb+1 th coefficient + CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) CALL kernel(kernel_g(icheb + 1), icheb + 1, ncheb) DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp2) - CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) !second term of chebyshev poly(matrix) + !second term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) CALL dbcsr_trace(matrix_dummy2(iwindow), trace=trace_dm(iwindow)) !icheb+1 th coefficient diff --git a/src/dm_ls_scf.F b/src/dm_ls_scf.F index e5d9d07e2c..97b662fb2b 100644 --- a/src/dm_ls_scf.F +++ b/src/dm_ls_scf.F @@ -588,7 +588,7 @@ CONTAINS DO ispin = 1, nspin IF (nonscf) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) - ELSEIF (ls_scf_env%do_rho_mixing) THEN + ELSE IF (ls_scf_env%do_rho_mixing) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (iscf == 1) THEN @@ -657,10 +657,12 @@ CONTAINS IF (ls_scf_env%nspins == 1) nelectron_spin_real = nelectron_spin_real/2 IF (do_transport) THEN - IF (ls_scf_env%has_s_preconditioner) & + IF (ls_scf_env%has_s_preconditioner) THEN CPABORT("NOT YET IMPLEMENTED with S preconditioner. ") - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & + END IF + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN CPABORT("NOT YET IMPLEMENTED with molecular clustering. ") + END IF extra_scf = maxscf_reached .OR. scf_converged ! get the current Kohn-Sham matrix (ks) and return matrix_p evaluated using an external C routine @@ -691,11 +693,13 @@ CONTAINS eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos, & iounit=-1) CASE (ls_scf_pexsi) - IF (ls_scf_env%has_s_preconditioner) & + IF (ls_scf_env%has_s_preconditioner) THEN CPABORT("S preconditioning not implemented in combination with the PEXSI library. ") - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & + END IF + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN CALL cp_abort(__LOCATION__, & "Molecular clustering not implemented in combination with the PEXSI library. ") + END IF CALL density_matrix_pexsi(ls_scf_env%pexsi, ls_scf_env%matrix_p(ispin), ls_scf_env%pexsi%matrix_w(ispin), & ls_scf_env%pexsi%kTS(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s, & nelectron_spin_real, ls_scf_env%mu_spin(ispin), iscf, ispin) @@ -834,8 +838,9 @@ CONTAINS END IF ! store the matrix for a next scf run - IF (.NOT. ls_scf_env%do_pao) & + IF (.NOT. ls_scf_env%do_pao) THEN CALL ls_scf_store_result(ls_scf_env) + END IF ! write homo and lumo energy and occupation (if not already part of the output) IF (ls_scf_env%curvy_steps) THEN @@ -908,8 +913,9 @@ CONTAINS END DO DEALLOCATE (ls_scf_env%matrix_ks) - IF (ls_scf_env%do_pexsi) & + IF (ls_scf_env%do_pexsi) THEN CALL pexsi_finalize_scf(ls_scf_env%pexsi, ls_scf_env%mu_spin) + END IF CALL timestop(handle) diff --git a/src/dm_ls_scf_create.F b/src/dm_ls_scf_create.F index f094e7e7d6..2ae4abd5c4 100644 --- a/src/dm_ls_scf_create.F +++ b/src/dm_ls_scf_create.F @@ -155,8 +155,9 @@ CONTAINS ! initialize PEXSI IF (ls_scf_env%do_pexsi) THEN - IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) & + IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) THEN CPABORT("EPS_FILTER_MATRIX must be set to 0 for PEXSI.") + END IF CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env, ls_scf_env%nspins) END IF @@ -263,8 +264,9 @@ CONTAINS CALL section_vals_get(mixing_section, explicit=ls_scf_env%do_rho_mixing) CALL section_vals_val_get(mixing_section, "METHOD", i_val=ls_scf_env%density_mixing_method) - IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) & + IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) THEN CPABORT("LS_DIIS and RHO_MIXING are not compatible.") + END IF pexsi_section => section_vals_get_subs_vals(input, "DFT%LS_SCF%PEXSI") CALL section_vals_get(pexsi_section) @@ -313,14 +315,18 @@ CONTAINS END SELECT ! verify some requirements for the curvy steps - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) & + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) THEN CPABORT("CURVY_STEPS cannot be used together with PEXSI.") - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) & + END IF + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) THEN CPABORT("CURVY_STEPS cannot be used together with TRANSPORT.") - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) & + END IF + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) THEN CPABORT("S Preconditioning not implemented in combination with CURVY_STEPS.") - IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) & + END IF + IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) THEN CPABORT("CURVY_STEPS requires the use of the sqrt inversion.") + END IF ! verify requirements for direct submatrix sign methods IF (ls_scf_env%sign_method == ls_scf_sign_submatrix & @@ -328,8 +334,9 @@ CONTAINS ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & - ) .AND. .NOT. ls_scf_env%sign_symmetric) & + ) .AND. .NOT. ls_scf_env%sign_symmetric) THEN CPABORT("DIRECT submatrix sign methods require SIGN_SYMMETRIC being set.") + END IF IF (ls_scf_env%fixed_mu .AND. ( & ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & diff --git a/src/dm_ls_scf_curvy.F b/src/dm_ls_scf_curvy.F index 1548418d0d..e1c9375c9b 100644 --- a/src/dm_ls_scf_curvy.F +++ b/src/dm_ls_scf_curvy.F @@ -95,9 +95,10 @@ CONTAINS ! If new search direction has to be computed transform H into the orthnormal basis - IF (ls_scf_env%curvy_data%line_search_step == 1) & + IF (ls_scf_env%curvy_data%line_search_step == 1) THEN CALL transform_matrix_orth(ls_scf_env%matrix_ks, ls_scf_env%matrix_s_sqrt_inv, & ls_scf_env%eps_filter) + END IF ! Set the energies for the line search and make sure to give the correct energy back to scf_main ls_scf_env%curvy_data%energies(lsstep) = energy diff --git a/src/dm_ls_scf_methods.F b/src/dm_ls_scf_methods.F index e74da48ab7..b51f08d513 100644 --- a/src/dm_ls_scf_methods.F +++ b/src/dm_ls_scf_methods.F @@ -516,8 +516,9 @@ CONTAINS IF (sign_symmetric) THEN - IF (.NOT. PRESENT(matrix_s_sqrt_inv)) & + IF (.NOT. PRESENT(matrix_s_sqrt_inv)) THEN CPABORT("Argument matrix_s_sqrt_inv required if sign_symmetric is set") + END IF CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv2, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) @@ -577,8 +578,9 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix + END IF IF (sign_symmetric) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & @@ -688,8 +690,9 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix + END IF CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & 0.0_dp, matrix_tmp, filter_eps=threshold) @@ -942,8 +945,9 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(trace_gx)) & + IF (abnormal_value(trace_gx)) THEN CPABORT("trace_gx is an abnormal value (NaN/Inf).") + END IF ! a branch of 1 or 2 appears to lead to a less accurate electron number count and premature exit ! if it turns out this does not exit because we get stuck in branch 1/2 for a reason we need to refine further @@ -969,13 +973,15 @@ CONTAINS CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_x_nosym, & 0.0_dp, matrix_p, filter_eps=threshold) - ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, where fk is evaluated using the stored values for gamma + ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, + ! where fk is evaluated using the stored values for gamma ! E. Rubensson et al., Chem Phys Lett 432, 2006, 591-594 - mu_a = 0.0_dp; mu_b = 1.0_dp; + mu_a = 0.0_dp; mu_b = 1.0_dp mu_fa = evaluate_trs4_polynomial(mu_a, gamma_values, i - 1) - 0.5_dp DO j = 1, 40 mu_c = 0.5*(mu_a + mu_b) - mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp ! i-1 because in the last iteration, only convergence is checked + ! i-1 because in the last iteration, only convergence is checked + mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp IF (ABS(mu_fc) < 1.0E-6_dp .OR. (mu_b - mu_a)/2 < 1.0E-6_dp) EXIT !TODO: define threshold values IF (mu_fc*mu_fa > 0) THEN diff --git a/src/dm_ls_scf_qs.F b/src/dm_ls_scf_qs.F index 7fc0b72aca..5ae581f005 100644 --- a/src/dm_ls_scf_qs.F +++ b/src/dm_ls_scf_qs.F @@ -322,8 +322,9 @@ CONTAINS CALL timeset(routineN, handle) my_keep_sparsity = .TRUE. - IF (PRESENT(keep_sparsity)) & + IF (PRESENT(keep_sparsity)) THEN my_keep_sparsity = keep_sparsity + END IF IF (.NOT. ls_mstruct%do_pao) THEN CALL dbcsr_create(matrix_declustered, template=matrix_qs) @@ -583,8 +584,9 @@ CONTAINS ! compute the corresponding KS matrix and new energy, mix density if requested CALL qs_rho_update_rho(rho, qs_env=qs_env) IF (ls_scf_env%do_rho_mixing) THEN - IF (ls_scf_env%density_mixing_method == direct_mixing_nr) & + IF (ls_scf_env%density_mixing_method == direct_mixing_nr) THEN CPABORT("Direct P mixing not implemented in linear scaling SCF. ") + END IF IF (ls_scf_env%density_mixing_method >= gspace_mixing_nr) THEN IF (iscf > MAX(ls_scf_env%mixing_store%nskip_mixing, 1)) THEN CALL gspace_mixing(qs_env, ls_scf_env%density_mixing_method, & @@ -839,9 +841,9 @@ CONTAINS CALL get_qs_env(qs_env, rho_atom_set=rho_atom) CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & ls_scf_env%para_env, rho_atom=rho_atom) - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(ls_scf_env%mixing_store) - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & diff --git a/src/dm_ls_scf_types.F b/src/dm_ls_scf_types.F index 07123e6801..1d26e1d570 100644 --- a/src/dm_ls_scf_types.F +++ b/src/dm_ls_scf_types.F @@ -208,10 +208,12 @@ CONTAINS DEALLOCATE (ls_scf_env%matrix_p) END IF - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) & + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) THEN CALL section_vals_release(ls_scf_env%chebyshev%print_key_dos) - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) & + END IF + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) THEN CALL section_vals_release(ls_scf_env%chebyshev%print_key_cube) + END IF IF (ASSOCIATED(ls_scf_env%chebyshev%min_energy)) THEN DEALLOCATE (ls_scf_env%chebyshev%min_energy) END IF @@ -228,8 +230,9 @@ CONTAINS CALL lib_pexsi_finalize(ls_scf_env%pexsi) END IF - IF (ls_scf_env%do_pao) & + IF (ls_scf_env%do_pao) THEN CALL pao_finalize(ls_scf_env%pao_env) + END IF DEALLOCATE (ls_scf_env) diff --git a/src/domain_submatrix_methods.F b/src/domain_submatrix_methods.F index b70d9fc507..ac020751c0 100644 --- a/src/domain_submatrix_methods.F +++ b/src/domain_submatrix_methods.F @@ -937,33 +937,6 @@ CONTAINS END DO - ! simple but quadratically scaling procedure - ! loop over local blocks - !CALL dbcsr_iterator_start(iter,matrix) - !DO WHILE (dbcsr_iterator_blocks_left(iter)) - ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& - ! row_size=row_size,col_size=col_size) - ! DO idomain = 1, ndomains - ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ELSE - ! domain_needs_block=(idomain==col& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ENDIF - ! IF (domain_needs_block) THEN - ! transp=.FALSE. - ! dest_node=node_of_domain(idomain) - ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& - ! ! idomain, idomain, transp, dest_node) - ! send_descriptor(1,dest_node+1)=send_descriptor(1,dest_node+1)+1 - ! send_descriptor(2,dest_node+1)=send_descriptor(2,dest_node+1)+& - ! row_size*col_size - ! ENDIF - ! ENDDO - !ENDDO - !CALL dbcsr_iterator_stop(iter) - ! communicate number of blocks and their sizes to the other nodes CALL group%alltoall(send_descriptor, recv_descriptor, ldesc) @@ -1058,15 +1031,6 @@ CONTAINS IF (block_node == myNode) THEN CALL dbcsr_get_block_p(matrix, row, col, block_p, found, row_size, col_size) IF (found) THEN - !col_offset=0 - !DO icol=1,col_size - ! start_data=send_offset_cpu(dest_node+1)+& - ! offset_block(dest_node+1)+& - ! col_offset - ! send_data(start_data+1:start_data+row_size)=& - ! data_p(1:row_size,icol) - ! col_offset=col_offset+row_size - !ENDDO col_offset = row_size*col_size start_data = send_offset_cpu(dest_node + 1) + & offset_block(dest_node + 1) @@ -1086,45 +1050,6 @@ CONTAINS END DO ! loop over rows END DO - ! more simple but quadratically scaling version - !CALL dbcsr_iterator_start(iter,matrix) - !DO WHILE (dbcsr_iterator_blocks_left(iter)) - ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& - ! row_size=row_size,col_size=col_size) - ! DO idomain = 1, ndomains - ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ELSE - ! domain_needs_block=(idomain==col& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ENDIF - ! IF (domain_needs_block) THEN - ! transp=.FALSE. - ! dest_node=node_of_domain(idomain) - ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& - ! ! idomain, idomain, transp, dest_node) - ! ! place the data appropriately - ! col_offset=0 - ! DO icol=1,col_size - ! start_data=send_offset_cpu(dest_node+1)+& - ! offset_block(dest_node+1)+& - ! col_offset - ! send_data(start_data+1:start_data+row_size)=& - ! data_p(1:row_size,icol) - ! col_offset=col_offset+row_size - ! ENDDO - ! offset_block(dest_node+1)=offset_block(dest_node+1)+col_size*row_size - ! ! fill out row,col information - ! send_data2(send_offset2_cpu(dest_node+1)+& - ! offset2_block(dest_node+1)+1)=row - ! send_data2(send_offset2_cpu(dest_node+1)+& - ! offset2_block(dest_node+1)+2)=col - ! offset2_block(dest_node+1)=offset2_block(dest_node+1)+2 - ! ENDIF - ! ENDDO - !ENDDO - !CALL dbcsr_iterator_stop(iter) ! send-receive all blocks CALL group%alltoall(send_data, send_size_cpu, send_offset_cpu, & @@ -1142,9 +1067,6 @@ CONTAINS ! copy blocks into submatrices CALL dbcsr_get_info(matrix, col_blk_size=col_blk_size, row_blk_size=row_blk_size) -! ALLOCATE(subm_row_size(ndomains),subm_col_size(ndomains)) -! subm_row_size(:)=0 -! subm_col_size(:)=0 ndomains2 = SIZE(submatrix) IF (ndomains2 /= ndomains) THEN CPABORT("wrong submatrix size") @@ -1159,9 +1081,6 @@ CONTAINS submatrix(:)%domain = -1 DO idomain = 1, ndomains dest_node = node_of_domain(idomain) - !transp=.FALSE. - !CALL dbcsr_get_stored_coordinates(distr_pattern,& - ! idomain, idomain, transp, dest_node) IF (dest_node == mynode) THEN submatrix(idomain)%domain = idomain submatrix(idomain)%nbrows = 0 @@ -1174,12 +1093,9 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) - !DO row = 1, nblkrows_tot - ! IF (qblk_exists(domain_map,row,idomain)) THEN first_row(row) = submatrix(idomain)%nrows + 1 submatrix(idomain)%nrows = submatrix(idomain)%nrows + row_blk_size(row) submatrix(idomain)%nbrows = submatrix(idomain)%nbrows + 1 - ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_row(submatrix(idomain)%nbrows)) ALLOCATE (submatrix(idomain)%size_brow(submatrix(idomain)%nbrows)) @@ -1190,12 +1106,9 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) - !DO row = 1, nblkrows_tot - ! IF (first_row(row).ne.-1) THEN submatrix(idomain)%dbcsr_row(smrow) = row submatrix(idomain)%size_brow(smrow) = row_blk_size(row) smrow = smrow + 1 - ! ENDIF END DO ! loop over the necessary columns @@ -1216,17 +1129,9 @@ CONTAINS ELSE col = idomain END IF - !DO col = 1, nblkcols_tot - ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain)) - ! ELSE - ! domain_needs_block=(col==idomain) ! RZK-warning col belongs to the domain - ! ENDIF - ! IF (domain_needs_block) THEN first_col(col) = submatrix(idomain)%ncols + 1 submatrix(idomain)%ncols = submatrix(idomain)%ncols + col_blk_size(col) submatrix(idomain)%nbcols = submatrix(idomain)%nbcols + 1 - ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_col(submatrix(idomain)%nbcols)) @@ -1250,12 +1155,9 @@ CONTAINS ELSE col = idomain END IF - !DO col = 1, nblkcols_tot - ! IF (first_col(col).ne.-1) THEN submatrix(idomain)%dbcsr_col(smcol) = col submatrix(idomain)%size_bcol(smcol) = col_blk_size(col) smcol = smcol + 1 - ! ENDIF END DO ALLOCATE (submatrix(idomain)%mdata( & diff --git a/src/ec_orth_solver.F b/src/ec_orth_solver.F index 1a8a904a72..65e07cfaf7 100644 --- a/src/ec_orth_solver.F +++ b/src/ec_orth_solver.F @@ -241,8 +241,9 @@ CONTAINS ! Tr(r_0 * r_0) CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, norm_rr(ispin)) - IF (abnormal_value(norm_rr(ispin))) & + IF (abnormal_value(norm_rr(ispin))) THEN CPABORT("Preconditioner: Tr[r_j*r_j] is an abnormal value (NaN/Inf)") + END IF IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0") norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp))) @@ -272,8 +273,9 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) & + IF (abnormal_value(new_norm(ispin))) THEN CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") + END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps*0.001_dp & @@ -710,8 +712,9 @@ CONTAINS CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin)) CPABORT("tr(Ap_j*p_j) < 0") - IF (abnormal_value(norm_cA(ispin))) & + IF (abnormal_value(norm_cA(ispin))) THEN CPABORT("Preconditioner: Tr[Ap_j*p_j] is an abnormal value (NaN/Inf)") + END IF END IF @@ -790,8 +793,9 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_z0(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) & + IF (abnormal_value(new_norm(ispin))) THEN CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") + END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps .OR. new_norm(ispin) < linres_control%eps) THEN diff --git a/src/eeq_data.F b/src/eeq_data.F index dc1bdef0d6..b030a0bde8 100644 --- a/src/eeq_data.F +++ b/src/eeq_data.F @@ -247,7 +247,7 @@ CONTAINS IF (PRESENT(eta)) eta = eeqGam(za) IF (PRESENT(kcn)) kcn = eeqkCN(za) IF (PRESENT(rad)) rad = eeqAlp(za) - ELSEIF (model == 2) THEN + ELSE IF (model == 2) THEN CPASSERT(za <= max_elem) IF (PRESENT(chi)) chi = eeq_chi(za) IF (PRESENT(eta)) eta = eeq_eta(za) diff --git a/src/eeq_method.F b/src/eeq_method.F index 7e86e08ea0..7e4c0f94f4 100644 --- a/src/eeq_method.F +++ b/src/eeq_method.F @@ -1611,7 +1611,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1693,7 +1693,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1764,7 +1764,7 @@ CONTAINS dfilter(1:3) = dft_control%period_efield%d_filter(1:3) fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi omega = cell%deth @@ -1882,7 +1882,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) diff --git a/src/efield_tb_methods.F b/src/efield_tb_methods.F index 11fbabcaf5..a7395d9325 100644 --- a/src/efield_tb_methods.F +++ b/src/efield_tb_methods.F @@ -281,7 +281,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'efield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) + COMPLEX(KIND=dp), DIMENSION(3) :: zi INTEGER :: atom_a, atom_b, handle, ia, iac, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, & @@ -334,7 +334,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -452,7 +452,7 @@ CONTAINS NULLIFY (sap_int) IF (dft_control%qs_control%dftb) THEN CPABORT("DFTB stress tensor for periodic efield not implemented") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL xtb_dsint_list(qs_env, sap_int) ELSE CPABORT("TB method unknown") @@ -612,7 +612,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'dfield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) + COMPLEX(KIND=dp), DIMENSION(3) :: zi INTEGER :: atom_a, atom_b, handle, i, ia, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, nspin @@ -674,7 +674,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/efield_utils.F b/src/efield_utils.F index 352369cdca..59efeb61bc 100644 --- a/src/efield_utils.F +++ b/src/efield_utils.F @@ -140,7 +140,7 @@ CONTAINS IF (DOT_PRODUCT(efield%polarisation, efield%polarisation) == 0) THEN pol(:) = 1.0_dp/3.0_dp ELSE - pol(:) = efield%polarisation(:)/(SQRT(DOT_PRODUCT(efield%polarisation, efield%polarisation))) + pol(:) = efield%polarisation(:)/NORM2(efield%polarisation) END IF SELECT CASE (efield%envelop_id) @@ -151,10 +151,12 @@ CONTAINS efield%phase_offset*pi)*pol(:) END IF CASE (ramp_env) - IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) & + IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) THEN strength = E_0*(sim_step - efield%envelop_i_vars(1))/(efield%envelop_i_vars(2) - efield%envelop_i_vars(1)) - IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) & + END IF + IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) THEN strength = E_0*(efield%envelop_i_vars(4) - sim_step)/(efield%envelop_i_vars(4) - efield%envelop_i_vars(3)) + END IF IF (sim_step > efield%envelop_i_vars(4) .AND. efield%envelop_i_vars(4) > 0) strength = 0.0_dp IF (sim_step <= efield%envelop_i_vars(1)) strength = 0.0_dp field = field + strength*COS(sim_time*nu*twopi + & diff --git a/src/eip_silicon.F b/src/eip_silicon.F index 1e5bf4d308..0d611e56c8 100644 --- a/src/eip_silicon.F +++ b/src/eip_silicon.F @@ -34,6 +34,7 @@ MODULE eip_silicon USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_para_env_type USE particle_types, ONLY: particle_type USE physcon, ONLY: angstrom,& @@ -926,25 +927,17 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & - ener_var, coord_var, count + REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + ener, coord, ener_var, coord_var, count - DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: s2, s3, sz - INTEGER, ALLOCATABLE, DIMENSION(:) :: num2, num3, numz - - REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, rlc3i, tcoord, & - tcoord2, tener, tener2 - INTEGER :: iam, iat, iat1, iat2, ii, i, il, in, indlst, indlstx, istop, & - istopg, l2, l3, laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, & - l1, myspaceout, ncx, nn, nnbrx, npr + INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & + laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, myspaceout, ncx, nn, nnbrx, npr + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb, num2, num3, numz + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, & + rlc3i, tcoord, tcoord2, tener, tener2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz, s2, s3, sz, txyz ! cut=par_a cut = 3.1213820e0_dp + 1.e-14_dp @@ -1564,8 +1557,6 @@ CONTAINS END IF !$OMP END PARALLEL -! write(*,*) 'ener,norm force', & -! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2021,16 +2012,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz - INTEGER :: icell, lstb, lay - REAL(KIND=dp) :: rel, cut2 + REAL(KIND=dp) :: rxyz(3, nn) + INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst - DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & - lstb(0:myspace - 1), rel(5, 0:myspace - 1) - - INTEGER :: jat, k1, k2, k3, jj - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + INTEGER :: jat, jj, k1, k2, k3 + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -2091,25 +2079,18 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & - ener_var, coord_var, count + REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + ener, coord, ener_var, coord_var, count - DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik - - REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & - tcoord2, tener, tener2 - INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, & - istop, istopg, l1, l2, l3, ll1, ll2, ll3, lot, ncx, nn, & - nnbrx, npjkx, npjx, laymx, npr, rlc1i, rlc2i, rlc3i, & - myspace, myspaceout + INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & + laymx, ll1, ll2, ll3, lot, myspace, myspaceout, ncx, nn, nnbrx, npjkx, npjx, npr, rlc1i, & + rlc2i, rlc3i + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & + tcoord2, tener, tener2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik, rel, rxyz, txyz ! tmax_phi= 0.4500000e+01_dp ! cut=tmax_phi @@ -2720,8 +2701,6 @@ CONTAINS END IF !$OMP END PARALLEL -! write(*,*) 'ener,norm force', & -! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2759,115 +2738,78 @@ CONTAINS ! with them and their contribution to the energy (tener). ! In addition the coordination number tcoord and the second moment of the ! local energy tener2 and coordination number tcoord2 are returned - INTEGER :: iat1, iat2, nat, lsta, lstb - REAL(KIND=dp) :: rel, tener, tener2, tcoord, tcoord2 + INTEGER :: iat1, iat2, nat, lsta(2, nat) + REAL(KIND=dp) :: tener, tener2, tcoord, tcoord2 INTEGER :: nnbrx - REAL(KIND=dp) :: txyz, f2ij + REAL(KIND=dp) :: rel(5, nnbrx*nat) + INTEGER :: lstb(nnbrx*nat) + REAL(KIND=dp) :: txyz(3, nat) INTEGER :: npjx - REAL(KIND=dp) :: f3ij + REAL(KIND=dp) :: f2ij(3, npjx) INTEGER :: npjkx - REAL(KIND=dp) :: f3ik + REAL(KIND=dp) :: f3ij(3, npjkx), f3ik(3, npjkx) INTEGER :: istop - DIMENSION lsta(2, nat), lstb(nnbrx*nat), rel(5, nnbrx*nat), txyz(3, nat) - DIMENSION f2ij(3, npjx), f3ij(3, npjkx), f3ik(3, npjkx) - REAL(KIND=dp), PARAMETER :: tmin_phi = 0.1500000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_phi = 0.4500000e+01_dp - REAL(KIND=dp), PARAMETER :: hi_phi = 3.00000000000e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_phi = 5.55555555555556e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_phi = 1.85185185185185e-002_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_phi = & - [0.69299400000000e+01_dp, -0.43995000000000e+00_dp, & - -0.17012300000000e+01_dp, -0.16247300000000e+01_dp, & - -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & - -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, & - -0.96100000000000e-02_dp, 0.00000000000000e+00_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_phi = & - [0.16533229480429e+03_dp, 0.39415410391417e+02_dp, & - 0.68710036300407e+01_dp, 0.53406950884203e+01_dp, & - 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & - -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, & - -0.40087646318907e-01_dp, -0.23942617684055e+00_dp] - REAL(KIND=dp), PARAMETER :: tmin_rho = 0.1500000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_rho = 0.3500000e+01_dp - REAL(KIND=dp), PARAMETER :: hi_rho = 5.00000000000e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_rho = 3.33333333333333e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_rho = 6.66666666666667e-003_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: cof_rho = & - [0.13747000000000e+00_dp, -0.14831000000000e+00_dp, & - -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & - -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, & - -0.66620000000000e+00_dp, -0.57328000000000e+00_dp, & - -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & - 0.00000000000000e+00_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: dof_rho = & - [-0.32275496741918e+01_dp, -0.64119006516165e+01_dp, & - 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & - 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, & - 0.47189016693543e+00_dp, 0.20569572748420e+01_dp, & - 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & - -0.12371959895186e+02_dp] - REAL(KIND=dp), PARAMETER :: tmin_fff = 0.1500000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp - REAL(KIND=dp), PARAMETER :: hi_fff = 4.50000000000e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_fff = 3.70370370370370e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_fff = & - [0.12503100000000e+01_dp, 0.86821000000000e+00_dp, & - 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & - 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, & - 0.27145000000000e+00_dp, 0.14814000000000e+00_dp, & - 0.48550000000000e-01_dp, 0.00000000000000e+00_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_fff = & - [0.27904652711432e+02_dp, -0.45230754228635e+01_dp, & - 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & - -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, & - -0.50891685571587e+00_dp, 0.66278396115427e+00_dp, & - 0.73976101109878e+00_dp, 0.25795319944506e+01_dp] - REAL(KIND=dp), PARAMETER :: tmin_uuu = -0.1770930e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_uuu = 0.7908520e+01_dp - REAL(KIND=dp), PARAMETER :: hi_uuu = 0.723181585730594e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_uuu = 0.230463095238095e0_dp - REAL(KIND=dp), PARAMETER :: h2sixth_uuu = 0.318679429600340e0_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_uuu = & - [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & - 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, & - 0.12668900000000e+01_dp, 0.16299800000000e+01_dp, & - 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_uuu = & - [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & - -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, & - -0.15815242579643e-01_dp, 0.26112640061855e-01_dp, & - -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] - REAL(KIND=dp), PARAMETER :: tmin_ggg = -0.1000000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_ggg = 0.8001400e+00_dp - REAL(KIND=dp), PARAMETER :: hi_ggg = 3.88858644327663e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_ggg = 4.28604761904762e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_ggg = 1.10221225156463e-002_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_ggg = & - [0.52541600000000e+01_dp, 0.23591500000000e+01_dp, & - 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & - 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, & - 0.49485900000000e+01_dp, 0.56179900000000e+01_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_ggg = & - [0.15826876132396e+02_dp, 0.31176239377907e+02_dp, & - 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & - 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, & - -0.18823313223755e+02_dp, -0.77183416481005e+01_dp] + REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: cof_rho = [0.13747000000000e+00_dp, & + -0.14831000000000e+00_dp, -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & + -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, -0.66620000000000e+00_dp, & + -0.57328000000000e+00_dp, -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & + 0.00000000000000e+00_dp] + REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: dof_rho = [-0.32275496741918e+01_dp, & + -0.64119006516165e+01_dp, 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & + 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, 0.47189016693543e+00_dp, & + 0.20569572748420e+01_dp, 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & + -0.12371959895186e+02_dp] + REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: cof_ggg = [0.52541600000000e+01_dp, & + 0.23591500000000e+01_dp, 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & + 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, 0.49485900000000e+01_dp, & + 0.56179900000000e+01_dp], cof_uuu = [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & + 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, 0.12668900000000e+01_dp, & + 0.16299800000000e+01_dp, 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] + REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: dof_ggg = [0.15826876132396e+02_dp, & + 0.31176239377907e+02_dp, 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & + 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, -0.18823313223755e+02_dp, & + -0.77183416481005e+01_dp], dof_uuu = [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & + -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, -0.15815242579643e-01_dp, & + 0.26112640061855e-01_dp, -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] + REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: cof_fff = [0.12503100000000e+01_dp, & + 0.86821000000000e+00_dp, 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & + 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, 0.27145000000000e+00_dp, & + 0.14814000000000e+00_dp, 0.48550000000000e-01_dp, 0.00000000000000e+00_dp], cof_phi = [ & + 0.69299400000000e+01_dp, -0.43995000000000e+00_dp, -0.17012300000000e+01_dp, & + -0.16247300000000e+01_dp, -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & + -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, -0.96100000000000e-02_dp, & + 0.00000000000000e+00_dp] + REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: dof_fff = [0.27904652711432e+02_dp, & + -0.45230754228635e+01_dp, 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & + -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, -0.50891685571587e+00_dp, & + 0.66278396115427e+00_dp, 0.73976101109878e+00_dp, 0.25795319944506e+01_dp], dof_phi = [ & + 0.16533229480429e+03_dp, 0.39415410391417e+02_dp, 0.68710036300407e+01_dp, & + 0.53406950884203e+01_dp, 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & + -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, -0.40087646318907e-01_dp, & + -0.23942617684055e+00_dp] + REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp, & + h2sixth_ggg = 1.10221225156463e-002_dp, h2sixth_phi = 1.85185185185185e-002_dp, & + h2sixth_rho = 6.66666666666667e-003_dp, h2sixth_uuu = 0.318679429600340e0_dp, & + hi_fff = 4.50000000000e0_dp, hi_ggg = 3.88858644327663e0_dp, hi_phi = 3.00000000000e0_dp, & + hi_rho = 5.00000000000e0_dp, hi_uuu = 0.723181585730594e0_dp, & + hsixth_fff = 3.70370370370370e-002_dp, hsixth_ggg = 4.28604761904762e-002_dp, & + hsixth_phi = 5.55555555555556e-002_dp, hsixth_rho = 3.33333333333333e-002_dp, & + hsixth_uuu = 0.230463095238095e0_dp + REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp, tmax_ggg = 0.8001400e+00_dp, & + tmax_phi = 0.4500000e+01_dp, tmax_rho = 0.3500000e+01_dp, tmax_uuu = 0.7908520e+01_dp, & + tmin_fff = 0.1500000e+01_dp, tmin_ggg = -0.1000000e+01_dp, tmin_phi = 0.1500000e+01_dp, & + tmin_rho = 0.1500000e+01_dp, tmin_uuu = -0.1770930e+01_dp - REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, & - b_ggg, cof1_fff, cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, & - cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, cof_fff_klo, & - cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, & - dens2, dens3, dof_fff_khi, dof_fff_klo, dof_ggg_khi, & - dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, ep_uuu, & - fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, & - gjik, gjikp, rho, rhop, rij, rik, sij, sik, t1, t2, t3, t4, & - tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, ypt2_fff, & - ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg - - INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, khi_fff, khi_ggg, & - klo_fff, klo_ggg + INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, & + khi_fff, khi_ggg, klo_fff, klo_ggg + REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, b_ggg, cof1_fff, & + cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, & + cof_fff_klo, cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, dens2, dens3, & + dof_fff_khi, dof_fff_klo, dof_ggg_khi, dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, & + ep_uuu, fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, gjik, gjikp, rho, rhop, & + rij, rik, sij, sik, t1, t2, t3, t4, tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, & + ypt2_fff, ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg ! initialize temporary private scalars for reduction sum on energies and ! private workarray txyz for forces forces @@ -3211,16 +3153,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz - INTEGER :: icell, lstb, lay - REAL(KIND=dp) :: rel, cut2 + REAL(KIND=dp) :: rxyz(3, nn) + INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst - DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & - lstb(0:myspace - 1), rel(5, 0:myspace - 1) - - INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, xrel, yrel, zrel, tti + INTEGER :: jat, jj, k1, k2, k3 + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel loop_k3: DO k3 = l3 - 1, l3 + 1 loop_k2: DO k2 = l2 - 1, l2 + 1 @@ -3268,14 +3207,14 @@ CONTAINS !> \param yp ... ! ************************************************************************************************** SUBROUTINE splint(ya, y2a, tmin, tmax, hsixth, h2sixth, hi, n, x, y, yp) - REAL(KIND=dp) :: ya, y2a, tmin, tmax, hsixth, h2sixth, hi + REAL(KIND=dp) :: tmin, tmax, hsixth, h2sixth, hi INTEGER :: n - REAL(KIND=dp) :: x, y, yp + REAL(KIND=dp) :: y2a(0:n - 1), ya(0:n - 1), x, y, yp - DIMENSION y2a(0:n - 1), ya(0:n - 1) - REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, tt, & - y2a_khi, ya_klo, y2a_klo, ya_khi, ypt1, ypt2, yt1, yt2 - INTEGER :: klo, khi + INTEGER :: khi, klo + REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, & + tt, y2a_khi, y2a_klo, ya_khi, ya_klo, & + ypt1, ypt2, yt1, yt2 ! interpolate if the argument is outside the cubic spline interval [tmin,tmax] tt = (x - tmin)*hi @@ -3356,15 +3295,15 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, real(8) : total potential energy, 2-body and 3-body, in eV -! count, real(8) : increased by 1.d0 at each call of this subroutine, -! needs to be initialized to 0.d0 before calling this routine for the first time +! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV +! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, +! needs to be initialized to 0._dp before calling this routine for the first time ! ! Other variables: ! p: the 2-body potential energy @@ -3377,9 +3316,12 @@ CONTAINS !***************************************************************************************** INTEGER :: nat - REAL(8) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + REAL(dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & etot, count + REAL(KIND=dp), PARAMETER :: eps = 2.167239428587_dp, ra = 1.8_dp, & + sigma = 2.0951_dp + INTEGER :: i, iam, iat, ii, il, in, indlst, & indlstx, ipb, l1, l2, l3, laymx, ll1, & ll2, ll3, myspace, myspaceout, ncx, & @@ -3387,18 +3329,14 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(8) :: cut, cut2, eps, esigma, fx(nat), & - fx3(nat), fy(nat), fy3(nat), fz(nat), & - fz3(nat), isigma, p, p3, pv3, ra, & - rlc1i, rlc2i, rlc3i, sigma - REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(dp) :: cut, cut2, esigma, fx(nat), fx3(nat), & + fy(nat), fy3(nat), fz(nat), fz3(nat), & + isigma, p, p3, pv3, rlc1i, rlc2i, rlc3i + REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - PARAMETER(ra=1.8d0) - PARAMETER(sigma=2.0951d0, eps=2.167239428587d0) - - count = count + 1.d0 - cut = sigma*ra*2.d0 - isigma = 1.d0/sigma + count = count + 1._dp + cut = sigma*ra*2._dp + isigma = 1._dp/sigma esigma = eps*isigma ! linear scaling calculation of verlet list, only serial @@ -3872,15 +3810,15 @@ CONTAINS !start energy and force calculation------------------------------------------------------- !set all variables to zero - p = 0.0d0 - p3 = 0.0d0 - pv3 = 0.0d0 - fx(:) = 0.0d0 - fy(:) = 0.0d0 - fz(:) = 0.0d0 - fx3(:) = 0.0d0 - fy3(:) = 0.0d0 - fz3(:) = 0.0d0 + p = 0.0_dp + p3 = 0.0_dp + pv3 = 0.0_dp + fx(:) = 0.0_dp + fy(:) = 0.0_dp + fz(:) = 0.0_dp + fx3(:) = 0.0_dp + fy3(:) = 0.0_dp + fz3(:) = 0.0_dp !----------------------------------------------------------------------------------------- ! triple loop for the 2 and 3-body forces ! do 20 i @@ -3916,23 +3854,22 @@ CONTAINS !> \param c ... !> \return ... ! ************************************************************************************************** - REAL(8) FUNCTION f(c) - REAL(8) :: c + REAL(KIND=dp) FUNCTION f(c) + REAL(KIND=dp) :: c - REAL(8) :: aa, bb, c4, crainv, ra + REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & + bb = 0.6022245584_dp, ra = 1.8_dp - PARAMETER(aa=7.049556277d0) - PARAMETER(ra=1.8d0, bb=0.6022245584d0) + REAL(KIND=dp) :: c4, crainv - IF ((c - ra) < 0.d0) THEN - crainv = 1.0d0/(c - ra) + IF ((c - ra) < 0._dp) THEN + crainv = 1.0_dp/(c - ra) c4 = c*c*c*c - f = aa*bb*4.0d0/(c4*c)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv + f = aa*bb*4.0_dp/(c4*c)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv ELSE - f = 0.d0 + f = 0._dp END IF - RETURN END FUNCTION f ! ************************************************************************************************** @@ -3940,18 +3877,17 @@ CONTAINS !> \param d ... !> \return ... ! ************************************************************************************************** - REAL(8) FUNCTION pe(d) - REAL(8) :: d + REAL(KIND=dp) FUNCTION pe(d) + REAL(KIND=dp) :: d - REAL(8), PARAMETER :: aa = 7.049556277d0, bb = 0.6022245584d0, & - ra = 1.8d0 + REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & + bb = 0.6022245584_dp, ra = 1.8_dp - IF ((d - ra) < 0.d0) THEN - pe = aa*(bb/(d*d*d*d) - 1.0d0)*dexp(1.0d0/(d - ra)) + IF ((d - ra) < 0._dp) THEN + pe = aa*(bb/(d*d*d*d) - 1.0_dp)*EXP(1.0_dp/(d - ra)) ELSE - pe = 0.d0 + pe = 0._dp END IF - RETURN END FUNCTION pe !------------------------------------------------------------------------------------------ @@ -3981,13 +3917,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(8) :: rxyz(3, nn) + REAL(KIND=dp) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(8) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(8) :: rr2, tt, tti, xrel, yrel, zrel + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -4004,7 +3940,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1.d0/tt + tti = 1._dp/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -4041,24 +3977,25 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE sw_subfeniat_l(i, nat, nnbrx, rel, p, p3, fx, fy, fz, fx3, fy3, fz3, lstb, lsta, isigma, sigma) INTEGER, INTENT(IN) :: i, nat, nnbrx - REAL(8), INTENT(IN) :: rel(5, nnbrx*nat) - REAL(8), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & + REAL(KIND=dp), INTENT(IN) :: rel(5, nnbrx*nat) + REAL(KIND=dp), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & fx3(nat), fy3(nat), fz3(nat) INTEGER, INTENT(IN) :: lstb(nnbrx*nat), lsta(2, nat) - REAL(8), INTENT(IN) :: isigma, sigma + REAL(KIND=dp), INTENT(IN) :: isigma, sigma + + REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & + bb = 0.6022245584_dp, gam = 1.2_dp, & + ra = 1.8_dp, ramda = 21.0_dp INTEGER :: Ipb, Ipe, j, k, l, m, nij - REAL(8) :: aa, bb, c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, & - gam, hi, hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, & - hiyik0, hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, & - hjxjk, hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, & - HJZIJ1, HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, & - hkyik0, hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, & - invrij, invrija, invrik, invrika, invrjk, invrjka, ra, ramda, refi, refj - REAL(8) :: refk, rij, rija, rik, rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk - - PARAMETER(gam=1.2d0, ramda=21.0d0, aa=7.049556277d0) - PARAMETER(ra=1.8d0, bb=0.6022245584d0) + REAL(KIND=dp) :: c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, hi, & + hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, hiyik0, & + hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, hjxjk, & + hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, HJZIJ1, & + HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, hkyik0, & + hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, invrij, & + invrija, invrik, invrika, invrjk, invrjka, refi, refj, refk, rij, rija, rik + REAL(KIND=dp) :: rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -4073,11 +4010,11 @@ CONTAINS yij = rel(2, l)*rij zij = rel(3, l)*rij - IF (rij >= 2.d0*ra) CYCLE + IF (rij >= 2._dp*ra) CYCLE IF (rij < ra) THEN - crainv = 1.0d0/(rij - ra) + crainv = 1.0_dp/(rij - ra) c4 = rij*rij*rij*rij - force = aa*bb*4.0d0/(c4*rij)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv + force = aa*bb*4.0_dp/(c4*rij)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv fx(i) = force*xij*invrij + fx(i) fy(i) = force*yij*invrij + fy(i) @@ -4087,7 +4024,7 @@ CONTAINS fy(j) = -force*yij*invrij + fy(j) fz(j) = -force*zij*invrij + fz(j) - p = p + aa*(bb/(rij*rij*rij*rij) - 1.0d0)*dexp(1.0d0/(rij - ra)) + p = p + aa*(bb/(rij*rij*rij*rij) - 1.0_dp)*EXP(1.0_dp/(rij - ra)) nij = 1 END IF @@ -4108,42 +4045,42 @@ CONTAINS zjk = zik - zij rjk = SQRT(xjk*xjk + yjk*yjk + zjk*zjk) - invrjk = 1.d0/rjk + invrjk = 1._dp/rjk IF ((rjk >= ra) .AND. (nij == 0)) CYCLE cosjik = (xij*xik + yij*yik + zij*zik)*(invrij*invrik) cosijk = (-xij*xjk - yij*yjk - zij*zjk)*(invrij*invrjk) cosikj = (xik*xjk + yik*yjk + zik*zjk)*(invrik*invrjk) - cosjik3 = cosjik + 1.0d0/3.0d0 - cosijk3 = cosijk + 1.0d0/3.0d0 - cosikj3 = cosikj + 1.0d0/3.0d0 + cosjik3 = cosjik + 1.0_dp/3.0_dp + cosijk3 = cosijk + 1.0_dp/3.0_dp + cosikj3 = cosikj + 1.0_dp/3.0_dp rija = rij - ra rika = rik - ra rjka = rjk - ra - invrija = 1.d0/rija - invrika = 1.d0/rika - invrjka = 1.d0/rjka + invrija = 1._dp/rija + invrika = 1._dp/rika + invrjka = 1._dp/rjka - IF (rija >= 0.0d0) THEN - refi = 0.0d0 - refj = 0.0d0 + IF (rija >= 0.0_dp) THEN + refi = 0.0_dp + refj = 0.0_dp refk = ramda*EXP(gam*invrika + gam*invrjka) - ELSE IF ((rija < 0.0d0) .AND. (rika < 0.0d0)) THEN - IF (rjka < 0.0d0) THEN + ELSE IF ((rija < 0.0_dp) .AND. (rika < 0.0_dp)) THEN + IF (rjka < 0.0_dp) THEN refi = ramda*EXP(gam*invrija + gam*invrika) refj = ramda*EXP(gam*invrija + gam*invrjka) refk = ramda*EXP(gam*invrika + gam*invrjka) ELSE refi = ramda*EXP(gam*invrija + gam*invrika) - refj = 0.0d0 - refk = 0.0d0 + refj = 0.0_dp + refk = 0.0_dp END IF - ELSE IF ((rija < 0.0d0) .AND. (rjka < 0.0d0)) THEN - refi = 0.0d0 + ELSE IF ((rija < 0.0_dp) .AND. (rjka < 0.0_dp)) THEN + refi = 0.0_dp refj = ramda*EXP(gam*invrija + gam*invrjka) - refk = 0.0d0 + refk = 0.0_dp ELSE CYCLE END IF @@ -4153,60 +4090,60 @@ CONTAINS hk = refk*cosikj3*cosikj3 p3 = p3 + hi + hj + hk - hixij0 = 2.0d0*(xik*invrik - xij*cosjik*invrij) + hixij0 = 2.0_dp*(xik*invrik - xij*cosjik*invrij) hixij1 = gam*xij*cosjik3*(invrija*invrija) hixij = refi*cosjik3*(hixij0 - hixij1)*invrij - hixik0 = 2.0d0*(xij*invrij - xik*cosjik*invrik) + hixik0 = 2.0_dp*(xij*invrij - xik*cosjik*invrik) hixik1 = gam*xik*cosjik3*(invrika*invrika) hixik = refi*cosjik3*(hixik0 - hixik1)*invrik - hjxij0 = 2.0d0*(-xjk*invrjk - xij*cosijk*invrij) + hjxij0 = 2.0_dp*(-xjk*invrjk - xij*cosijk*invrij) hjxij1 = gam*xij*cosijk3*(invrija*invrija) hjxij = refj*cosijk3*(hjxij0 - hjxij1)*invrij - hkxik0 = 2.0d0*(xjk*invrjk - xik*cosikj*invrik) + hkxik0 = 2.0_dp*(xjk*invrjk - xik*cosikj*invrik) hkxik1 = gam*xik*cosikj3*(invrika*invrika) hkxik = refk*cosikj3*(hkxik0 - hkxik1)*invrik - hjxjk0 = 2.0d0*(-xij*invrij - xjk*cosijk*invrjk) + hjxjk0 = 2.0_dp*(-xij*invrij - xjk*cosijk*invrjk) hjxjk1 = gam*xjk*cosijk3*(invrjka*invrjka) hjxjk = refj*cosijk3*(hjxjk0 - hjxjk1)*invrjk - hkxkj0 = 2.0d0*(-xik*invrik + xjk*cosikj*invrjk) + hkxkj0 = 2.0_dp*(-xik*invrik + xjk*cosikj*invrjk) hkxkj1 = gam*xjk*cosikj3*(invrjka*invrjka) hkxkj = refk*cosikj3*(hkxkj0 + hkxkj1)*invrjk - hiyij0 = 2.0d0*(yik*invrik - yij*cosjik*invrij) + hiyij0 = 2.0_dp*(yik*invrik - yij*cosjik*invrij) hiyij1 = gam*yij*cosjik3*(invrija*invrija) hiyij = refi*cosjik3*(hiyij0 - hiyij1)*invrij - hiyik0 = 2.0d0*(yij*invrij - yik*cosjik*invrik) + hiyik0 = 2.0_dp*(yij*invrij - yik*cosjik*invrik) hiyik1 = gam*yik*cosjik3*(invrika*invrika) hiyik = refi*cosjik3*(hiyik0 - hiyik1)*invrik - hjyij0 = 2.0d0*(-yjk*invrjk - yij*cosijk*invrij) + hjyij0 = 2.0_dp*(-yjk*invrjk - yij*cosijk*invrij) hjyij1 = gam*yij*cosijk3*(invrija*invrija) hjyij = refj*cosijk3*(hjyij0 - hjyij1)*invrij - hkyik0 = 2.0d0*(yjk*invrjk - yik*cosikj*invrik) + hkyik0 = 2.0_dp*(yjk*invrjk - yik*cosikj*invrik) hkyik1 = gam*yik*cosikj3*(invrika*invrika) hkyik = refk*cosikj3*(hkyik0 - hkyik1)*invrik - hjyjk0 = 2.0d0*(-yij*invrij - yjk*cosijk*invrjk) + hjyjk0 = 2.0_dp*(-yij*invrij - yjk*cosijk*invrjk) hjyjk1 = gam*yjk*cosijk3*(invrjka*invrjka) hjyjk = refj*cosijk3*(hjyjk0 - hjyjk1)*invrjk - hkykj0 = 2.0d0*(-yik*invrik + yjk*cosikj*invrjk) + hkykj0 = 2.0_dp*(-yik*invrik + yjk*cosikj*invrjk) hkykj1 = gam*yjk*cosikj3*(invrjka*invrjka) hkykj = refk*cosikj3*(hkykj0 + hkykj1)*invrjk - hizij0 = 2.0d0*(zik*invrik - zij*cosjik*invrij) + hizij0 = 2.0_dp*(zik*invrik - zij*cosjik*invrij) hizij1 = gam*zij*cosjik3*(invrija*invrija) hizij = refi*cosjik3*(hizij0 - hizij1)*invrij - hizik0 = 2.0d0*(zij*invrij - zik*cosjik*invrik) + hizik0 = 2.0_dp*(zij*invrij - zik*cosjik*invrik) hizik1 = gam*zik*cosjik3*(invrika*invrika) hizik = refi*cosjik3*(hizik0 - hizik1)*invrik - hjzij0 = 2.0d0*(-zjk*invrjk - zij*cosijk*invrij) + hjzij0 = 2.0_dp*(-zjk*invrjk - zij*cosijk*invrij) hjzij1 = gam*zij*cosijk3*(invrija*invrija) hjzij = refj*cosijk3*(hjzij0 - hjzij1)*invrij - hkzik0 = 2.0d0*(zjk*invrjk - zik*cosikj*invrik) + hkzik0 = 2.0_dp*(zjk*invrjk - zik*cosikj*invrik) hkzik1 = gam*zik*cosikj3*(invrika*invrika) hkzik = refk*cosikj3*(hkzik0 - hkzik1)*invrik - hjzjk0 = 2.0d0*(-zij*invrij - zjk*cosijk*invrjk) + hjzjk0 = 2.0_dp*(-zij*invrij - zjk*cosijk*invrjk) hjzjk1 = gam*zjk*cosijk3*(invrjka*invrjka) hjzjk = refj*cosijk3*(hjzjk0 - hjzjk1)*invrjk - hkzkj0 = 2.0d0*(-zik*invrik + zjk*cosikj*invrjk) + hkzkj0 = 2.0_dp*(-zik*invrik + zjk*cosikj*invrjk) hkzkj1 = gam*zjk*cosikj3*(invrjka*invrjka) hkzkj = refk*cosikj3*(hkzkj0 + hkzkj1)*invrjk @@ -4251,32 +4188,32 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, real(8) : total potential energy, 2-body and 3-body, in eV -! count, real(8) : increased by 1.d0 at each call of this subroutine, -! needs to be initialized to 0.d0 before calling this routine for the first time +! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV +! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, +! needs to be initialized to 0._dp before calling this routine for the first time !***************************************************************************************** INTEGER :: nat - REAL(8) :: alat(3), rxyz(3, nat), fxyz(3, nat), & + REAL(KIND=dp) :: alat(3), rxyz(3, nat), fxyz(3, nat), & etot, count INTEGER :: iat, NNmax, Npmax INTEGER, ALLOCATABLE, DIMENSION(:) :: Kinds, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - REAL(8) :: Uatot, Urtot, xbox, ybox, zbox - REAL(8), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf - REAL(8), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn - REAL(8), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X + REAL(KIND=dp) :: Uatot, Urtot, xbox, ybox, zbox + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf + REAL(KIND=dp), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn + REAL(KIND=dp), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X INTEGER:: nnbrx, nnbrxt INTEGER :: i - count = count + 1.d0 + count = count + 1._dp DO iat = 1, nat rxyz(1, iat) = MODULO(MODULO(rxyz(1, iat), alat(1)), alat(1)) @@ -4296,7 +4233,7 @@ CONTAINS DO i = 1, nat kinds(i) = 2 !Since all atoms are Si, all of kind 2 END DO - fxyz = 0.0d0 + fxyz = 0.0_dp xbox = alat(1); ybox = alat(2); zbox = alat(3) CALL tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) CALL tersoff_pairlist_energy_forces(nat, Npmax, NNmax, xbox, ybox, zbox, Kinds, rxyz, R1, R2, Cr, & @@ -4324,14 +4261,15 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) - REAL(8), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X - REAL(8), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass + REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X + REAL(KIND=dp), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass - REAL(8), PARAMETER :: C_ala = 2.2119d0, C_alr = 3.4879d0, C_b = 1.5724d-7, C_c = 3.8049d4, & - C_Ca = 3.4674d2, C_Cr = 1.3936d3, C_d = 4.3484d0, C_h = -5.7058d-1, C_mass = 12.0d0, & - C_n = 7.2751d-1, C_R1 = 1.8d0, C_R2 = 2.1d0, Si_ala = 1.7322d0, Si_alr = 2.4799d0, & - Si_b = 1.1000d-6, Si_c = 1.0039d5, Si_Ca = 4.7118d2, Si_Cr = 1.8308d3, Si_d = 1.6217d1, & - Si_h = -5.9825d-1, Si_mass = 28.0855d0, Si_n = 7.8734d-1, Si_R1 = 2.7d0, Si_R2 = 3.3d0 + REAL(KIND=dp), PARAMETER :: C_ala = 2.2119_dp, C_alr = 3.4879_dp, C_b = 1.5724e-7_dp, & + C_c = 3.8049e4_dp, C_Ca = 3.4674e2_dp, C_Cr = 1.3936e3_dp, C_d = 4.3484_dp, & + C_h = -5.7058e-1_dp, C_mass = 12.0_dp, C_n = 7.2751e-1_dp, C_R1 = 1.8_dp, C_R2 = 2.1_dp, & + Si_ala = 1.7322_dp, Si_alr = 2.4799_dp, Si_b = 1.1000e-6_dp, Si_c = 1.0039e5_dp, & + Si_Ca = 4.7118e2_dp, Si_Cr = 1.8308e3_dp, Si_d = 1.6217e1_dp, Si_h = -5.9825e-1_dp, & + Si_mass = 28.0855_dp, Si_n = 7.8734e-1_dp, Si_R1 = 2.7_dp, Si_R2 = 3.3_dp !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version @@ -4345,48 +4283,48 @@ CONTAINS !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version -!Increased Cutoff, originally 3.0d0 +!Increased Cutoff, originally 3.0_dp Cr(1, 1) = C_Cr Cr(2, 2) = Si_Cr - Cr(1, 2) = dsqrt(Cr(1, 1)*Cr(2, 2)) + Cr(1, 2) = SQRT(Cr(1, 1)*Cr(2, 2)) Cr(2, 1) = Cr(1, 2) Ca(1, 1) = C_Ca Ca(2, 2) = Si_Ca - Ca(1, 2) = dsqrt(Ca(1, 1)*Ca(2, 2)) + Ca(1, 2) = SQRT(Ca(1, 1)*Ca(2, 2)) Ca(2, 1) = Ca(1, 2) R1(1, 1) = C_R1 R1(2, 2) = Si_R1 - R1(1, 2) = dsqrt(R1(1, 1)*R1(2, 2)) + R1(1, 2) = SQRT(R1(1, 1)*R1(2, 2)) R1(2, 1) = R1(1, 2) R2(1, 1) = C_R2 R2(2, 2) = Si_R2 - R2(1, 2) = dsqrt(R2(1, 1)*R2(2, 2)) + R2(1, 2) = SQRT(R2(1, 1)*R2(2, 2)) R2(2, 1) = R2(1, 2) - X(1, 1) = 1.0d0 - X(2, 2) = 1.0d0 - X(1, 2) = 0.9776d0 - X(2, 1) = 0.9776d0 + X(1, 1) = 1.0_dp + X(2, 2) = 1.0_dp + X(1, 2) = 0.9776_dp + X(2, 1) = 0.9776_dp alr(1, 1) = C_alr alr(2, 2) = Si_alr - alr(1, 2) = 0.5d0*(alr(1, 1) + alr(2, 2)) + alr(1, 2) = 0.5_dp*(alr(1, 1) + alr(2, 2)) alr(2, 1) = alr(1, 2) ala(1, 1) = C_ala ala(2, 2) = Si_ala - ala(1, 2) = 0.5d0*(ala(1, 1) + ala(2, 2)) + ala(1, 2) = 0.5_dp*(ala(1, 1) + ala(2, 2)) ala(2, 1) = ala(1, 2) Pn(1) = C_n Pn(2) = Si_n - Co_bcd(1) = C_b*(1.0d0 + C_c*C_c/(C_d*C_d)) - Co_bcd(2) = Si_b*(1.0d0 + Si_c*Si_c/(Si_d*Si_d)) + Co_bcd(1) = C_b*(1.0_dp + C_c*C_c/(C_d*C_d)) + Co_bcd(2) = Si_b*(1.0_dp + Si_c*Si_c/(Si_d*Si_d)) bcsq(1) = C_b*C_c*C_c bcsq(2) = Si_b*Si_c*Si_c @@ -4439,35 +4377,32 @@ CONTAINS XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, & Pn, Co_bcd, bcsq, dsq, h, F, Uatot, dkEij) INTEGER, INTENT(in) :: Nmol, Npmax, NNmax - REAL(8), INTENT(in) :: xbox, ybox, zbox + REAL(KIND=dp), INTENT(in) :: xbox, ybox, zbox INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(8), DIMENSION(1:3*Nmol), INTENT(in) :: R - REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X - REAL(8), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf - REAL(8), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf - REAL(8), INTENT(out) :: Urtot + REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(in) :: R + REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X + REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf + REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf + REAL(KIND=dp), INTENT(out) :: Urtot INTEGER :: lsta(2, Nmol) INTEGER, INTENT(inout) :: nnbrx INTEGER :: lstb(nnbrx*Nmol) - REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(8), DIMENSION(1:3*Nmol), INTENT(out) :: F - REAL(8), INTENT(out) :: Uatot - REAL(8), DIMENSION(1:3*NNmax) :: dkEij + REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(out) :: F + REAL(KIND=dp), INTENT(out) :: Uatot + REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij INTEGER :: i, iam, iat, ii, il, in, indlst, indlstx, Ipb, istopg, jat, l1, l2, l3, laymx, & ll1, ll2, ll3, myspace, myspaceout, nat, ncx, ndat, nn, npjkx, npjx, npr, Nptot INTEGER, ALLOCATABLE, DIMENSION(:) :: lay INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(8) :: alat(3), cut, cut2, pi, rlc1i, rlc2i, & - rlc3i, rxyz0(3, Nmol), xhalf, yhalf, & - zhalf - REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(KIND=dp) :: alat(3), cut, cut2, rlc1i, rlc2i, rlc3i, & + rxyz0(3, Nmol), xhalf, yhalf, zhalf + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - pi = dacos(-1.0d0) - - xhalf = 0.5d0*xbox - yhalf = 0.5d0*ybox - zhalf = 0.5d0*zbox + xhalf = 0.5_dp*xbox + yhalf = 0.5_dp*ybox + zhalf = 0.5_dp*zbox nat = Nmol @@ -4950,29 +4885,28 @@ CONTAINS istopg = 0 !end of creating pairlist part------------------------------------------------------------ !Energy----------------------------------------------------------------------------------- - Urtot = 0.0d0 + Urtot = 0.0_dp Nptot = 0 - F = 0.0d0 - Uatot = 0.0d0 + F = 0.0_dp + Uatot = 0.0_dp DO_I: DO i = 1, Nmol - CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel, pi) + CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) END DO DO_I - Urtot = 0.5d0*Urtot + Urtot = 0.5_dp*Urtot !Force------------------------------------------------------------------------------------ - F = 0.0d0 - Uatot = 0.0d0 + F = 0.0_dp + Uatot = 0.0_dp DO_If: DO i = 1, Nmol CALL tersoff_subfiat_l(i,Nmol,Npmax,NNmax,Kinds,Pn,Co_bcd,bcsq,dsq,h,XYZRrefdf,UadUrdf,F,Uatot,dkEij,lsta,lstb,nnbrx) END DO DO_If - F = 0.5d0*F - Uatot = 0.5d0*Uatot + F = 0.5_dp*F + Uatot = 0.5_dp*Uatot !----------------------------------------------------------------------------------------- DEALLOCATE (rxyz, icell, lay, rel) - RETURN END SUBROUTINE tersoff_pairlist_energy_forces !----------------------------------------------------------------------------------------- @@ -5002,13 +4936,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(8) :: rxyz(3, nn) + REAL(KIND=dp) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(8) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(8) :: rr2, tt, tti, xrel, yrel, zrel + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -5025,7 +4959,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1.d0/tt + tti = 1._dp/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -5061,22 +4995,20 @@ CONTAINS !> \param lstb ... !> \param nnbrx ... !> \param rel ... -!> \param pi ... ! ************************************************************************************************** - SUBROUTINE tersoff_subeniat_l(i,Nmol,Npmax,Kinds,X,R1,R2,Cr,Ca,alr,ala,XYZRrefdf,UadUrdf,Urtot,lsta,lstb,nnbrx,rel,pi) +SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala - REAL(8), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf - REAL(8), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf - REAL(8), INTENT(inout) :: Urtot + REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala + REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf + REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf + REAL(KIND=dp), INTENT(inout) :: Urtot INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) - REAL(8), INTENT(in) :: rel(5, nnbrx*Nmol) - REAL(8) :: pi + REAL(KIND=dp), INTENT(in) :: rel(5, nnbrx*Nmol) INTEGER :: j, Ki, Kj, l, Nppt3, Nppt6, Nptot - REAL(8) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & + REAL(KIND=dp) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & R2ij, Rij, Rreij, Ua, Ur, Xij, Yij, Zij ! ####################################### @@ -5107,13 +5039,13 @@ CONTAINS alrij = alr(Ki, Kj) alaij = ala(Ki, Kj) - Ur = Cr(Ki, Kj)*dexp(-alrij*Rij) - Ua = -Ca(Ki, Kj)*dexp(-alaij*Rij)*X(Ki, Kj) + Ur = Cr(Ki, Kj)*EXP(-alrij*Rij) + Ua = -Ca(Ki, Kj)*EXP(-alaij*Rij)*X(Ki, Kj) R1ij = R1(Ki, Kj) IF (Rij <= R1ij) THEN - XYZRrefdf(Nppt6 + 5) = 1.0d0 - XYZRrefdf(Nppt6 + 6) = 0.0d0 + XYZRrefdf(Nppt6 + 5) = 1.0_dp + XYZRrefdf(Nppt6 + 6) = 0.0_dp Urtot = Urtot + Ur UadUrdf(Nppt3 + 1) = Ua UadUrdf(Nppt3 + 2) = -alrij*Ur @@ -5121,8 +5053,8 @@ CONTAINS ELSE PL1 = pi/(R2ij - R1ij) PL2 = PL1*(Rij - R1ij) - fij = 0.5d0 + 0.5d0*dcos(PL2) - dfij = -0.5d0*PL1*dsin(PL2) + fij = 0.5_dp + 0.5_dp*COS(PL2) + dfij = -0.5_dp*PL1*SIN(PL2) XYZRrefdf(Nppt6 + 5) = fij XYZRrefdf(Nppt6 + 6) = dfij Urtot = Urtot + fij*Ur @@ -5158,20 +5090,20 @@ CONTAINS INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax, NNmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(8), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf - REAL(8), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf - REAL(8), DIMENSION(1:3*Nmol), INTENT(inout) :: F - REAL(8), INTENT(inout) :: Uatot - REAL(8), DIMENSION(1:3*NNmax) :: dkEij + REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf + REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf + REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(inout) :: F + REAL(KIND=dp), INTENT(inout) :: Uatot + REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) INTEGER :: ij, ijpt3, ijpt6, ik, ikpt6, Ipb, Ipe, & Ipt3, Jpt3, Ki, Kpt3, Nkpt3 - REAL(8) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, Co_mb2, & - Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, dGi, & - djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, Rreij, & - Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik + REAL(KIND=dp) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, & + Co_mb2, Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, & + dGi, djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, & + Rreij, Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -5184,9 +5116,9 @@ CONTAINS Co_cdi = Co_bcd(Ki) - dFxi = 0.0d0 - dFyi = 0.0d0 - dFzi = 0.0d0 + dFxi = 0.0_dp + dFyi = 0.0_dp + dFzi = 0.0_dp DO_J: DO ij = Ipb, Ipe, +1 @@ -5200,11 +5132,11 @@ CONTAINS fij = XYZRrefdf(IJpt6 + 5) dfij = XYZRrefdf(IJpt6 + 6) - Eij = 0.0d0 - djEij = 0.0d0 - dXjEij2 = 0.0d0 - dYjEij2 = 0.0d0 - dZjEij2 = 0.0d0 + Eij = 0.0_dp + djEij = 0.0_dp + dXjEij2 = 0.0_dp + dYjEij2 = 0.0_dp + dZjEij2 = 0.0_dp Nkpt3 = -3 DO_K: DO ik = Ipb, Ipe, +1 @@ -5225,9 +5157,9 @@ CONTAINS COSijk = XRreij*XRreik + YRreij*YRreik + ZRreij*ZRreik Co_hcosi = hi - COSijk - Co_dhcosi = 1.0d0/(dsqi + Co_hcosi*Co_hcosi) + Co_dhcosi = 1.0_dp/(dsqi + Co_hcosi*Co_hcosi) Gi = -bcsqi*Co_dhcosi - dGi = 2.0d0*Co_hcosi*Co_dhcosi*Gi + dGi = 2.0_dp*Co_hcosi*Co_dhcosi*Gi Gi = Gi + Co_cdi Eij = Eij + fik*Gi @@ -5249,22 +5181,22 @@ CONTAINS dkEij(Nkpt3 + 3) = Co1_dkEij*ZRreik + Co2_dkEij*ZRreij ELSE - dkEij(Nkpt3 + 1) = 0.0d0 - dkEij(Nkpt3 + 2) = 0.0d0 - dkEij(Nkpt3 + 3) = 0.0d0 + dkEij(Nkpt3 + 1) = 0.0_dp + dkEij(Nkpt3 + 2) = 0.0_dp + dkEij(Nkpt3 + 3) = 0.0_dp END IF IKIJ END DO DO_K - Bij = 1.0d0 + Eij**Pni - Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5d0/Pni) + Bij = 1.0_dp + Eij**Pni + Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5_dp/Pni) Uatot = Uatot + Ua - Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5d0/Pni) + Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5_dp/Pni) CEij: IF (Nkpt3 > 0) THEN - Co_mb1 = Ua*0.5d0*Eij**(Pni - 1.0d0)/Bij + Co_mb1 = Ua*0.5_dp*Eij**(Pni - 1.0_dp)/Bij Co_mb2 = Co_mb1*Rreij Nkpt3 = -3 diff --git a/src/emd/rt_bse_types.F b/src/emd/rt_bse_types.F index 7688b6c8d8..b9b647119f 100644 --- a/src/emd/rt_bse_types.F +++ b/src/emd/rt_bse_types.F @@ -99,7 +99,8 @@ MODULE rt_bse_types !> \param dft_control DFT control parameters !> \param ham_effective Real and imaginary part of the effective Hamiltonian used to propagate !> the density matrix -!> \param ham_reference Reference Hamiltonian, which does not change in the propagation = DFT+G0W0 - initial Hartree - initial COHSEX +!> \param ham_reference Reference Hamiltonian, which does not change in the +!> propagation = DFT+G0W0 - initial Hartree - initial COHSEX !> \param ham_workspace Workspace matrices for use with the Hamiltonian propagation - storage of !> exponential propagators etc. !> \param rho Density matrix at the current time step @@ -145,7 +146,7 @@ MODULE rt_bse_types moments_field => NULL() INTEGER :: sim_step = 0, & sim_start = 0, & - ! Needed for continuation runs for loading of previous moments trace + ! Needed to continue runs by loading previous moments trace sim_start_orig = 0, & sim_nsteps = -1, & ! Default reference point type for output moments diff --git a/src/emd/rt_delta_pulse.F b/src/emd/rt_delta_pulse.F index 8bf9e04b2e..f768c0abae 100644 --- a/src/emd/rt_delta_pulse.F +++ b/src/emd/rt_delta_pulse.F @@ -159,8 +159,9 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_old=mos_old, mos_new=mos_new) IF (rtp_control%apply_delta_pulse) THEN - IF (dft_control%qs_control%dftb) & + IF (dft_control%qs_control%dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) + END IF IF (rtp_control%periodic) THEN IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T40))") & diff --git a/src/emd/rt_projection_mo_utils.F b/src/emd/rt_projection_mo_utils.F index 36e8080ca9..60ea2ff4aa 100644 --- a/src/emd/rt_projection_mo_utils.F +++ b/src/emd/rt_projection_mo_utils.F @@ -103,9 +103,10 @@ CONTAINS i_val=proj_mo%ref_nlumo) ! Relevent only in EMD - IF (.NOT. rtp_control%fixed_ions) & + IF (.NOT. rtp_control%fixed_ions) THEN CALL section_vals_val_get(proj_mo_section, "PROPAGATE_REF", i_rep_section=i_rep, & l_val=proj_mo%propagate_ref) + END IF ! If no reference .wfn is provided, using the restart SCF file: IF (proj_mo%ref_mo_file_name == "DEFAULT") THEN @@ -136,11 +137,12 @@ CONTAINS CALL section_vals_val_get(proj_mo_section, "TD_MO_SPIN", i_rep_section=i_rep, & i_val=proj_mo%td_mo_spin) - IF (proj_mo%td_mo_spin > SIZE(mos)) & + IF (proj_mo%td_mo_spin > SIZE(mos)) THEN CALL cp_abort(__LOCATION__, & "You asked to project the time dependent BETA spin while the "// & "real time DFT run has only one spin defined. "// & "Please set TD_MO_SPIN to 1 or use UKS.") + END IF CALL section_vals_val_get(proj_mo_section, "TD_MO_INDEX", i_rep_section=i_rep, & i_vals=tmp_ints) @@ -160,10 +162,11 @@ CONTAINS ALLOCATE (proj_mo%td_mo_occ(SIZE(proj_mo%td_mo_index))) proj_mo%td_mo_occ(:) = 0.0_dp DO j_td = 1, SIZE(proj_mo%td_mo_index) - IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) & + IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) THEN CALL cp_abort(__LOCATION__, & "The MO number available in the Time Dependent run "// & "is smaller than the MO number you have required in TD_MO_INDEX.") + END IF proj_mo%td_mo_occ(j_td) = mos(proj_mo%td_mo_spin)%occupation_numbers(proj_mo%td_mo_index(j_td)) END DO END IF @@ -237,9 +240,10 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(proj_mo%ref_mo_file_name), exist=is_file) - IF (.NOT. is_file) & + IF (.NOT. is_file) THEN CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(proj_mo%ref_mo_file_name)) + END IF CALL open_file(file_name=proj_mo%ref_mo_file_name, & file_action="READ", & @@ -254,10 +258,11 @@ CONTAINS IF (para_env%is_source()) CALL close_file(unit_number=restart_unit) - IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) & + IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) THEN CALL cp_abort(__LOCATION__, & "Projection on spin BETA is not possible as the reference wavefunction "// & "only has one spin channel. Use a reference .wfn calculated with UKS/LSD, or set REF_MO_SPIN to 1") + END IF ! Store only the mos required nbr_mo_max = mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%ncol_global @@ -269,19 +274,21 @@ CONTAINS END DO ELSE DO i_ref = 1, SIZE(proj_mo%ref_mo_index) - IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) & + IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) THEN CALL cp_abort(__LOCATION__, & "The number of MOs available in the reference wavefunction "// & "is smaller than the MO number you have requested in REF_MO_INDEX.") + END IF END DO END IF nbr_ref_mo = SIZE(proj_mo%ref_mo_index) - IF (nbr_ref_mo > nbr_mo_max) & + IF (nbr_ref_mo > nbr_mo_max) THEN CALL cp_abort(__LOCATION__, & "The total number of requested MOs is larger than what is available in the reference wavefunction. "// & "If you are trying to project onto virtual states, make sure they are included in the .wfn file "// & "e.g., by the ADDED_MOS keyword in the SCF section of the input when calculating your reference.") + END IF ! Store ALLOCATE (proj_mo%mo_ref(nbr_ref_mo)) @@ -290,14 +297,16 @@ CONTAINS nrow_global=mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%nrow_global, & ncol_global=1) - IF (dft_control%rtp_control%fixed_ions) & + IF (dft_control%rtp_control%fixed_ions) THEN CALL cp_fm_create(mo_coeff_temp, mo_ref_fmstruct, 'mo_ref') + END IF DO mo_index = 1, nbr_ref_mo real_mo_index = proj_mo%ref_mo_index(mo_index) - IF (real_mo_index > nbr_mo_max) & + IF (real_mo_index > nbr_mo_max) THEN CALL cp_abort(__LOCATION__, & "One of reference mo index is larger then the total number of available mo in the .wfn file.") + END IF ! fill with the reference mo values CALL cp_fm_create(proj_mo%mo_ref(mo_index), mo_ref_fmstruct, 'mo_ref') @@ -324,8 +333,9 @@ CONTAINS DEALLOCATE (mo_ref_temp) CALL cp_fm_struct_release(mo_ref_fmstruct) - IF (dft_control%rtp_control%fixed_ions) & + IF (dft_control%rtp_control%fixed_ions) THEN CALL cp_fm_release(mo_coeff_temp) + END IF END SUBROUTINE read_reference_mo_from_wfn @@ -372,8 +382,9 @@ CONTAINS ! Does not compute the projection if not the required time step IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & print_mo_section, ""), & - cp_p_file)) & + cp_p_file)) THEN RETURN + END IF IF (.NOT. dft_control%rtp_control%fixed_ions) THEN CALL get_qs_env(qs_env, & diff --git a/src/emd/rt_propagation_methods.F b/src/emd/rt_propagation_methods.F index fe656f3197..95cde86d30 100644 --- a/src/emd/rt_propagation_methods.F +++ b/src/emd/rt_propagation_methods.F @@ -165,12 +165,14 @@ CONTAINS ! either in the lengh or velocity gauge. ! should be called after qs_energies_init and before qs_ks_update_qs_env IF (dft_control%apply_efield_field) THEN - IF (ANY(cell%perd(1:3) /= 0)) & + IF (ANY(cell%perd(1:3) /= 0)) THEN CPABORT("Length gauge (efield) and periodicity are not compatible") + END IF CALL efield_potential_lengh_gauge(qs_env) ELSE IF (rtp_control%velocity_gauge) THEN - IF (dft_control%apply_vector_potential) & + IF (dft_control%apply_vector_potential) THEN CALL update_vector_potential(qs_env, dft_control) + END IF CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) END IF @@ -408,8 +410,9 @@ CONTAINS DO i = 1, SIZE(exp_H_new) CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_new(i)%matrix, 0.0_dp, prefac) - IF (propagator == do_em) & + IF (propagator == do_em) THEN CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_old(i)%matrix, 1.0_dp, prefac) + END IF END DO CALL timestop(handle) diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index 1cee221fad..8a78ff7660 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -197,19 +197,23 @@ CONTAINS REAL(n_electrons, dp) WRITE (UNIT=output_unit, FMT="((T3,A,T59,F22.14))") & "Total energy:", rtp%energy_new - IF (run_type == ehrenfest) & + IF (run_type == ehrenfest) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old - IF (run_type == real_time_propagation) & + "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old + END IF + IF (run_type == real_time_propagation) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to initial state:", rtp%energy_new - rtp%energy_old - IF (PRESENT(delta_iter)) & + "Energy difference to initial state:", rtp%energy_new - rtp%energy_old + END IF + IF (PRESENT(delta_iter)) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,E20.6))") & - "Convergence:", delta_iter + "Convergence:", delta_iter + END IF IF (rtp%converged) THEN - IF (run_type == real_time_propagation) & + IF (run_type == real_time_propagation) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,F12.2))") & - "Time needed for propagation:", used_time + "Time needed for propagation:", used_time + END IF WRITE (UNIT=output_unit, FMT="(/,(T3,A,3X,F16.14))") & "CONVERGENCE REACHED", rtp%energy_new - rtp%energy_old END IF @@ -220,22 +224,25 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_new=mos_new) CALL rt_calculate_orthonormality(orthonormality, & mos_new, matrix_s(1)%matrix) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, FMT="(/,(T3,A,T60,F20.10))") & - "Max deviation from orthonormalization:", orthonormality + "Max deviation from orthonormalization:", orthonormality + END IF END IF END IF - IF (output_unit > 0) & + IF (output_unit > 0) THEN CALL m_flush(output_unit) + END IF CALL cp_print_key_finished_output(output_unit, logger, rtp_section, & "PRINT%PROGRAM_RUN_INFO") IF (rtp%converged) THEN dft_section => section_vals_get_subs_vals(input, "DFT") IF (BTEST(cp_print_key_should_output(logger%iter_info, & - dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) & + dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) THEN CALL print_field_applied(qs_env, dft_section) + END IF CALL make_moment(qs_env) IF (BTEST(cp_print_key_should_output(logger%iter_info, & dft_section, "REAL_TIME_PROPAGATION%PRINT%E_CONSTITUENTS"), cp_p_file)) THEN @@ -406,9 +413,10 @@ CONTAINS rtp%energy_old = rtp%energy_new - IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) & + IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) THEN CALL cp_abort(__LOCATION__, "EMD did not converge, either increase MAX_ITER "// & "or use a smaller TIMESTEP") + END IF END SUBROUTINE rt_prop_output @@ -838,7 +846,7 @@ CONTAINS CHARACTER(len=14) :: ext CHARACTER(len=2) :: sdir INTEGER :: dir, handle, print_unit - INTEGER, DIMENSION(:), POINTER :: stride(:) + INTEGER, DIMENSION(:), POINTER :: stride LOGICAL :: mpi_io TYPE(cp_logger_type), POINTER :: logger TYPE(current_env_type) :: current_env @@ -886,7 +894,7 @@ CONTAINS IF (dir == 1) THEN sdir = "-x" - ELSEIF (dir == 2) THEN + ELSE IF (dir == 2) THEN sdir = "-y" ELSE sdir = "-z" diff --git a/src/emd/rt_propagation_utils.F b/src/emd/rt_propagation_utils.F index 6e6997f20e..431a2fefee 100644 --- a/src/emd/rt_propagation_utils.F +++ b/src/emd/rt_propagation_utils.F @@ -318,9 +318,10 @@ CONTAINS dft_section=dft_section) CALL set_uniform_occupation_mo_array(mo_array, nspin) - IF (dft_control%rtp_control%apply_wfn_mix_init_restart) & + IF (dft_control%rtp_control%apply_wfn_mix_init_restart) THEN CALL wfn_mix(mo_array, particle_set, dft_section, qs_kind_set, para_env, output_unit, & for_rtp=.TRUE.) + END IF DO ispin = 1, nspin CALL calculate_density_matrix(mo_array(ispin), p_rmpv(ispin)%matrix) @@ -423,8 +424,9 @@ CONTAINS DO mo = 1, mo_array(ispin)%nmo IF (mo_array(ispin)%occupation_numbers(mo) /= 0.0 .AND. & mo_array(ispin)%occupation_numbers(mo) /= 1.0 .AND. & - mo_array(ispin)%occupation_numbers(mo) /= 2.0) & + mo_array(ispin)%occupation_numbers(mo) /= 2.0) THEN is_uniform = .FALSE. + END IF END DO mo_array(ispin)%uniform_occupation = is_uniform END DO diff --git a/src/emd/rt_propagator_init.F b/src/emd/rt_propagator_init.F index 69e42afdd0..7d1cbfd570 100644 --- a/src/emd/rt_propagator_init.F +++ b/src/emd/rt_propagator_init.F @@ -161,7 +161,7 @@ CONTAINS DO imat = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(imat), mos_next(imat)) END DO - ELSEIF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN + ELSE IF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN ELSE IF (rtp%linear_scaling) THEN CALL compute_exponential_sparse(exp_H_new, propagator_matrix, rtp_control, rtp) diff --git a/src/energy_corrections.F b/src/energy_corrections.F index e0ea3c5191..e79c921c09 100644 --- a/src/energy_corrections.F +++ b/src/energy_corrections.F @@ -1726,7 +1726,7 @@ CONTAINS IF (dft_control%do_admm_mo) THEN CPASSERT(.NOT. qs_env%run_rtp) CALL admm_mo_calc_rho_aux(qs_env) - ELSEIF (dft_control%do_admm_dm) THEN + ELSE IF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF diff --git a/src/environment.F b/src/environment.F index f981bdf787..dfc1ca86d0 100644 --- a/src/environment.F +++ b/src/environment.F @@ -470,8 +470,9 @@ CONTAINS iw = cp_print_key_unit_nr(logger, root_section, "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG", & extension=".Log") - IF (iw > 0) & + IF (iw > 0) THEN CALL globenv%gaussian_rng_stream%write(iw, write_all=.TRUE.) + END IF CALL cp_print_key_finished_output(iw, logger, root_section, & "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG") @@ -594,8 +595,9 @@ CONTAINS IF (trace .AND. (.NOT. trace_master .OR. para_env%mepos == 0)) THEN unit_nr = -1 - IF (logger%para_env%is_source() .OR. .NOT. trace_master) & + IF (logger%para_env%is_source() .OR. .NOT. trace_master) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) + END IF WRITE (tracing_string, "(I6.6,A1,I6.6)") para_env%mepos, ":", para_env%num_pe IF (ASSOCIATED(trace_routines)) THEN CALL timings_setup_tracing(trace_max, unit_nr, tracing_string, trace_routines) @@ -682,8 +684,9 @@ CONTAINS CPABORT("FARMING program supports only NONE as run type") END IF - IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) & + IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) THEN CPABORT("TEST program supports only NONE as run type") + END IF CALL m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree) MemTotal_avr = MemTotal @@ -1231,8 +1234,9 @@ CONTAINS IF (ierr /= 0) CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') ELSE READ (txt(1:n), FMT="(I2,A1,I2,A1,I2)", IOSTAT=ierr) hours, c1, minutes, c2, seconds - IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") & + IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") THEN CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') + END IF walltime = 3600.0_dp*REAL(hours, dp) + 60.0_dp*REAL(minutes, dp) + REAL(seconds, dp) END IF END SUBROUTINE cp2k_get_walltime @@ -1331,15 +1335,18 @@ CONTAINS IF (cg_mode /= CALLGRAPH_NONE) THEN CALL section_vals_val_get(root_section, "GLOBAL%CALLGRAPH_FILE_NAME", c_val=cg_filename) IF (LEN_TRIM(cg_filename) == 0) cg_filename = TRIM(logger%iter_info%project_name) - IF (cg_mode == CALLGRAPH_ALL) & !incorporate mpi-rank into filename + IF (cg_mode == CALLGRAPH_ALL) THEN + !incorporate mpi-rank into filename cg_filename = TRIM(cg_filename)//"_"//TRIM(ADJUSTL(cp_to_string(para_env%mepos))) + END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,3X,A)") "Writing callgraph to: "//TRIM(cg_filename)//".callgraph" WRITE (UNIT=iw, FMT="()") WRITE (UNIT=iw, FMT="(T2,A)") "-------------------------------------------------------------------------------" END IF - IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) & + IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) THEN CALL timings_report_callgraph(TRIM(cg_filename)//".callgraph") + END IF END IF CALL cp_print_key_finished_output(iw, logger, root_section, & diff --git a/src/eri_mme/eri_mme_error_control.F b/src/eri_mme/eri_mme_error_control.F index 4c8a63e1c6..645678d1f4 100644 --- a/src/eri_mme/eri_mme_error_control.F +++ b/src/eri_mme/eri_mme_error_control.F @@ -92,13 +92,15 @@ CONTAINS max_iter = 100 - IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) & + IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) THEN CALL cp_abort(__LOCATION__, "difference of boundaries for cutoff "// & "(MAX - MIN) must be greater than cutoff precision.") + END IF - IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) & + IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) THEN CALL cp_abort(__LOCATION__, & "relative delta to modify initial cutoff interval (DELTA) must be in (0, 1)") + END IF cutoff_lr(1) = cutoff_l cutoff_lr(2) = cutoff_r @@ -113,10 +115,11 @@ CONTAINS ! 1) find valid initial values for bisection DO iter1 = 1, max_iter + 1 - IF (iter1 > max_iter) & + IF (iter1 > max_iter) THEN CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine initial "// & "cutoff interval has been exceeded.") + END IF cutoff_lr(1) = MAX(cutoff_lr(1), 0.5_dp*G_min**2) ! approx.) is hit @@ -144,9 +147,10 @@ CONTAINS "ERI_MME| Step, cutoff (min, max, mid), err(minimax), err(cutoff), err diff" DO iter2 = 1, max_iter + 1 - IF (iter2 > max_iter) & + IF (iter2 > max_iter) THEN CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine cutoff has been exceeded") + END IF cutoff_mid = 0.5_dp*(cutoff_lr(1) + cutoff_lr(2)) CALL cutoff_minimax_error(cutoff_mid, hmat, h_inv, vol, G_min, zet_min, l_mm, zet_max, l_max_zet, & @@ -337,9 +341,10 @@ CONTAINS gr = 0.5_dp*(SQRT(5.0_dp) - 1.0_dp) ! golden ratio ! Find valid starting values for golden section search DO iter = 1, max_iter + 1 - IF (iter > max_iter) & + IF (iter > max_iter) THEN CALL cp_abort(__LOCATION__, "Maximum number of iterations for finding "// & "exponent maximizing cutoff error has been exceeded.") + END IF CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_max_tmp, C, err_ctff_curr, para_env) IF (err_ctff_prev >= err_ctff_curr) THEN diff --git a/src/eri_mme/eri_mme_gaussian.F b/src/eri_mme/eri_mme_gaussian.F index fea8e96a21..1cde9784a6 100644 --- a/src/eri_mme/eri_mme_gaussian.F +++ b/src/eri_mme/eri_mme_gaussian.F @@ -133,7 +133,7 @@ CONTAINS CPASSERT(G_max > G_min) IF (potential_prv == eri_mme_coulomb .OR. potential_prv == eri_mme_longrange) THEN minimax_Rc = (G_max/G_min)**2 - ELSEIF (potential_prv == eri_mme_yukawa) THEN + ELSE IF (potential_prv == eri_mme_yukawa) THEN minimax_Rc = (G_max**2 + pot_par**2)/(G_min**2 + pot_par**2) END IF @@ -165,9 +165,9 @@ CONTAINS IF (PRESENT(err_minimax)) THEN IF (potential_prv == eri_mme_coulomb) THEN err_minimax = err_minimax/G_min**2 - ELSEIF (potential_prv == eri_mme_yukawa) THEN + ELSE IF (potential_prv == eri_mme_yukawa) THEN err_minimax = err_minimax/(G_min**2 + pot_par**2) - ELSEIF (potential_prv == eri_mme_longrange) THEN + ELSE IF (potential_prv == eri_mme_longrange) THEN err_minimax = err_minimax/G_min**2 ! approx. of Coulomb err_minimax = err_minimax*EXP(-G_min**2/pot_par**2) ! exponential factor END IF diff --git a/src/eri_mme/eri_mme_lattice_summation.F b/src/eri_mme/eri_mme_lattice_summation.F index 4fd3228772..a5f8da4731 100644 --- a/src/eri_mme/eri_mme_lattice_summation.F +++ b/src/eri_mme/eri_mme_lattice_summation.F @@ -89,7 +89,7 @@ CONTAINS IF (PRESENT(G_rad)) G_rad = exp_radius(l_max, alpha_G, sum_precision, 1.0_dp, epsabs=G_res) IF (PRESENT(R_rad)) R_rad = exp_radius(l_max, alpha_R, sum_precision, 1.0_dp, epsabs=R_res) - END SUBROUTINE + END SUBROUTINE eri_mme_2c_get_rads ! ************************************************************************************************** !> \brief Get summation radii for 3c integrals @@ -149,7 +149,7 @@ CONTAINS R_rads_3(2) = exp_radius(la_max + lb_max + lc_max, alpha_R, sum_precision, 1.0_dp, R_res) END IF - END SUBROUTINE + END SUBROUTINE eri_mme_3c_get_rads ! ************************************************************************************************** !> \brief Get summation bounds for 2c integrals @@ -212,7 +212,7 @@ CONTAINS n_sum_3d(2) = nsum_2c_rspace_3d(ns_R, la_max, lb_max) END IF - END SUBROUTINE + END SUBROUTINE eri_mme_2c_get_bounds ! ************************************************************************************************** !> \brief Get summation bounds for 3c integrals @@ -326,7 +326,7 @@ CONTAINS n_sum_3d(3) = nsum_3c_rspace_3d(ns3_R1, ns3_R2, la_max, lb_max, lc_max) END IF - END SUBROUTINE + END SUBROUTINE eri_mme_3c_get_bounds ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -341,7 +341,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_1d nsum_2c_gspace_1d = NINT(ns_G*(2*exp_w + (l + m + 1)*5), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_gspace_1d ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in G space in 1 dimension @@ -380,7 +380,7 @@ CONTAINS END DO END DO - S_G(:) = REAL(S_G_c(0:l_max)*i_pow((/(l, l=0, l_max)/)))*inv_lgth + S_G(:) = REAL(S_G_c(0:l_max)*i_pow([(l, l=0, l_max)]))*inv_lgth END SUBROUTINE pgf_sum_2c_gspace_1d ! ************************************************************************************************** @@ -396,7 +396,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_3d nsum_2c_gspace_3d = NINT(ns_G*(2*exp_w + ncoset(l + m)*7), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_gspace_3d ! ************************************************************************************************** !> \brief As pgf_sum_2c_gspace_1d but 3d sum required for non-orthorhombic cells @@ -495,7 +495,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_1d nsum_2c_rspace_1d = NINT(ns_R*(exp_w + (l + m + 1)*3), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_rspace_1d ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in R space in 1 dimension @@ -553,7 +553,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_3d nsum_2c_rspace_3d = NINT(ns_R*(exp_w + ncoset(l + m)*(4 + ncoset(l + m)*4)), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_rspace_3d ! ************************************************************************************************** !> \brief As pgf_sum_2c_rspace_1d but 3d sum required for non-orthorhombic cells @@ -611,7 +611,8 @@ CONTAINS END DO DO lco = 1, ncoset(l_max) CALL get_l(lco, l, lx, ly, lz) - S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot ! cost: 4 flops + ! cost: 4 flops + S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot END DO END DO END DO @@ -794,7 +795,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_gspace_1d nsum_3c_gspace_1d = 15 - END FUNCTION + END FUNCTION nsum_3c_gspace_1d ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -810,7 +811,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_product_3c_gspace_1d nsum_product_3c_gspace_1d = MIN(19, NINT(ns_G*(3 + ns_R*2))) - END FUNCTION + END FUNCTION nsum_product_3c_gspace_1d ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -826,7 +827,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_rspace_1d nsum_3c_rspace_1d = NINT(MIN((4 + ns_R1*2), ns_R1*(ns_R2 + 1)), KIND=int_8) - END FUNCTION + END FUNCTION nsum_3c_rspace_1d ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -954,7 +955,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE + END SUBROUTINE pgf_sum_3c_rspace_1d_generic ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -1009,7 +1010,7 @@ CONTAINS #:for l in range(0, l_tot_max) #:for k in range(0, l+2) #:if k0 - h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# + h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# #:else h_to_c_${k}$_${l+1}$ = 0.0_dp #:endif @@ -1087,15 +1088,15 @@ CONTAINS #:for l in range(0,l_max+1) #:for t in range(0,l+m+2) #:if l < l_max - E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}# +c2*E_${t}$_${l}$_${m}$&#{endif}# #{if t0 and t<=l-1+m}#-${2*l}$*E_${t}$_${l-1}$_${m}$#{endif}#) #:endif #:if m < m_max - E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}#+c3*E_${t}$_${l}$_${m}$&#{endif}# - #{if t0 and t<=m-1+l}#-${2*m}$*E_${t}$_${l}$_${m-1}$#{endif}#) #:endif #:endfor @@ -1115,7 +1116,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE + END SUBROUTINE pgf_sum_3c_rspace_1d_${l_max}$_${m_max}$_${n_max}$_exp_${prop_exp}$ #:endfor #:endfor #:endfor @@ -1265,7 +1266,7 @@ CONTAINS nsum_3c_gspace_3d = NINT(ns_G1*ns_G2*(5*exp_w + ncoset(l)*ncoset(m)*ncoset(n)*4), KIND=int_8) - END FUNCTION + END FUNCTION nsum_3c_gspace_3d ! ************************************************************************************************** !> \brief ... @@ -1427,7 +1428,7 @@ CONTAINS END SELECT S_G = REAL(S_G_c, KIND=dp)/vol**2 - END SUBROUTINE + END SUBROUTINE pgf_sum_3c_gspace_3d ! ************************************************************************************************** !> \brief ... @@ -1543,7 +1544,7 @@ CONTAINS 3*nsum_gaussian_overlap(l, m, 1) + & ncoset(l)*ncoset(m)*(ncoset(l + m)*4 + ncoset(n)*8)), & KIND=int_8) - END FUNCTION + END FUNCTION nsum_product_3c_gspace_3d ! ************************************************************************************************** !> \brief ... @@ -1764,7 +1765,7 @@ CONTAINS ncoset(l + m)*2 + ncoset(n)*ncoset(l + m)*4)), & KIND=int_8) - END FUNCTION + END FUNCTION nsum_3c_rspace_3d ! ************************************************************************************************** !> \brief ... @@ -1962,7 +1963,7 @@ CONTAINS ELSE nsum_gaussian_overlap = nsum_gaussian_overlap + loop*32 END IF - END FUNCTION + END FUNCTION nsum_gaussian_overlap ! ************************************************************************************************** !> \brief ... @@ -1981,7 +1982,7 @@ CONTAINS IF (PRESENT(lx)) lx = indco(1, lco) IF (PRESENT(ly)) ly = indco(2, lco) IF (PRESENT(lz)) lz = indco(3, lco) - END SUBROUTINE + END SUBROUTINE get_l ! ************************************************************************************************** !> \brief ... @@ -1993,10 +1994,10 @@ CONTAINS COMPLEX(KIND=dp) :: i_pow COMPLEX(KIND=dp), DIMENSION(0:3), PARAMETER :: & - ip = (/(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)/) + ip = [(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)] i_pow = ip(MOD(i, 4)) - END FUNCTION + END FUNCTION i_pow END MODULE eri_mme_lattice_summation diff --git a/src/eri_mme/eri_mme_test.F b/src/eri_mme/eri_mme_test.F index f67388aac6..923b19c2c9 100644 --- a/src/eri_mme/eri_mme_test.F +++ b/src/eri_mme/eri_mme_test.F @@ -158,8 +158,9 @@ CONTAINS acc_check = .TRUE. END IF - IF (.NOT. acc_check) & + IF (.NOT. acc_check) THEN CPABORT("Actual error greater than upper bound estimate.") + END IF END IF END IF diff --git a/src/eri_mme/eri_mme_types.F b/src/eri_mme/eri_mme_types.F index 2f40d28ab0..25f94e1ae1 100644 --- a/src/eri_mme/eri_mme_types.F +++ b/src/eri_mme/eri_mme_types.F @@ -127,8 +127,9 @@ CONTAINS CHARACTER(len=2) :: string WRITE (string, '(I2)') n_minimax_max - IF (n_minimax > n_minimax_max) & + IF (n_minimax > n_minimax_max) THEN CPABORT("The maximum allowed number of minimax points N_MINIMAX is "//TRIM(string)) + END IF param%n_minimax = n_minimax param%n_grids = 1 diff --git a/src/et_coupling_proj.F b/src/et_coupling_proj.F index f387e74c79..dae0f3d119 100644 --- a/src/et_coupling_proj.F +++ b/src/et_coupling_proj.F @@ -150,8 +150,9 @@ CONTAINS IF (ASSOCIATED(ec)) THEN - IF (ASSOCIATED(ec%fermi)) & + IF (ASSOCIATED(ec%fermi)) THEN DEALLOCATE (ec%fermi) + END IF IF (ASSOCIATED(ec%m_transf)) THEN CALL cp_fm_release(matrix=ec%m_transf) DEALLOCATE (ec%m_transf) @@ -166,8 +167,9 @@ CONTAINS IF (ASSOCIATED(ec%block)) THEN DO i = 1, SIZE(ec%block) - IF (ASSOCIATED(ec%block(i)%atom)) & + IF (ASSOCIATED(ec%block(i)%atom)) THEN DEALLOCATE (ec%block(i)%atom) + END IF IF (ASSOCIATED(ec%block(i)%mo)) THEN DO j = 1, SIZE(ec%block(i)%mo) CALL deallocate_mo_set(ec%block(i)%mo(j)) @@ -242,8 +244,9 @@ CONTAINS DO i = 1, n_atoms CALL get_atomic_kind(particle_set(i)%atomic_kind, kind_number=j) CALL get_qs_kind(qs_kind_set(j), basis_set=ao_basis_set) - IF (.NOT. ASSOCIATED(ao_basis_set)) & + IF (.NOT. ASSOCIATED(ao_basis_set)) THEN CPABORT('Unsupported basis set type. ') + END IF CALL get_gto_basis_set(gto_basis_set=ao_basis_set, & nset=n_set, nshell=n_shell, l=ang_mom_id) DO j = 1, n_set @@ -300,8 +303,9 @@ CONTAINS ! Count unique atoms DO j = 1, SIZE(atom_id) ! Check atom ID validity - IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) & + IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) THEN CPABORT('invalid fragment atom ID ('//TRIM(ADJUSTL(cp_to_string(atom_id(j))))//')') + END IF ! Check if the atom is not in previously-defined blocks found = .FALSE. DO k = 1, i - 1 @@ -346,12 +350,15 @@ CONTAINS END DO ! Clean memory - IF (ASSOCIATED(atom_nf)) & + IF (ASSOCIATED(atom_nf)) THEN DEALLOCATE (atom_nf) - IF (ASSOCIATED(atom_ps)) & + END IF + IF (ASSOCIATED(atom_ps)) THEN DEALLOCATE (atom_ps) - IF (ASSOCIATED(t)) & + END IF + IF (ASSOCIATED(t)) THEN DEALLOCATE (t) + END IF END SUBROUTINE set_block_data @@ -409,8 +416,9 @@ CONTAINS ! Routine name for debug purposes ! Local variables - IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) & + IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) THEN CPABORT('cannot reorder Hamiltonian, working-matrix structure is not equivalent') + END IF ! Matrix-element reordering nr = 1 @@ -672,8 +680,9 @@ CONTAINS END DO ! Clean memory - IF (ALLOCATED(dat)) & + IF (ALLOCATED(dat)) THEN DEALLOCATE (dat) + END IF END SUBROUTINE hamiltonian_block_diag @@ -718,8 +727,9 @@ CONTAINS END IF END DO - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT('MO-fraction atom ID not defined in the block') + END IF ! sum MO coefficients from the atom DO k = 1, blk_at(j)%n_ao @@ -773,8 +783,9 @@ CONTAINS IF (n > 0) THEN - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(/,T3,A/)') 'Block state fractions:' + END IF ! Number of AO functions CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) @@ -809,8 +820,9 @@ CONTAINS IF (ASSOCIATED(list_mo)) THEN IF (j > 1) THEN - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, *) + END IF END IF DO l = 1, SIZE(list_mo) @@ -820,13 +832,15 @@ CONTAINS list_mo(l), list_at) c2 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(2), & list_mo(l), list_at) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(I5,A,I5,2F20.10)') j, ' /', list_mo(l), c1, c2 + END IF ELSE c1 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(1), & list_mo(l), list_at) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(I5,A,I5,F20.10)') j, ' /', list_mo(l), c1 + END IF END IF END DO @@ -873,8 +887,9 @@ CONTAINS ! Routine name for debug purposes prnt_fm = .FALSE. - IF (PRESENT(fermi)) & + IF (PRESENT(fermi)) THEN prnt_fm = fermi + END IF IF (output_unit > 0) THEN @@ -884,11 +899,13 @@ CONTAINS IF (n_spins > 1) THEN mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) & + IF (PRESENT(mx_mo_a)) THEN mx_a = MIN(mo(1)%nmo, mx_mo_a) + END IF mx_b = mo(2)%nmo - IF (PRESENT(mx_mo_b)) & + IF (PRESENT(mx_mo_b)) THEN mx_b = MIN(mo(2)%nmo, mx_mo_b) + END IF n = MAX(mx_a, mx_b) DO i = 1, n @@ -918,8 +935,9 @@ CONTAINS ELSE mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) & + IF (PRESENT(mx_mo_a)) THEN mx_a = MIN(mo(1)%nmo, mx_mo_a) + END IF DO i = 1, mx_a WRITE (output_unit, '(T3,I10,2F12.4)') & @@ -984,8 +1002,9 @@ CONTAINS my_pos = "APPEND" END IF - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(/,T3,A/)') 'Printing coupling elements to output files' + END IF DO i = 1, ec%n_blocks DO j = i + 1, ec%n_blocks @@ -1104,15 +1123,16 @@ CONTAINS ALLOCATE (vec_t(n_mo)) CPASSERT(ASSOCIATED(vec_t)) CALL cp_fm_vectorssum(mat_t, vec_t) - vec_t = 1.0_dp/DSQRT(vec_t) + vec_t = 1.0_dp/SQRT(vec_t) CALL cp_fm_column_scale(mo%mo_coeff, vec_t) ! Clean memory CALL cp_fm_struct_release(fmstruct=fm_s) CALL cp_fm_release(matrix=mat_sc) CALL cp_fm_release(matrix=mat_t) - IF (ASSOCIATED(vec_t)) & + IF (ASSOCIATED(vec_t)) THEN DEALLOCATE (vec_t) + END IF END SUBROUTINE normalize_mo_vectors @@ -1222,24 +1242,28 @@ CONTAINS ! Number of states n_mo = mat_u%matrix_struct%nrow_global - IF (n_mo /= mat_u%matrix_struct%ncol_global) & + IF (n_mo /= mat_u%matrix_struct%ncol_global) THEN CPABORT('block state matrix is not square') - IF (n_mo /= SIZE(vec_e)) & + END IF + IF (n_mo /= SIZE(vec_e)) THEN CPABORT('inconsistent number of states / energies') + END IF ! Maximal occupancy CALL get_qs_env(qs_env, dft_control=dft_cntrl) mx_occ = 2.0_dp - IF (dft_cntrl%nspins > 1) & + IF (dft_cntrl%nspins > 1) THEN mx_occ = 1.0_dp + END IF ! Number of electrons n_el = ec%block(id)%n_electrons IF (dft_cntrl%nspins > 1) THEN n_el = n_el/2 IF (MOD(ec%block(id)%n_electrons, 2) == 1) THEN - IF (spin == 1) & + IF (spin == 1) THEN n_el = n_el + 1 + END IF END IF END IF @@ -1518,8 +1542,9 @@ CONTAINS ! Parallel calculation - master thread master = .FALSE. - IF (output_unit > 0) & + IF (output_unit > 0) THEN master = .TRUE. + END IF ! Header IF (master) THEN @@ -1603,20 +1628,23 @@ CONTAINS CPABORT('ET_COUPLING not implemented with kpoints') ELSE ! no K-points - IF (master) & + IF (master) THEN WRITE (output_unit, '(T3,A)') 'No K-point sampling (Gamma point only)' + END IF END IF IF (dft_cntrl%nspins == 2) THEN - IF (master) & + IF (master) THEN WRITE (output_unit, '(/,T3,A)') 'Spin-polarized calculation' + END IF !<--- Open shell / No K-points ------------------------------------------------>! ! State eneries of the whole system - IF (mo(1)%nao /= mo(2)%nao) & + IF (mo(1)%nao /= mo(2)%nao) THEN CPABORT('different number of alpha/beta AO basis functions') + END IF IF (master) THEN WRITE (output_unit, '(/,T3,A,I10)') & 'Number of AO basis functions = ', mo(1)%nao @@ -1648,8 +1676,9 @@ CONTAINS ELSE - IF (master) & + IF (master) THEN WRITE (output_unit, '(/,T3,A)') 'Spin-restricted calculation' + END IF !<--- Close shell / No K-points ----------------------------------------------->! diff --git a/src/ewald_spline_util.F b/src/ewald_spline_util.F index 9ebfcab6e5..74f69713b4 100644 --- a/src/ewald_spline_util.F +++ b/src/ewald_spline_util.F @@ -398,10 +398,10 @@ CONTAINS END DO Na = SQRT(dxTerm*dxTerm + dyTerm*dyTerm + dzTerm*dzTerm) dn = Eval_d_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) - Nn = SQRT(DOT_PRODUCT(dn, dn)) + Nn = NORM2(dn) Fterm = Eval_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) tmp1 = ABS(Term - Fterm) - tmp2 = SQRT(DOT_PRODUCT(dn - [dxTerm, dyTerm, dzTerm], dn - [dxTerm, dyTerm, dzTerm])) + tmp2 = NORM2(dn - [dxTerm, dyTerm, dzTerm]) errf = errf + tmp1 maxerrorf = MAX(maxerrorf, tmp1) errd = errd + tmp2 diff --git a/src/ewalds.F b/src/ewalds.F index c5df25968f..b10f460437 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -364,9 +364,9 @@ CONTAINS charges) TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set(:) + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(distribution_1d_type), POINTER :: local_particles - REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self(:) + REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self REAL(KIND=dp), DIMENSION(:), POINTER :: charges INTEGER :: ewald_type, ii, iparticle_kind, & diff --git a/src/ewalds_multipole.F b/src/ewalds_multipole.F index 06a4c1f867..96abbf552e 100644 --- a/src/ewalds_multipole.F +++ b/src/ewalds_multipole.F @@ -61,6 +61,17 @@ MODULE ewalds_multipole IMPLICIT NONE PRIVATE + TYPE charge_mono_type + REAL(KIND=dp), DIMENSION(:), & + POINTER :: charge => NULL() + REAL(KIND=dp), DIMENSION(:, :), & + POINTER :: pos => NULL() + END TYPE charge_mono_type + TYPE multi_charge_type + TYPE(charge_mono_type), DIMENSION(:), & + POINTER :: charge_typ => NULL() + END TYPE multi_charge_type + LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_r_space = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_g_space = .FALSE. @@ -1276,16 +1287,6 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, iw, debug_r_space) - TYPE charge_mono_type - REAL(KIND=dp), DIMENSION(:), & - POINTER :: charge - REAL(KIND=dp), DIMENSION(:, :), & - POINTER :: pos - END TYPE charge_mono_type - TYPE multi_charge_type - TYPE(charge_mono_type), DIMENSION(:), & - POINTER :: charge_typ - END TYPE multi_charge_type TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(fist_nonbond_env_type), POINTER :: nonbond_env @@ -1607,7 +1608,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = SQRT(DOT_PRODUCT(rm, rm)) + r = NORM2(rm) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1646,7 +1647,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = SQRT(DOT_PRODUCT(rm, rm)) + r = NORM2(rm) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1727,7 +1728,7 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%charge(2)) ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 2)) CALL random_stream%fill(rvec) - rvec = rvec/(2.0_dp*SQRT(DOT_PRODUCT(rvec, rvec)))*dx + rvec = rvec/(2.0_dp*NORM2(rvec))*dx multipoles(i)%charge_typ(isize)%charge(1) = echarge multipoles(i)%charge_typ(isize)%pos(1:3, 1) = rvec multipoles(i)%charge_typ(isize)%charge(2) = -echarge @@ -1742,9 +1743,9 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 4)) CALL random_stream%fill(rvec1) CALL random_stream%fill(rvec2) - rvec1 = rvec1/SQRT(DOT_PRODUCT(rvec1, rvec1)) + rvec1 = rvec1/NORM2(rvec1) rvec2 = rvec2 - DOT_PRODUCT(rvec2, rvec1)*rvec1 - rvec2 = rvec2/SQRT(DOT_PRODUCT(rvec2, rvec2)) + rvec2 = rvec2/NORM2(rvec2) ! rvec1 = rvec1/2.0_dp*dx rvec2 = rvec2/2.0_dp*dx diff --git a/src/ewalds_multipole_sr.fypp b/src/ewalds_multipole_sr.fypp index 4f8b2f528b..99d3e9d09d 100644 --- a/src/ewalds_multipole_sr.fypp +++ b/src/ewalds_multipole_sr.fypp @@ -246,7 +246,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = dexp(-dampa_ij*r) + dampaexpi = EXP(-dampa_ij*r) dampfunci = dampsumfi*dampaexpi*dampfac_ij dampfuncdiffi = -dampa_ij*dampaexpi* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -267,7 +267,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = dexp(-dampa_ji*r) + dampaexpj = EXP(-dampa_ji*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ji dampfuncdiffj = -dampa_ji*dampaexpj* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & @@ -287,7 +287,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = dexp(-dampa_ij*r) + dampaexpj = EXP(-dampa_ij*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ij dampfuncdiffj = -dampa_ij*dampaexpj* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -308,7 +308,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = dexp(-dampa_ji*r) + dampaexpi = EXP(-dampa_ji*r) dampfunci = dampsumfi*dampaexpi*dampfac_ji dampfuncdiffi = -dampa_ji*dampaexpi* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & diff --git a/src/excited_states.F b/src/excited_states.F index a5ab99bb5d..13329ec4db 100644 --- a/src/excited_states.F +++ b/src/excited_states.F @@ -112,9 +112,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=ex_env%debug_forces) ELSE ! KS-DFT diff --git a/src/exstates_types.F b/src/exstates_types.F index 1b9c77dd55..d7d535d6b9 100644 --- a/src/exstates_types.F +++ b/src/exstates_types.F @@ -106,8 +106,9 @@ CONTAINS CALL cp_fm_release(ex_env%wfn_history%evect) CALL cp_fm_release(ex_env%wfn_history%cpmos) - IF (ALLOCATED(ex_env%gw_eigen)) & + IF (ALLOCATED(ex_env%gw_eigen)) THEN DEALLOCATE (ex_env%gw_eigen) + END IF DEALLOCATE (ex_env) diff --git a/src/f77_interface.F b/src/f77_interface.F index 125ff2d120..28be264b2a 100644 --- a/src/f77_interface.F +++ b/src/f77_interface.F @@ -755,11 +755,12 @@ CONTAINS ! Check that the order of the force_eval is the correct one CALL section_vals_val_get(force_env_sections, "METHOD", i_val=method_name_id, & i_rep_section=i_force_eval(1)) - IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) & + IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) THEN CALL cp_abort(__LOCATION__, & "In case of multiple force_eval the MAIN force_eval (the first in the list of FORCE_EVAL_ORDER or "// & "the one omitted from that order list) must be a MIXED_ENV type calculation. Please check your "// & "input file and possibly correct the MULTIPLE_FORCE_EVAL%FORCE_EVAL_ORDER. ") + END IF IF (method_name_id == do_mixed) THEN check = ASSOCIATED(force_env%mixed_env%sub_para_env) @@ -807,8 +808,9 @@ CONTAINS IF (method_name_id == do_qmmm) THEN qmmmx_section => section_vals_get_subs_vals(force_env_section, "QMMM%FORCE_MIXING") CALL section_vals_get(qmmmx_section, explicit=do_qmmm_force_mixing) - IF (do_qmmm_force_mixing) & - method_name_id = do_qmmmx ! QMMM Force-Mixing has its own (hidden) method_id + IF (do_qmmm_force_mixing) THEN + method_name_id = do_qmmmx + END IF ! QMMM Force-Mixing has its own (hidden) method_id END IF SELECT CASE (method_name_id) @@ -943,8 +945,9 @@ CONTAINS ! Release force_env_section IF (nforce_eval > 1) CALL section_vals_release(force_env_section) END DO - IF (use_multiple_para_env) & + IF (use_multiple_para_env) THEN CALL cp_rm_default_logger() + END IF DEALLOCATE (group_distribution) DEALLOCATE (i_force_eval) timer_env => get_timer_env() diff --git a/src/farming_methods.F b/src/farming_methods.F index 006de02994..eeb540f8e2 100644 --- a/src/farming_methods.F +++ b/src/farming_methods.F @@ -304,7 +304,7 @@ CONTAINS WRITE (output_unit, "(T2,A)") & "FARMING| ---- WARNING ---- failed to open ("//TRIM(farming_env%restart_file_name)//"), starting at 1" END IF - CLOSE (iunit, IOSTAT=stat) + CLOSE (iunit) END IF CALL cp_print_key_finished_output(output_unit, logger, farming_section, & diff --git a/src/farming_types.F b/src/farming_types.F index 3324a31dbb..45820baede 100644 --- a/src/farming_types.F +++ b/src/farming_types.F @@ -38,7 +38,8 @@ MODULE farming_types LOGICAL :: restart = .FALSE. LOGICAL :: CYCLE = .FALSE. LOGICAL :: captain_minion = .FALSE. - INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() ! user preference for partitioning the cpus + ! user preference for partitioning the cpus + INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() CHARACTER(LEN=default_path_length) :: restart_file_name = "" ! restart file for farming CHARACTER(LEN=default_path_length) :: cwd = "" ! directory we started from INTEGER :: Njobs = -1 ! how many jobs to run diff --git a/src/fist_efield_methods.F b/src/fist_efield_methods.F index 72be6551ad..86afa8d109 100644 --- a/src/fist_efield_methods.F +++ b/src/fist_efield_methods.F @@ -103,7 +103,7 @@ CONTAINS END IF fieldpol = efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*efield%strength dfilter = efield%dfilter diff --git a/src/fist_environment_types.F b/src/fist_environment_types.F index 5a49675dc1..ba016dd434 100644 --- a/src/fist_environment_types.F +++ b/src/fist_environment_types.F @@ -187,7 +187,7 @@ CONTAINS IF (PRESENT(subsys)) subsys => fist_env%subsys IF (PRESENT(efield)) efield => fist_env%efield - IF (ASSOCIATED(fist_env%subsys)) & + IF (ASSOCIATED(fist_env%subsys)) THEN CALL cp_subsys_get(fist_env%subsys, & atomic_kinds=atomic_kinds, & local_molecules=local_molecules, & @@ -200,6 +200,7 @@ CONTAINS multipoles=fist_multipoles, & results=results, & cell=cell) + END IF IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds%els diff --git a/src/fist_force.F b/src/fist_force.F index 2cff3aba15..f2ab3a0281 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -735,7 +735,7 @@ CONTAINS shell_particle_set(i)%f(3) = fshell_total(3, i) + fgshell_coulomb(3, i) END DO - ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms @@ -767,7 +767,7 @@ CONTAINS shell_particle_set(i)%f(2) = fshell_total(2, i) shell_particle_set(i)%f(3) = fshell_total(3, i) END DO - ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms diff --git a/src/fist_intra_force.F b/src/fist_intra_force.F index 882ca5fe8f..9838cd3333 100644 --- a/src/fist_intra_force.F +++ b/src/fist_intra_force.F @@ -272,9 +272,9 @@ CONTAINS b32 = particle_set(index_c)%r - particle_set(index_b)%r b12 = pbc(b12, cell) b32 = pbc(b32, cell) - d12 = SQRT(DOT_PRODUCT(b12, b12)) + d12 = NORM2(b12) id12 = 1.0_dp/d12 - d32 = SQRT(DOT_PRODUCT(b32, b32)) + d32 = NORM2(b32) id32 = 1.0_dp/d32 dist = DOT_PRODUCT(b12, b32) theta = (dist*id12*id32) @@ -343,11 +343,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = SQRT(DOT_PRODUCT(tm, tm)) + sm = NORM2(tm) ism = 1.0_dp/sm - sn = SQRT(DOT_PRODUCT(tn, tn)) + sn = NORM2(tn) isn = 1.0_dp/sn - s32 = SQRT(DOT_PRODUCT(t32, t32)) + s32 = NORM2(t32) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -415,11 +415,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = SQRT(DOT_PRODUCT(tm, tm)) + sm = NORM2(tm) ism = 1.0_dp/sm - sn = SQRT(DOT_PRODUCT(tn, tn)) + sn = NORM2(tn) isn = 1.0_dp/sn - s32 = SQRT(DOT_PRODUCT(t32, t32)) + s32 = NORM2(t32) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -483,8 +483,8 @@ CONTAINS tm(1) = t32(2)*t12(3) - t12(2)*t32(3) tm(2) = -t32(1)*t12(3) + t12(1)*t32(3) tm(3) = t32(1)*t12(2) - t12(1)*t32(2) - sm = SQRT(DOT_PRODUCT(tm, tm)) - s32 = SQRT(DOT_PRODUCT(t32, t32)) + sm = NORM2(tm) + s32 = NORM2(t32) CALL force_opbends(opbend_list(iopbend)%opbend_kind%id_type, & s32, tm, t41, t42, t43, & opbend_list(iopbend)%opbend_kind%k, & diff --git a/src/fist_neighbor_lists.F b/src/fist_neighbor_lists.F index 803244aac8..34694b9879 100644 --- a/src/fist_neighbor_lists.F +++ b/src/fist_neighbor_lists.F @@ -685,7 +685,7 @@ CONTAINS ra(:) = pbc(particle_set(atom_a)%r, cell) rb(:) = pbc(particle_set(atom_b)%r, cell) rab = rb(:) - ra(:) + cell_v - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) IF (ilist <= neighbor_kind_pair%nscale) THEN WRITE (UNIT=output_unit, FMT="(T3,2(I6,3(1X,F10.6)),3(1X,I3),10X,F8.4,L4,F11.5,F9.5)") & atom_a, ra(1:3)*conv, & diff --git a/src/fist_nonbond_env_types.F b/src/fist_nonbond_env_types.F index c90883e177..26360ee060 100644 --- a/src/fist_nonbond_env_types.F +++ b/src/fist_nonbond_env_types.F @@ -189,29 +189,36 @@ CONTAINS IF (PRESENT(rlist_lowsq)) rlist_lowsq => fist_nonbond_env%rlist_lowsq IF (PRESENT(ij_kind_full_fac)) ij_kind_full_fac => fist_nonbond_env%ij_kind_full_fac IF (PRESENT(nonbonded)) nonbonded => fist_nonbond_env%nonbonded - IF (PRESENT(r_last_update)) & + IF (PRESENT(r_last_update)) THEN r_last_update => fist_nonbond_env%r_last_update - IF (PRESENT(r_last_update_pbc)) & + END IF + IF (PRESENT(r_last_update_pbc)) THEN r_last_update_pbc => fist_nonbond_env%r_last_update_pbc - IF (PRESENT(rshell_last_update_pbc)) & + END IF + IF (PRESENT(rshell_last_update_pbc)) THEN rshell_last_update_pbc => fist_nonbond_env%rshell_last_update_pbc - IF (PRESENT(rcore_last_update_pbc)) & + END IF + IF (PRESENT(rcore_last_update_pbc)) THEN rcore_last_update_pbc => fist_nonbond_env%rcore_last_update_pbc - IF (PRESENT(cell_last_update)) & + END IF + IF (PRESENT(cell_last_update)) THEN cell_last_update => fist_nonbond_env%cell_last_update + END IF IF (PRESENT(lup)) lup = fist_nonbond_env%lup IF (PRESENT(aup)) aup = fist_nonbond_env%aup IF (PRESENT(ei_scale14)) ei_scale14 = fist_nonbond_env%ei_scale14 IF (PRESENT(vdw_scale14)) vdw_scale14 = fist_nonbond_env%vdw_scale14 - IF (PRESENT(shift_cutoff)) & + IF (PRESENT(shift_cutoff)) THEN shift_cutoff = fist_nonbond_env%shift_cutoff + END IF IF (PRESENT(do_electrostatics)) do_electrostatics = fist_nonbond_env%do_electrostatics IF (PRESENT(natom_types)) natom_types = fist_nonbond_env%natom_types IF (PRESENT(counter)) counter = fist_nonbond_env%counter IF (PRESENT(last_update)) last_update = fist_nonbond_env%last_update IF (PRESENT(num_update)) num_update = fist_nonbond_env%num_update - IF (PRESENT(long_range_correction)) & + IF (PRESENT(long_range_correction)) THEN long_range_correction = fist_nonbond_env%long_range_correction + END IF END SUBROUTINE fist_nonbond_env_get ! ************************************************************************************************** @@ -283,29 +290,36 @@ CONTAINS IF (PRESENT(charges)) fist_nonbond_env%charges => charges IF (PRESENT(rlist_lowsq)) fist_nonbond_env%rlist_lowsq => rlist_lowsq IF (PRESENT(nonbonded)) fist_nonbond_env%nonbonded => nonbonded - IF (PRESENT(r_last_update)) & + IF (PRESENT(r_last_update)) THEN fist_nonbond_env%r_last_update => r_last_update - IF (PRESENT(r_last_update_pbc)) & + END IF + IF (PRESENT(r_last_update_pbc)) THEN fist_nonbond_env%r_last_update_pbc => r_last_update_pbc - IF (PRESENT(rshell_last_update_pbc)) & + END IF + IF (PRESENT(rshell_last_update_pbc)) THEN fist_nonbond_env%rshell_last_update_pbc => rshell_last_update_pbc - IF (PRESENT(rcore_last_update_pbc)) & + END IF + IF (PRESENT(rcore_last_update_pbc)) THEN fist_nonbond_env%rcore_last_update_pbc => rcore_last_update_pbc - IF (PRESENT(cell_last_update)) & + END IF + IF (PRESENT(cell_last_update)) THEN fist_nonbond_env%cell_last_update => cell_last_update + END IF IF (PRESENT(lup)) fist_nonbond_env%lup = lup IF (PRESENT(aup)) fist_nonbond_env%aup = aup IF (PRESENT(ei_scale14)) fist_nonbond_env%ei_scale14 = ei_scale14 IF (PRESENT(vdw_scale14)) fist_nonbond_env%vdw_scale14 = vdw_scale14 - IF (PRESENT(shift_cutoff)) & + IF (PRESENT(shift_cutoff)) THEN fist_nonbond_env%shift_cutoff = shift_cutoff + END IF IF (PRESENT(do_electrostatics)) fist_nonbond_env%do_electrostatics = do_electrostatics IF (PRESENT(natom_types)) fist_nonbond_env%natom_types = natom_types IF (PRESENT(counter)) fist_nonbond_env%counter = counter IF (PRESENT(last_update)) fist_nonbond_env%last_update = last_update IF (PRESENT(num_update)) fist_nonbond_env%num_update = num_update - IF (PRESENT(long_range_correction)) & + IF (PRESENT(long_range_correction)) THEN fist_nonbond_env%long_range_correction = long_range_correction + END IF END SUBROUTINE fist_nonbond_env_set ! ************************************************************************************************** diff --git a/src/floquet_utils.F b/src/floquet_utils.F index b5e0f05f72..182c1a0e93 100644 --- a/src/floquet_utils.F +++ b/src/floquet_utils.F @@ -303,7 +303,7 @@ CONTAINS ! E_factor(α) = (i E(α) exp(i·φ(α)))/(2ω) where α = x,y,z DO i_dir = 1, 3 - efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(DCOS(phi(i_dir)), DSIN(phi(i_dir)), KIND=dp)/(2*omega) + efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(COS(phi(i_dir)), SIN(phi(i_dir)), KIND=dp)/(2*omega) END DO DO i_dir = 1, 3 diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index 17c77dc1eb..2ae9174c83 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -439,8 +439,9 @@ CONTAINS ! * the source matrix is distributed across a number of processes, or ! * not all elements of the target matrix will be assigned, e.g. ! when the target matrix is larger then the source matrix - IF (do_zero) & + IF (do_zero) THEN CALL zcopy(SIZE(target_m), z_zero, 0, target_m(1, 1), 1) + END IF IF (tr_a) THEN DO j = start_col_local, end_col_local @@ -668,14 +669,17 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN CPABORT("internal local_data has different sizes") + END IF CALL zcopy(SIZE(source%local_data), source%local_data(1, 1), 1, destination%local_data(1, 1), 1) ELSE - IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) & + IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) THEN CPABORT("cannot copy between full matrixes of differen sizes") - IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) & + END IF + IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) THEN CPABORT("cannot copy between full matrixes of differen sizes") + END IF #if defined(__parallel) CALL pzcopy(source%matrix_struct%nrow_global* & source%matrix_struct%ncol_global, & @@ -1068,7 +1072,8 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another + ! routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends diff --git a/src/fm/cp_fm_diag_utils.F b/src/fm/cp_fm_diag_utils.F index 8ac6dc147e..d613da3fc9 100644 --- a/src/fm/cp_fm_diag_utils.F +++ b/src/fm/cp_fm_diag_utils.F @@ -200,12 +200,14 @@ CONTAINS ncpu = num_pe_old - nzero ! Avoid layouts with odd number of CPUs (blacs grid layout will be square) - IF (ncpu > 2) & + IF (ncpu > 2) THEN ncpu = ncpu - MODULO(ncpu, 2) + END IF ! if there are no zero-width columns and the number of processors was even, leave it at that - IF (ncpu == num_pe_old) & + IF (ncpu == num_pe_old) THEN RETURN + END IF ! Iteratively search for the maximum number of CPUs for ELPA ! On each step, we test whether the blacs grid created with ncpu processes @@ -216,8 +218,9 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(ncpu, dp))) jpe = ncpu/ipe - IF (ipe*jpe /= ncpu) & + IF (ipe*jpe /= ncpu) THEN CYCLE + END IF IF (gcd(ipe, jpe) >= gcd_max) THEN npcol = jpe gcd_max = gcd(ipe, jpe) @@ -228,17 +231,20 @@ CONTAINS ! (snippet copied from cp_fm_struct.F:cp_fm_struct_create) nzero = 0 DO ipe = 0, npcol - 1 - IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) & + IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) THEN nzero = nzero + 1 + END IF END DO - IF (nzero == 0) & + IF (nzero == 0) THEN EXIT + END IF ncpu = ncpu - nzero - IF (ncpu > 2) & + IF (ncpu > 2) THEN ncpu = ncpu - MODULO(ncpu, 2) + END IF END DO END FUNCTION cp_fm_max_ncpu_non_zero_column @@ -423,8 +429,9 @@ CONTAINS eigenvectors_new = eigenvectors END IF - IF (PRESENT(redist_info)) & + IF (PRESENT(redist_info)) THEN redist_info = rdinfo + END IF #else MARK_USED(matrix) diff --git a/src/fm/cp_fm_elpa.F b/src/fm/cp_fm_elpa.F index c55f3ba75f..0fed54533c 100644 --- a/src/fm/cp_fm_elpa.F +++ b/src/fm/cp_fm_elpa.F @@ -192,8 +192,9 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: one_stage, qr, should_print #if defined(__ELPA) - IF (elpa_init(20180525) /= ELPA_OK) & + IF (elpa_init(20180525) /= ELPA_OK) THEN CPABORT("The linked ELPA library does not support the required API version") + END IF IF (PRESENT(one_stage)) elpa_one_stage = one_stage IF (PRESENT(should_print)) elpa_print = should_print IF (PRESENT(qr)) elpa_qr = qr @@ -294,8 +295,9 @@ CONTAINS caller_is_elpa=.TRUE., redist_info=rdinfo) ! Call ELPA on CPUs that hold the new matrix - IF (ASSOCIATED(matrix_new%matrix_struct)) & + IF (ASSOCIATED(matrix_new%matrix_struct)) THEN CALL cp_fm_diag_elpa_base(matrix_new, eigenvectors_new, eigenvalues, rdinfo) + END IF ! Redistribute results and clean up CALL cp_fm_redistribute_end(matrix, eigenvectors, eigenvalues, matrix_new, eigenvectors_new) @@ -389,12 +391,14 @@ CONTAINS ! Matrix order must be even use_qr = elpa_qr .AND. (MODULO(n, 2) == 0) ! Matrix order and block size must be greater than or equal to 64 - IF (.NOT. elpa_qr_unsafe) & + IF (.NOT. elpa_qr_unsafe) THEN use_qr = use_qr .AND. (n >= 64) .AND. (nblk >= 64) + END IF ! Check if eigenvalues computed with elpa_qr_unsafe should be verified - IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) & + IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) THEN check_eigenvalues = .TRUE. + END IF CALL matrix%matrix_struct%para_env%bcast(check_eigenvalues) @@ -497,8 +501,9 @@ CONTAINS CALL elpa_obj%set("solver", & MERGE(ELPA_SOLVER_1STAGE, ELPA_SOLVER_2STAGE, elpa_one_stage), & success) - IF (success /= ELPA_OK) & + IF (success /= ELPA_OK) THEN CPABORT("Setting solver for ELPA failed") + END IF ! enabling the GPU must happen before setting the kernel SELECT CASE (elpa_kernel) @@ -539,8 +544,9 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (success /= ELPA_OK) & + IF (success /= ELPA_OK) THEN CPABORT("ELPA failed to diagonalize a matrix") + END IF IF (check_eigenvalues) THEN ! run again without QR @@ -548,11 +554,13 @@ CONTAINS CPASSERT(success == ELPA_OK) CALL elpa_obj%eigenvectors(matrix_noqr%local_data, eval_noqr, eigenvectors_noqr%local_data, success) - IF (success /= ELPA_OK) & + IF (success /= ELPA_OK) THEN CPABORT("ELPA failed to diagonalize a matrix even without QR decomposition") + END IF - IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) & + IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) THEN CPABORT("ELPA failed to calculate Eigenvalues with ELPA's QR decomposition") + END IF DEALLOCATE (eval_noqr) CALL cp_fm_release(matrix_noqr) diff --git a/src/fm/cp_fm_struct.F b/src/fm/cp_fm_struct.F index 717f915611..3082c01518 100644 --- a/src/fm/cp_fm_struct.F +++ b/src/fm/cp_fm_struct.F @@ -232,8 +232,9 @@ CONTAINS ALLOCATE (fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1) - 1)), & fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2) - 1))) - IF (.NOT. PRESENT(template_fmstruct)) & + IF (.NOT. PRESENT(template_fmstruct)) THEN fmstruct%first_p_pos = [0, 0] + END IF IF (PRESENT(first_p_pos)) fmstruct%first_p_pos = first_p_pos fmstruct%nrow_locals = 0 @@ -266,10 +267,12 @@ CONTAINS CALL m_flush(iunit) END IF - IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) & + IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) THEN CPABORT("sum of local cols not equal global cols") - IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) & + END IF + IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) THEN CPABORT("sum of local row not equal global rows") + END IF #else ! block = full matrix fmstruct%nrow_block = fmstruct%nrow_global @@ -281,10 +284,11 @@ CONTAINS fmstruct%local_leading_dimension = MAX(fmstruct%local_leading_dimension, & fmstruct%nrow_locals(fmstruct%context%mepos(1))) IF (PRESENT(local_leading_dimension)) THEN - IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) & + IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) THEN CALL cp_abort(__LOCATION__, "local_leading_dimension too small ("// & cp_to_string(local_leading_dimension)//"<"// & cp_to_string(fmstruct%local_leading_dimension)//")") + END IF fmstruct%local_leading_dimension = local_leading_dimension END IF diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 75d6c4e816..756ad2f27e 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -482,8 +482,9 @@ CONTAINS my_ncol = matrix%matrix_struct%ncol_global IF (PRESENT(ncol)) my_ncol = ncol - IF (ncol_global < (my_start_col + my_ncol - 1)) & + IF (ncol_global < (my_start_col + my_ncol - 1)) THEN CPABORT("ncol_global>=(my_start_col+my_ncol-1)") + END IF ALLOCATE (buff(nrow_global)) @@ -1268,7 +1269,7 @@ CONTAINS IF (PRESENT(dir)) THEN IF (dir == 'c' .OR. dir == 'C') THEN docol = .TRUE. - ELSEIF (dir == 'r' .OR. dir == 'R') THEN + ELSE IF (dir == 'r' .OR. dir == 'R') THEN docol = .FALSE. ELSE CPABORT('Wrong argument DIR') @@ -1326,11 +1327,12 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN CALL cp_abort(__LOCATION__, & "Cannot copy full matrix <"//TRIM(source%name)// & "> to full matrix <"//TRIM(destination%name)// & ">. The local_data blocks have different sizes.") + END IF CALL dcopy(SIZE(source%local_data, 1)*SIZE(source%local_data, 2), & source%local_data, 1, destination%local_data, 1) ELSE @@ -1472,17 +1474,21 @@ CONTAINS na = msource%matrix_struct%nrow_global nb = mtarget%matrix_struct%nrow_global ! nrow must be <= na and nb - IF (nrow > na) & + IF (nrow > na) THEN CPABORT("cannot copy because nrow > number of rows of source matrix") - IF (nrow > nb) & + END IF + IF (nrow > nb) THEN CPABORT("cannot copy because nrow > number of rows of target matrix") + END IF na = msource%matrix_struct%ncol_global nb = mtarget%matrix_struct%ncol_global ! ncol must be <= na_col and nb_col - IF (ncol > na) & + IF (ncol > na) THEN CPABORT("cannot copy because nrow > number of rows of source matrix") - IF (ncol > nb) & + END IF + IF (ncol > nb) THEN CPABORT("cannot copy because nrow > number of rows of target matrix") + END IF #if defined(__parallel) desca(:) = msource%matrix_struct%descriptor(:) @@ -1716,7 +1722,8 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another + ! routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends @@ -2012,10 +2019,12 @@ CONTAINS ! check whether source is available on this process IF (ASSOCIATED(source%matrix_struct)) THEN desca = source%matrix_struct%descriptor - IF (nrows > source%matrix_struct%nrow_global) & + IF (nrows > source%matrix_struct%nrow_global) THEN CPABORT("nrows is greater than nrow_global of source") - IF (ncols > source%matrix_struct%ncol_global) & + END IF + IF (ncols > source%matrix_struct%ncol_global) THEN CPABORT("ncols is greater than ncol_global of source") + END IF smat => source%local_data ELSE desca = -1 @@ -2024,10 +2033,12 @@ CONTAINS ! check destination is available on this process IF (ASSOCIATED(destination%matrix_struct)) THEN descb = destination%matrix_struct%descriptor - IF (nrows > destination%matrix_struct%nrow_global) & + IF (nrows > destination%matrix_struct%nrow_global) THEN CPABORT("nrows is greater than nrow_global of destination") - IF (ncols > destination%matrix_struct%ncol_global) & + END IF + IF (ncols > destination%matrix_struct%ncol_global) THEN CPABORT("ncols is greater than ncol_global of destination") + END IF dmat => destination%local_data ELSE descb = -1 diff --git a/src/force_env_methods.F b/src/force_env_methods.F index 28cbe7e2ac..abb560ea63 100644 --- a/src/force_env_methods.F +++ b/src/force_env_methods.F @@ -404,8 +404,9 @@ CONTAINS "PRINT%PROGRAM_RUN_INFO") ! terminate the run if the value of the potential is abnormal - IF (abnormal_value(e_pot)) & + IF (abnormal_value(e_pot)) THEN CPABORT("Potential energy is an abnormal value (NaN/Inf).") + END IF ! Print forces, if requested print_forces = cp_print_key_unit_nr(logger, force_env%force_env_section, "PRINT%FORCES", & @@ -625,13 +626,15 @@ CONTAINS (.NOT. use_full_grid) ! Preserve restrictions selected during initial setup. The explicit DEBUG expert option ! remains available for symmetry diagnostics on otherwise unsupported cell matrices. - IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & + IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN use_inversion_symmetry_only = .TRUE. + END IF non_lower_triangular_cell = (ABS(cell%hmat(2, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 2)) > eps_cell) - IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & + IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN use_inversion_symmetry_only = .TRUE. + END IF dynamic_symmetry = kpoint_symmetry .AND. .NOT. use_full_grid .AND. & .NOT. use_inversion_symmetry_only IF (run_type_id == debug_run .AND. .NOT. fd_energy .AND. .NOT. dynamic_symmetry .AND. & @@ -1282,8 +1285,9 @@ CONTAINS !Transfer results source = 0 IF (ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) THEN - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN source = force_env%para_env%mepos + END IF END IF CALL force_env%para_env%sum(source) CALL cp_results_mp_bcast(results(iforce_eval)%results, source, force_env%para_env) @@ -1394,14 +1398,17 @@ CONTAINS CALL section_vals_val_get(mixed_section, "MIXED_CDFT%LAMBDA", r_val=lambda) ! Get the states which determine the forces CALL section_vals_val_get(mixed_section, "MIXED_CDFT%FORCE_STATES", i_vals=itmplist) - IF (SIZE(itmplist) /= 2) & + IF (SIZE(itmplist) /= 2) THEN CALL cp_abort(__LOCATION__, & "Keyword FORCE_STATES takes exactly two input values.") - IF (ANY(itmplist < 0)) & + END IF + IF (ANY(itmplist < 0)) THEN CPABORT("Invalid force_eval index.") + END IF istate = itmplist - IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) & + IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) THEN CPABORT("Invalid force_eval index.") + END IF mixed_energy%pot = lambda*energies(istate(1)) + (1.0_dp - lambda)*energies(istate(2)) ! General Mapping of forces... CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results, & @@ -1515,8 +1522,9 @@ CONTAINS ! Get Mapping index array natom = SIZE(particles(iforce_eval)%list%els) ! Serial mode need to deallocate first - IF (ASSOCIATED(map_index)) & + IF (ASSOCIATED(map_index)) THEN DEALLOCATE (map_index) + END IF CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, & map_index) @@ -1526,8 +1534,9 @@ CONTAINS particles(iforce_eval)%list%els(iparticle)%r = particles_mix%els(jparticle)%r END DO ! Mixed CDFT + QMMM: Need to translate now - IF (force_env%mixed_env%do_mixed_qmmm_cdft) & + IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN CALL apply_qmmm_translate(force_env%sub_force_env(iforce_eval)%force_env%qmmm_env) + END IF END DO ! For mixed CDFT calculations parallelized over CDFT states ! build weight and gradient on all processors before splitting into groups and @@ -1593,8 +1602,9 @@ CONTAINS nforce_eval = SIZE(force_env%sub_force_env) nvar = force_env%mixed_env%cdft_control%nconstraint ! Transfer cdft strengths for writing restart - IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) & + IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) THEN ALLOCATE (force_env%mixed_env%strength(nforce_eval, nvar)) + END IF force_env%mixed_env%strength = 0.0_dp DO iforce_eval = 1, nforce_eval IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE @@ -1604,14 +1614,16 @@ CONTAINS CALL force_env_get(force_env%sub_force_env(iforce_eval)%force_env, qs_env=qs_env) END IF CALL get_qs_env(qs_env, dft_control=dft_control) - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN force_env%mixed_env%strength(iforce_eval, :) = dft_control%qs_control%cdft_control%strength(:) + END IF END DO CALL force_env%para_env%sum(force_env%mixed_env%strength) ! Mixed CDFT: calculate ET coupling IF (force_env%mixed_env%do_mixed_et) THEN - IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) & + IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) THEN CALL mixed_cdft_calculate_coupling(force_env) + END IF END IF END IF @@ -2133,9 +2145,10 @@ CONTAINS ! Calculate potential gradient if the step has been accepted. Otherwise, we reuse the previous one - IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) & + IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) THEN CALL calculate_embed_pot_grad(force_env%sub_force_env(ref_subsys_number)%force_env%qs_env, & diff_rho_r, diff_rho_spin, opt_embed) + END IF ! Take the embedding step CALL opt_embed_step(diff_rho_r, diff_rho_spin, opt_embed, embed_pot, spin_embed_pot, rho_r_ref, & force_env%sub_force_env(ref_subsys_number)%force_env%qs_env) diff --git a/src/force_env_types.F b/src/force_env_types.F index 339fcfeb75..f13f5bfbf1 100644 --- a/src/force_env_types.F +++ b/src/force_env_types.F @@ -230,10 +230,12 @@ CONTAINS CALL cp_add_default_logger(my_logger) END IF CALL force_env_release(force_env%sub_force_env(i)%force_env) - IF (force_env%in_use == use_mixed_force) & + IF (force_env%in_use == use_mixed_force) THEN CALL cp_rm_default_logger() - IF (force_env%in_use == use_embed) & + END IF + IF (force_env%in_use == use_embed) THEN CALL cp_rm_default_logger() + END IF END DO DEALLOCATE (force_env%sub_force_env) END IF diff --git a/src/force_env_utils.F b/src/force_env_utils.F index 699045290f..aba2988c97 100644 --- a/src/force_env_utils.F +++ b/src/force_env_utils.F @@ -393,7 +393,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) DO iparticle = 1, SIZE(particles%els) force = particles%els(iparticle)%f(:) - mod_force = SQRT(DOT_PRODUCT(force, force)) + mod_force = NORM2(force) IF ((mod_force > max_value) .AND. (mod_force /= 0.0_dp)) THEN force = force/mod_force*max_value particles%els(iparticle)%f(:) = force diff --git a/src/force_fields_all.F b/src/force_fields_all.F index 061e971116..6f9106752b 100644 --- a/src/force_fields_all.F +++ b/src/force_fields_all.F @@ -2025,11 +2025,12 @@ CONTAINS only_qm = qmmm_ff_precond_only_qm(id1=atmname, is_link=is_link_atom) CALL uppercase(atmname) - IF (charge /= -HUGE(0.0_dp)) & + IF (charge /= -HUGE(0.0_dp)) THEN CALL cp_warn(__LOCATION__, & "The charge for atom index ("//cp_to_string(iatom)//") and atom name ("// & TRIM(atmname)//") was already defined. The charge associated to this kind"// & " will be set to an uninitialized value and only the atom specific charge will be used! ") + END IF charge = -HUGE(0.0_dp) ! Check if the potential really requires the charge definition.. @@ -2171,10 +2172,11 @@ CONTAINS inp_info%shell_list(j)%shell%charge_shell charge = 0.0_dp IF (found) THEN - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "CORE-SHELL model defined for KIND ("//TRIM(atmname)//")"// & " ignoring charge definition! ") + END IF ELSE found = .TRUE. END IF @@ -2929,18 +2931,20 @@ CONTAINS ((name_atm_a) == (inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" ADDING! ") + END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declarations: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") + END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. @@ -2971,18 +2975,20 @@ CONTAINS ((name_atm_a) == (qmmm_env%inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" Adding QM/MM forcefield specifications") + END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING QM/MM forcefield specifications! ") + END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), & " ", TRIM(name_atm_b) @@ -3227,18 +3233,20 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") + END IF END IF found = .TRUE. END IF @@ -3268,18 +3276,20 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") + END IF END IF found = .TRUE. END IF @@ -3306,18 +3316,20 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> ADDING") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> OVERWRITING") + END IF END IF found = .TRUE. END DO @@ -3351,18 +3363,20 @@ CONTAINS END IF IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> ADDING QM/MM forcefield specifications") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> OVERWRITING QM/MM forcefield specifications") + END IF END IF found = .TRUE. END IF @@ -3633,9 +3647,10 @@ CONTAINS IF (PRESENT(atm3)) fmt = fmt + 1 IF (PRESENT(atm4)) fmt = fmt + 1 CALL integer_to_string(fmt - 1, sfmt) - IF (fmt > 1) & + IF (fmt > 1) THEN my_format = '(T2,"FORCEFIELD| Missing ","'//TRIM(type_name)// & '",T40,"(",A9,'//TRIM(sfmt)//'(",",A9),")")' + END IF IF (PRESENT(fatal)) fatal = .TRUE. ! Check for previous already stored equal force fields IF (ASSOCIATED(array)) nsize = SIZE(array) @@ -3660,8 +3675,9 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN found = .TRUE. + END IF CASE ("Urey-Bradley") IF (INDEX(array(i) (21:39), "Urey-Bradley") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3671,8 +3687,9 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN found = .TRUE. + END IF CASE ("Torsion") IF (INDEX(array(i) (21:39), "Torsion") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3684,8 +3701,9 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) & + ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) THEN found = .TRUE. + END IF CASE ("Improper") IF (INDEX(array(i) (21:39), "Improper") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3701,8 +3719,9 @@ CONTAINS ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm2)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm3)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) & + ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) THEN found = .TRUE. + END IF CASE ("Out of plane bend") IF (INDEX(array(i) (21:39), "Out of plane bend") == 0) CYCLE @@ -3715,8 +3734,9 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) & + ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) THEN found = .TRUE. + END IF CASE ("Charge") IF (INDEX(array(i) (21:39), "Charge") == 0) CYCLE diff --git a/src/force_fields_input.F b/src/force_fields_input.F index 28fccce750..89bcf55132 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -135,8 +135,9 @@ CONTAINS SELECT CASE (ff_type%ff_type) CASE (do_ff_charmm, do_ff_amber, do_ff_g96, do_ff_g87) CALL section_vals_val_get(ff_section, "PARM_FILE_NAME", c_val=ff_type%ff_file_name) - IF (TRIM(ff_type%ff_file_name) == "") & + IF (TRIM(ff_type%ff_file_name) == "") THEN CPABORT("Force Field Parameter's filename is empty! Please check your input file.") + END IF CASE (do_ff_undef) ! Do Nothing CASE DEFAULT @@ -538,8 +539,8 @@ CONTAINS ipbv%a(13) = 8756947519.029_dp ipbv%a(14) = 15793297761.67_dp ipbv%a(15) = 12917180227.21_dp - ELSEIF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & - ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN + ELSE IF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & + ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN ipbv%rcore = 2.95_dp ! a.u. ipbv%m = -0.004025691139759147_dp ! Hartree/a.u. @@ -559,7 +560,7 @@ CONTAINS ipbv%a(13) = -4224406093.918E0_dp ipbv%a(14) = 217192386506.5E0_dp ipbv%a(15) = -157581228915.5_dp - ELSEIF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN + ELSE IF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN ipbv%rcore = 3.165_dp ! a.u. ipbv%m = 0.002639704108787555_dp ! Hartree/a.u. ipbv%b = -0.2735482611857583_dp ! Hartree @@ -599,12 +600,12 @@ CONTAINS ft%a = cp_unit_to_cp2k(424.097_dp, "eV") ft%c = cp_unit_to_cp2k(1.05_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(0.499_dp, "eV*angstrom^8") - ELSEIF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & - ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN + ELSE IF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & + ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN ft%a = cp_unit_to_cp2k(1256.31_dp, "eV") ft%c = cp_unit_to_cp2k(7.00_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(8.676_dp, "eV*angstrom^8") - ELSEIF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN + ELSE IF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN ft%a = cp_unit_to_cp2k(3488.998_dp, "eV") ft%c = cp_unit_to_cp2k(72.50_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(145.427_dp, "eV*angstrom^8") @@ -1271,10 +1272,11 @@ CONTAINS ! Calculate p_inv the inverse of the matrix p p_inv(:, :) = 0.0_dp CALL invert_matrix(p, p_inv, eval_error) - IF (eval_error >= 1.0E-8_dp) & + IF (eval_error >= 1.0E-8_dp) THEN CALL cp_warn(__LOCATION__, & "The polynomial fit for the BUCK4RANGES potential is only accurate to "// & TRIM(cp_to_string(eval_error))) + END IF ! Get the 6 coefficients of the 5th-order polynomial -> x(1:6) ! and the 4 coefficients of the 3rd-order polynomial -> x(7:10) x(:) = MATMUL(p_inv(:, :), v(:)) diff --git a/src/global_types.F b/src/global_types.F index 9d076d7514..6ce57fe286 100644 --- a/src/global_types.F +++ b/src/global_types.F @@ -139,8 +139,9 @@ CONTAINS CPASSERT(globenv%ref_count > 0) globenv%ref_count = globenv%ref_count - 1 IF (globenv%ref_count == 0) THEN - IF (ALLOCATED(globenv%gaussian_rng_stream)) & + IF (ALLOCATED(globenv%gaussian_rng_stream)) THEN DEALLOCATE (globenv%gaussian_rng_stream) + END IF DEALLOCATE (globenv) END IF END IF diff --git a/src/graphcon.F b/src/graphcon.F index 7a06c59b4e..e2ecc59f35 100644 --- a/src/graphcon.F +++ b/src/graphcon.F @@ -547,7 +547,7 @@ CONTAINS IF (q(k) == k) THEN q(k) = n ELSE - go to 1 + GOTO 1 END IF END DO first = .TRUE. diff --git a/src/grid/grid_api.F b/src/grid/grid_api.F index f93b6072be..3868fa9a47 100644 --- a/src/grid/grid_api.F +++ b/src/grid/grid_api.F @@ -474,14 +474,18 @@ CONTAINS hadb=hadb_cptr, & a_hdab=a_hdab_cptr) - IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) & + IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) THEN force_a = force_a + forces(:, 1) - IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) & + END IF + IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) THEN force_b = force_b + forces(:, 2) - IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) & + END IF + IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) THEN my_virial_a = my_virial_a + virials(:, :, 1) - IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) & + END IF + IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) THEN my_virial_b = my_virial_b + virials(:, :, 2) + END IF END SUBROUTINE integrate_pgf_product diff --git a/src/grpp/libgrpp.F b/src/grpp/libgrpp.F index 820b585bca..07b19227b7 100644 --- a/src/grpp/libgrpp.F +++ b/src/grpp/libgrpp.F @@ -16,6 +16,10 @@ MODULE libgrpp USE ISO_C_BINDING, ONLY: C_DOUBLE,& C_INT32_T + IMPLICIT NONE + + PRIVATE + INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_DIRAC = 0 INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_TURBOMOLE = 1 @@ -26,6 +30,12 @@ MODULE libgrpp INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_FERMI_BUBBLE = 4 INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_POINT_CHARGE_NUMERICAL = 5 + PUBLIC :: libgrpp_init + PUBLIC :: libgrpp_type1_integrals + PUBLIC :: libgrpp_type1_integrals_gradient + PUBLIC :: libgrpp_type2_integrals + PUBLIC :: libgrpp_type2_integrals_gradient + INTERFACE SUBROUTINE libgrpp_init() diff --git a/src/gw_integrals.F b/src/gw_integrals.F index 30582ab92c..9036627e7d 100644 --- a/src/gw_integrals.F +++ b/src/gw_integrals.F @@ -128,7 +128,7 @@ CONTAINS IF (ctx%op_ij == do_potential_truncated .OR. ctx%op_ij == do_potential_short) THEN ctx%dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor ctx%dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (ctx%op_ij == do_potential_coulomb) THEN + ELSE IF (ctx%op_ij == do_potential_coulomb) THEN ctx%dr_ij = 1000000.0_dp ctx%dr_ik = 1000000.0_dp END IF diff --git a/src/gw_large_cell_gamma_ri_rs.F b/src/gw_large_cell_gamma_ri_rs.F index 5dda82c272..d80730fb64 100644 --- a/src/gw_large_cell_gamma_ri_rs.F +++ b/src/gw_large_cell_gamma_ri_rs.F @@ -395,9 +395,28 @@ CONTAINS IF (.NOT. ASSOCIATED(orb_basis_set)) RETURN - IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0; END IF - IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0; END IF - IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0; END IF + IF (cell%perd(1) == 1) THEN + ix_min = -1 + ix_max = 1 + ELSE + ix_min = 0 + ix_max = 0 + END IF + IF (cell%perd(2) == 1) THEN + iy_min = -1 + iy_max = 1 + ELSE + iy_min = 0 + iy_max = 0 + END IF + + IF (cell%perd(3) == 1) THEN + iz_min = -1 + iz_max = 1 + ELSE + iz_min = 0 + iz_max = 0 + END IF r_atom = particle_set(iatom)%r @@ -952,9 +971,27 @@ CONTAINS natom = SIZE(bs_env%i_ao_start_from_atom) - IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0; END IF - IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0; END IF - IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0; END IF + IF (cell%perd(1) == 1) THEN + ix_min = -1 + ix_max = 1 + ELSE + ix_min = 0 + ix_max = 0 + END IF + IF (cell%perd(2) == 1) THEN + iy_min = -1 + iy_max = 1 + ELSE + iy_min = 0 + iy_max = 0 + END IF + IF (cell%perd(3) == 1) THEN + iz_min = -1 + iz_max = 1 + ELSE + iz_min = 0 + iz_max = 0 + END IF !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, max_ao_size, & diff --git a/src/gw_non_periodic_ri_rs.F b/src/gw_non_periodic_ri_rs.F index 7c0cea6568..0cf7dfc5ef 100644 --- a/src/gw_non_periodic_ri_rs.F +++ b/src/gw_non_periodic_ri_rs.F @@ -258,14 +258,16 @@ CONTAINS DO i = 1, SIZE(zet_ao, 1) DO j = 1, SIZE(zet_ao, 2) - IF (zet_ao(i, j) > 1.0E-3_dp) & + IF (zet_ao(i, j) > 1.0E-3_dp) THEN alpha_min_ao_kind(ikind) = MIN(alpha_min_ao_kind(ikind), zet_ao(i, j)) + END IF END DO END DO DO i = 1, SIZE(zet_ri, 1) DO j = 1, SIZE(zet_ri, 2) - IF (zet_ri(i, j) > 1.0E-3_dp) & + IF (zet_ri(i, j) > 1.0E-3_dp) THEN alpha_min_ri_kind(ikind) = MIN(alpha_min_ri_kind(ikind), zet_ri(i, j)) + END IF END DO END DO END DO diff --git a/src/gw_utils.F b/src/gw_utils.F index e1f635b340..a4206cac50 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -1401,8 +1401,9 @@ CONTAINS num_pe = para_env%num_pe ! if not already set, use all processors for the group (for large-cell GW, performance ! seems to be best for a single group with all MPI processes per group) - IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) & + IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) THEN bs_env%group_size_tensor = num_pe + END IF ! group_size_tensor must divide num_pe without rest; otherwise everything will be complicated IF (MODULO(num_pe, bs_env%group_size_tensor) /= 0) THEN @@ -2052,15 +2053,17 @@ CONTAINS DO i = 1, SIZE(exp_RI, 1) DO j = 1, SIZE(exp_RI, 2) IF (exp_RI(i, j) < exp_min_RI .AND. exp_RI(i, j) > 1E-3_dp) exp_min_RI = exp_RI(i, j) - IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) & + IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) THEN exp_RI_kind(ikind) = exp_RI(i, j) + END IF END DO END DO DO i = 1, SIZE(exp_ao, 1) DO j = 1, SIZE(exp_ao, 2) IF (exp_ao(i, j) < exp_min_ao .AND. exp_ao(i, j) > 1E-3_dp) exp_min_ao = exp_ao(i, j) - IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) & + IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) THEN exp_ao_kind(ikind) = exp_ao(i, j) + END IF END DO END DO radius_ao_kind(ikind) = SQRT(-LOG(eps)/exp_ao_kind(ikind)) diff --git a/src/gx_ac_unittest.F b/src/gx_ac_unittest.F index edbb4a1617..d962c3e789 100644 --- a/src/gx_ac_unittest.F +++ b/src/gx_ac_unittest.F @@ -11,17 +11,21 @@ ! ************************************************************************************************** PROGRAM gx_ac_unittest #include "base/base_uses.f90" -#if !defined(__GREENX) - ! Abort and inform that GreenX was not included in the compilation - ! Ideally, this will be avoided in testing by the conditional tests - CPABORT("CP2K not compiled with GreenX library.") -#else +#if defined(__GREENX) USE kinds, ONLY: dp USE gx_ac, ONLY: create_thiele_pade, & evaluate_thiele_pade_at, & free_params, & params +#endif + IMPLICIT NONE + +#if !defined(__GREENX) + ! Abort and inform that GreenX was not included in the compilation + ! Ideally, this will be avoided in testing by the conditional tests + CPABORT("CP2K not compiled with GreenX library.") +#else ! Create the dataset containing the fitting data ! Two Lorentzian peaks with some overlap COMPLEX(kind=dp) :: damp_one = (2, 0), & diff --git a/src/hartree_local_methods.F b/src/hartree_local_methods.F index 78f4033388..44e58782e8 100644 --- a/src/hartree_local_methods.F +++ b/src/hartree_local_methods.F @@ -329,8 +329,9 @@ CONTAINS basis_set=basis_1c, basis_type="GAPW_1C") cneo = ASSOCIATED(cneo_potential) - IF (cneo .AND. tddft) & + IF (cneo .AND. tddft) THEN CPABORT("Electronic TDDFT with CNEO quantum nuclei is not implemented.") + END IF NULLIFY (nuc_basis) max_iso_not0_nuc = 0 @@ -372,8 +373,9 @@ CONTAINS END IF nchan_0 = nsoset(lmax0) - IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) & + IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) THEN CPABORT("channels for rho0 > # max of spherical harmonics") + END IF NULLIFY (Vh1_h, Vh1_s) ALLOCATE (Vh1_h(nr, max_iso_not0)) diff --git a/src/hdf5_wrapper.F b/src/hdf5_wrapper.F index 24a9388303..d80bd6b9cc 100644 --- a/src/hdf5_wrapper.F +++ b/src/hdf5_wrapper.F @@ -35,9 +35,16 @@ MODULE hdf5_wrapper IMPLICIT NONE + PRIVATE + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hdf5_wrapper' #ifdef __HDF5 INTEGER, PARAMETER, PUBLIC :: hdf5_id = hid_t + + PUBLIC :: h5aread_double_scalar, h5awrite_boolean, h5awrite_double_scalar, h5awrite_double_simple + PUBLIC :: h5awrite_fixlen_string, h5awrite_integer_scalar, h5awrite_integer_simple + PUBLIC :: h5awrite_string_simple, h5close, h5dread_double_simple, h5dwrite_double_simple, h5fclose + PUBLIC :: h5fcreate, h5fopen, h5gclose, h5gcreate, h5gopen, h5open #endif CONTAINS diff --git a/src/hfx_ace_methods.F b/src/hfx_ace_methods.F index 501997a8ef..e095b59ca0 100644 --- a/src/hfx_ace_methods.F +++ b/src/hfx_ace_methods.F @@ -182,15 +182,17 @@ CONTAINS nspins = dft_control%nspins IF (n_rep_hf /= 1) CPABORT("ACE: only one &HF section is supported.") - IF (dft_control%nimages /= 1) & + IF (dft_control%nimages /= 1) THEN CPABORT("ACE: k-points / multiple images are not implemented.") + END IF ! ACE requires explicit MO coefficients (C_occ) which are only available ! with diagonalization-based SCF. OT never constructs mo_coeff during ! the SCF, so the ACE projector build loop would silently get garbage. CALL get_qs_env(qs_env, scf_control=scf_control) - IF (scf_control%use_ot) & + IF (scf_control%use_ot) THEN CPABORT("ACE: OT doesn't work, use diagonalization-based SCF.") + END IF rebuild_freq = MAX(1, ace_rebuild_frequency) @@ -198,8 +200,9 @@ CONTAINS ! Bypass A: energy-only call ! ------------------------------------------------------------------ IF (just_energy) THEN - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T2,A)') 'ACE | just_energy=T: full HFX (no matrix update)' + END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -211,8 +214,9 @@ CONTAINS ! Bypass B: ionic forces requested ! ------------------------------------------------------------------ IF (calculate_forces) THEN - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T2,A)') 'ACE | calculate_forces=T: full HFX for exact forces' + END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -271,13 +275,15 @@ CONTAINS IF (ace_built_now) THEN ace_is_built = .TRUE. ace_step_counter = 1 - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'ACE | W built. Projector live from next step.' + END IF ELSE ace_is_built = .FALSE. ace_step_counter = 0 - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'ACE | Build deferred (C_occ=0). Full HFX in ks_matrix.' + END IF END IF ELSE @@ -409,8 +415,9 @@ CONTAINS v_rspace_new, v_tau_rspace, ext_xc_section) ehfx_full = energy%ex - IF (DBG_BUILD .AND. iw > 0) & + IF (DBG_BUILD .AND. iw > 0) THEN WRITE (iw, '(/,T2,A,F20.10)') 'ACE BUILD | E_x(full HFX) = ', ehfx_full + END IF ! Allocate / resize module storage IF (ALLOCATED(ace_W)) THEN @@ -426,9 +433,10 @@ CONTAINS ! ---------------------------------------------------------------- DO ispin = 1, nspins - IF (mos_for_ace(ispin)%use_mo_coeff_b) & + IF (mos_for_ace(ispin)%use_mo_coeff_b) THEN CALL copy_dbcsr_to_fm(mos_for_ace(ispin)%mo_coeff_b, & mos_for_ace(ispin)%mo_coeff) + END IF CALL get_mo_set(mos_for_ace(ispin), mo_coeff=mo_coeff, & nao=nao, nmo=nmo, homo=nocc, & @@ -450,8 +458,9 @@ CONTAINS END IF IF (frob < 1.0e-20_dp) THEN - IF (DBG_BUILD .AND. iw > 0) & + IF (DBG_BUILD .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'mo_coeff=0: build deferred to next step.' + END IF CALL timestop(handle) RETURN END IF @@ -530,12 +539,14 @@ CONTAINS CPABORT("ACE: Cholesky of -M failed (not positive definite).") END IF - IF (DBG_BUILD .AND. iw > 0) & + IF (DBG_BUILD .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'Cholesky OK (info=0).' + END IF ! Step 7: W = xi * U^{-1} - IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) & + IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) THEN CALL cp_fm_release(ace_W(1, ispin)) + END IF CALL cp_fm_create(ace_W(1, ispin), xi_fm%matrix_struct, name="W_ACE") CALL cp_fm_to_fm(xi_fm, ace_W(1, ispin)) @@ -735,9 +746,10 @@ CONTAINS CALL cp_fm_release(P_fm) CALL cp_fm_release(PW_fm) - IF (DBG_ENERGY .AND. iw > 0) & + IF (DBG_ENERGY .AND. iw > 0) THEN WRITE (iw, '(T4,A,I4,A,F20.10)') & - 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val + 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val + END IF END DO energy%ex = ehfx_ace @@ -776,15 +788,17 @@ CONTAINS IF (do_admm) THEN CALL get_admm_env(admm_env, mos_aux_fit=mos_aux_diag) - IF (mos_aux_diag(ispin)%use_mo_coeff_b) & + IF (mos_aux_diag(ispin)%use_mo_coeff_b) THEN CALL copy_dbcsr_to_fm(mos_aux_diag(ispin)%mo_coeff_b, & mos_aux_diag(ispin)%mo_coeff) + END IF CALL get_mo_set(mos_aux_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) ELSE - IF (mos_diag(ispin)%use_mo_coeff_b) & + IF (mos_diag(ispin)%use_mo_coeff_b) THEN CALL copy_dbcsr_to_fm(mos_diag(ispin)%mo_coeff_b, & mos_diag(ispin)%mo_coeff) + END IF CALL get_mo_set(mos_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) END IF diff --git a/src/hfx_admm_utils.F b/src/hfx_admm_utils.F index 95aa6eb99c..502353ae25 100644 --- a/src/hfx_admm_utils.F +++ b/src/hfx_admm_utils.F @@ -213,8 +213,9 @@ CONTAINS IF (PRESENT(ext_xc_section)) hfx_sections => section_vals_get_subs_vals(ext_xc_section, "HF") CALL section_vals_get(hfx_sections, n_repetition=n_rep_hf) - IF (n_rep_hf > 1) & + IF (n_rep_hf > 1) THEN CPABORT("ADMM can handle only one HF section.") + END IF IF (.NOT. ASSOCIATED(admm_env)) THEN ! setup admm environment @@ -228,8 +229,9 @@ CONTAINS admm_env=admm_env) ! Initialize the GAPW data types - IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) & + IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN CALL init_admm_gapw(qs_env) + END IF ! ADMM neighbor lists and overlap matrices CALL admm_init_hamiltonians(admm_env, qs_env, "AUX_FIT") @@ -304,11 +306,13 @@ CONTAINS CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) !Test combinations of input values. So far, only ADMM2 is availavle - IF (.NOT. admm_env%purification_method == do_admm_purify_none) & + IF (.NOT. admm_env%purification_method == do_admm_purify_none) THEN CPABORT("Only ADMM_PURIFICATION_METHOD NONE implemeted for ADMM K-points") + END IF IF (.NOT. (dft_control%admm_control%method == do_admm_basis_projection & - .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) & + .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) THEN CPABORT("Only BASIS_PROJECTION and CHARGE_CONSTRAINED_PROJECTION implemented for KP") + END IF IF (admm_env%do_admms .OR. admm_env%do_admmp .OR. admm_env%do_admmq) THEN IF (use_real_wfn) CPABORT("Only KP-HFX ADMM2 is implemented with REAL wavefunctions") END IF @@ -637,7 +641,7 @@ CONTAINS mic = molecule_only IF (kpoints%nkp > 0) THEN mic = .FALSE. - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN mic = .TRUE. END IF @@ -1239,8 +1243,9 @@ CONTAINS ! Remember: Vhfx is added, energy is calclulated from total Vhfx, ! so energy of last iteration is correct - IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) & + IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) THEN CPABORT("HFX_TREAT_LSD_IN_CORE not implemented for adiabatically rescaled hybrids") + END IF ! everything is calculated with adiabatic rescaling but the potential is not added in a first step distribute_fock_matrix = .NOT. do_adiabatic_rescaling diff --git a/src/hfx_compression_methods.F b/src/hfx_compression_methods.F index d6d0df4ae7..6b9e07e456 100644 --- a/src/hfx_compression_methods.F +++ b/src/hfx_compression_methods.F @@ -225,7 +225,9 @@ CONTAINS !! This happens in case a container has fully been filled in the compression step !! but no other was needed for the current bit size !! Therefore we can safely igonore an eof error + ! We still need to ask for it to read the data correctly, so we mark it as used READ (container%unit, IOSTAT=stat) container%current%data + MARK_USED(stat) memory_usage = memory_usage + 1 container%file_counter = container%file_counter + 1 ELSE diff --git a/src/hfx_energy_potential.F b/src/hfx_energy_potential.F index 679a821530..eec9821017 100644 --- a/src/hfx_energy_potential.F +++ b/src/hfx_energy_potential.F @@ -3123,12 +3123,13 @@ CONTAINS DO mb = 1, mb_max DO ma = 1, ma_max iint = iint + 1 - IF (ABS(prim(iint)) > 0.0000000000001) & + IF (ABS(prim(iint)) > 0.0000000000001) THEN WRITE (99, *) atom_offsets(i, 1) + ma + set_offsets(iset, 1, i, 1) - 1, & - atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & - atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & - atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & - prim(iint) + atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & + atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & + atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & + prim(iint) + END IF END DO END DO END DO diff --git a/src/hfx_exx.F b/src/hfx_exx.F index 4116db4143..c083d86131 100644 --- a/src/hfx_exx.F +++ b/src/hfx_exx.F @@ -567,7 +567,7 @@ CONTAINS xc_section_aux => qs_env%mp2_env%ri_rpa%xc_section_aux xc_section_primary => qs_env%mp2_env%ri_rpa%xc_section_primary END IF - ELSEIF (qs_env%energy_correction) THEN + ELSE IF (qs_env%energy_correction) THEN IF (ASSOCIATED(qs_env%ec_env%xc_section_aux) .AND. & ASSOCIATED(qs_env%ec_env%xc_section_primary)) THEN xc_section_aux => qs_env%ec_env%xc_section_aux diff --git a/src/hfx_load_balance_methods.F b/src/hfx_load_balance_methods.F index 5b13c6a164..38f34ce1e0 100644 --- a/src/hfx_load_balance_methods.F +++ b/src/hfx_load_balance_methods.F @@ -1860,9 +1860,10 @@ CONTAINS ! it also avoids degenerate cases where thousands of zero sized tasks ! are assigned to the same (least loaded) cpu ! - IF (do_randomize) & + IF (do_randomize) THEN rng_stream = rng_stream_type(name="uniform_rng", & distribution_type=UNIFORM) + END IF DO i = total_number_of_bins, 1, -nstep tmp_cpu_cost = my_cost_cpu diff --git a/src/hfx_pw_methods.F b/src/hfx_pw_methods.F index 8551fc0b85..f4a1e7ca5b 100644 --- a/src/hfx_pw_methods.F +++ b/src/hfx_pw_methods.F @@ -147,7 +147,7 @@ CONTAINS END IF IF (potential_type == do_potential_coulomb) THEN CALL pw_copy(poisson_env%green_fft%influence_fn, greenfn) - ELSEIF (potential_type == do_potential_truncated) THEN + ELSE IF (potential_type == do_potential_truncated) THEN CALL section_vals_val_get(ip_section, "CUTOFF_RADIUS", r_val=rcut) grid => poisson_env%green_fft%influence_fn%pw_grid DO ig = grid%first_gne0, grid%ngpts_cut_local @@ -156,9 +156,10 @@ CONTAINS g3d = fourpi/g2 greenfn%array(ig) = g3d*(1.0_dp - COS(rcut*gg)) END DO - IF (grid%have_g0) & + IF (grid%have_g0) THEN greenfn%array(1) = 0.5_dp*fourpi*rcut*rcut - ELSEIF (potential_type == do_potential_short) THEN + END IF + ELSE IF (potential_type == do_potential_short) THEN CALL section_vals_val_get(ip_section, "OMEGA", r_val=omega) IF (omega > 0.0_dp) omega = 0.25_dp/(omega*omega) grid => poisson_env%green_fft%influence_fn%pw_grid diff --git a/src/hfx_ri.F b/src/hfx_ri.F index 23675f8016..087348e6b3 100644 --- a/src/hfx_ri.F +++ b/src/hfx_ri.F @@ -3708,9 +3708,10 @@ CONTAINS CALL get_RI_density_coeffs(density_coeffs, rho_ao, 1, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) - IF (nspins == 2) & + IF (nspins == 2) THEN CALL get_RI_density_coeffs(density_coeffs_2, rho_ao, 2, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) + END IF unit_nr = cp_print_key_unit_nr(logger, input, "DFT%XC%HF%RI%PRINT%RI_DENSITY_COEFFS", & extension=".dat", file_status="REPLACE", & diff --git a/src/hfx_ri_kp.F b/src/hfx_ri_kp.F index 238d2f9b50..2093e39aad 100644 --- a/src/hfx_ri_kp.F +++ b/src/hfx_ri_kp.F @@ -250,8 +250,9 @@ CONTAINS !We do all the checks on what we allow in this initial implementation IF (ri_data%flavor /= ri_pmat) CPABORT("K-points RI-HFX only with RHO flavor") IF (ri_data%same_op) ri_data%same_op = .FALSE. !force the full calculation with RI metric - IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) & + IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) THEN CPABORT("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points") + END IF CALL get_kp_and_ri_images(ri_data, qs_env) nimg = ri_data%nimg @@ -3637,8 +3638,9 @@ CONTAINS DO i_img = 1, nimg DO i_spin = 1, nspins - IF (.NOT. (i_img == 1 .AND. i_spin == 1)) & + IF (.NOT. (i_img == 1 .AND. i_spin == 1)) THEN CALL dbt_create(rho_ao_t_sub(1, 1), rho_ao_t_sub(i_spin, i_img)) + END IF CALL copy_2c_to_subgroup(rho_ao_t_sub(i_spin, i_img), rho_ao_t(i_spin, i_img), & group_size, ngroups, para_env) CALL dbt_destroy(rho_ao_t(i_spin, i_img)) @@ -4398,8 +4400,9 @@ CONTAINS CALL neighbor_list_iterator_release(nl_iterator) CALL release_neighbor_list_sets(nl_2c) CALL para_env%max(ri_data%nimg) - IF (ri_data%nimg > nimg) & + IF (ri_data%nimg > nimg) THEN CPABORT("Make sure the smallest exponent of the RI-HFX basis is larger than that of the ORB basis.") + END IF !Keep track of which images will not contribute, so that can be ignored before calculation CALL para_env%sum(present_img) diff --git a/src/hfx_types.F b/src/hfx_types.F index 1c11cc9d77..d81fd2de0e 100644 --- a/src/hfx_types.F +++ b/src/hfx_types.F @@ -778,8 +778,9 @@ CONTAINS actual_x_data%load_balance_parameter%do_randomize = logic_val actual_x_data%load_balance_parameter%rtp_redistribute = .FALSE. - IF (ASSOCIATED(dft_control%rtp_control)) & + IF (ASSOCIATED(dft_control%rtp_control)) THEN actual_x_data%load_balance_parameter%rtp_redistribute = dft_control%rtp_control%hfx_redistribute + END IF CALL section_vals_val_get(hf_sub_section, "BLOCK_SIZE", i_val=int_val) ! negative values ask for a computed default @@ -1044,11 +1045,13 @@ CONTAINS ! Sanity checks IF (actual_x_data%use_ace) THEN ! ACE requires HFX to be meaningful - IF (actual_x_data%general_parameter%fraction <= 0.0_dp) & + IF (actual_x_data%general_parameter%fraction <= 0.0_dp) THEN CPABORT("ACE requires FRACTION > 0.") + END IF ! If frequency is 1, it is full HFX - IF (actual_x_data%ace_rebuild_freq < 1) & + IF (actual_x_data%ace_rebuild_freq < 1) THEN CPABORT("ACE: REBUILD_FREQUENCY must be >= 1") + END IF END IF END IF END DO @@ -1216,8 +1219,9 @@ CONTAINS ri_metric%scale_longrange = hfx_pot%scale_longrange END IF - IF (ri_metric%potential_type == do_potential_short) & + IF (ri_metric%potential_type == do_potential_short) THEN CALL erfc_cutoff(ri_data%eps_schwarz, ri_metric%omega, ri_metric%cutoff_radius) + END IF IF (ri_metric%potential_type == do_potential_id) ri_metric%cutoff_radius = 0.0_dp END ASSOCIATE @@ -1432,7 +1436,7 @@ CONTAINS DEALLOCATE (dist1, dist2) CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(2, 1)) - ELSEIF (ri_data%flavor == ri_mo) THEN + ELSE IF (ri_data%flavor == ri_mo) THEN ALLOCATE (ri_data%t_2c_int(2, 1)) CALL create_2c_tensor(ri_data%t_2c_int(1, 1), dist1, dist2, ri_data%pgrid_2d, & @@ -1622,7 +1626,7 @@ CONTAINS DEALLOCATE (ri_data%blk_indices) DEALLOCATE (ri_data%store_3c) - ELSEIF (ri_data%flavor == ri_mo) THEN + ELSE IF (ri_data%flavor == ri_mo) THEN CALL dbt_destroy(ri_data%t_3c_int_ctr_1(1, 1)) CALL dbt_destroy(ri_data%t_3c_int_ctr_2(1, 1)) DEALLOCATE (ri_data%t_3c_int_ctr_1) diff --git a/src/hfxbase/hfx_compression_core_methods.F b/src/hfxbase/hfx_compression_core_methods.F index 302e5b90b6..bdb6ca7c6a 100644 --- a/src/hfxbase/hfx_compression_core_methods.F +++ b/src/hfxbase/hfx_compression_core_methods.F @@ -21,38 +21,38 @@ MODULE hfx_compression_core_methods ! masks the corresponding number of bits from the right INTEGER(kind=int_8), PARAMETER :: mask_right(0:63) = & - (/0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & + [0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & 1023_int_8, 2047_int_8, 4095_int_8, 8191_int_8, 16383_int_8, 32767_int_8, 65535_int_8, 131071_int_8, & 262143_int_8, 524287_int_8, 1048575_int_8, 2097151_int_8, 4194303_int_8, 8388607_int_8, 16777215_int_8, & 33554431_int_8, 67108863_int_8, 134217727_int_8, 268435455_int_8, 536870911_int_8, 1073741823_int_8, & - 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & + 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & 68719476735_int_8, 137438953471_int_8, 274877906943_int_8, 549755813887_int_8, 1099511627775_int_8, & - 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & - 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & + 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & + 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & 562949953421311_int_8, 1125899906842623_int_8, 2251799813685247_int_8, 4503599627370495_int_8, & 9007199254740991_int_8, 18014398509481983_int_8, 36028797018963967_int_8, 72057594037927935_int_8, & - 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & - 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & - 9223372036854775807_int_8/) + 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & + 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & + 9223372036854775807_int_8] ! masks the corresponding number of bits from the left ! use ishft to avoid explicitly writing -HUGE-1, and keep it out of the array a work-around for a bug in pgi 6.1-1 INTEGER(kind=int_8), PARAMETER :: ugly_duck = ISHFT(1_int_8, 63) INTEGER(kind=int_8), PARAMETER :: mask_left(0:63) = & - (/0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & - -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & - -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & + [0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & + -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & + -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & -18014398509481984_int_8, -9007199254740992_int_8, -4503599627370496_int_8, -2251799813685248_int_8, & -1125899906842624_int_8, -562949953421312_int_8, -281474976710656_int_8, -140737488355328_int_8, & - -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & - -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & + -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & + -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & -274877906944_int_8, -137438953472_int_8, -68719476736_int_8, -34359738368_int_8, -17179869184_int_8, & -8589934592_int_8, -4294967296_int_8, -2147483648_int_8, -1073741824_int_8, -536870912_int_8, & - -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & + -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & -8388608_int_8, -4194304_int_8, -2097152_int_8, -1048576_int_8, -524288_int_8, -262144_int_8, & -131072_int_8, -65536_int_8, -32768_int_8, -16384_int_8, -8192_int_8, -4096_int_8, -2048_int_8, & -1024_int_8, -512_int_8, -256_int_8, -128_int_8, -64_int_8, -32_int_8, -16_int_8, -8_int_8, -4_int_8, & - -2_int_8/) + -2_int_8] PUBLIC :: bits2ints_specific, ints2bits_specific @@ -70,7 +70,7 @@ CONTAINS INTEGER(KIND=int_8), INTENT(OUT) :: full_data(*) full_data(1:Ndata) = packed_data(1:Ndata) - END SUBROUTINE + END SUBROUTINE ints2ints ! Nbits : number of relevant bits per int in the bit stream (this includes all bits) ! Ndata : number of ints that need to be extracted from the bit stream @@ -160,22 +160,30 @@ CONTAINS idata = idata + 1 IF (ibits_remaining >= Nbits) THEN data_tmp = full_data(idata) - data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left - pack_tmp = IOR(pack_tmp, data_tmp) ! add to the packed data + ! put bits on the left + data_tmp = ISHFT(data_tmp, 64 - Nbits) + ! add to the packed data + pack_tmp = IOR(pack_tmp, data_tmp) ibits_remaining = ibits_remaining - Nbits - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! and shift to the right to make place for the next + ! and shift to the right to make place for the next + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ELSE i_odd_bits = ibits_remaining data_tmp = full_data(idata) - data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left - data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) ! restrict to those bits for which we still have space + ! put bits on the left + data_tmp = ISHFT(data_tmp, 64 - Nbits) + ! restrict to those bits for which we still have space + data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) pack_tmp = IOR(pack_tmp, data_tmp) ! add them to the packed bits ipack = ipack + 1 - packed_data(ipack) = pack_tmp ! store the full packed data away and start with a new one + ! store the full packed data away and start with a new one + packed_data(ipack) = pack_tmp data_tmp = full_data(idata) - pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) ! put the missing bits on the left if pack_tmp + ! put the missing bits on the left if pack_tmp + pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) ibits_remaining = 64 - Nbits + i_odd_bits - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! shift to make place, but not more than the number of available bits + ! shift to make place, but not more than the number of available bits + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) END IF END DO diff --git a/src/hirshfeld_methods.F b/src/hirshfeld_methods.F index d045ff0a39..f4dbc0691a 100644 --- a/src/hirshfeld_methods.F +++ b/src/hirshfeld_methods.F @@ -220,16 +220,18 @@ CONTAINS IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) & + IF (hirshfeld_env%use_bohr) THEN rco = cp_unit_to_cp2k(rco, "angstrom") + END IF END IF CASE (radius_covalent) CALL get_ptable_info(symbol=esym, covalent_radius=rco, found=found) IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) & + IF (hirshfeld_env%use_bohr) THEN rco = cp_unit_to_cp2k(rco, "angstrom") + END IF END IF CASE (radius_single) CPASSERT(PRESENT(radius)) diff --git a/src/iao_analysis.F b/src/iao_analysis.F index 0e658efcd6..080d92ca5c 100644 --- a/src/iao_analysis.F +++ b/src/iao_analysis.F @@ -1179,7 +1179,7 @@ CONTAINS WRITE (filename, '(A18,I1.1)') "IBO_CENTERS_SPREAD" iw = cp_print_key_unit_nr(logger, print_section, "", extension=".csp", & middle_name=TRIM(filename), file_position="REWIND", log_filename=.FALSE.) - ELSEIF (PRESENT(iounit)) THEN + ELSE IF (PRESENT(iounit)) THEN iw = iounit ELSE iw = -1 @@ -1702,7 +1702,7 @@ CONTAINS IF (order == 2) THEN aij = aij + 4._dp*mij**2 - (mii - mjj)**2 bij = bij + 4._dp*mij*(mii - mjj) - ELSEIF (order == 4) THEN + ELSE IF (order == 4) THEN aij = aij - mii**4 - mjj**4 + 6._dp*(mii**2 + mjj**2)*mij**2 + & mii**3*mjj + mii*mjj**3 bij = bij + 4._dp*mij*(mii**3 - mjj**3) diff --git a/src/iao_types.F b/src/iao_types.F index ce837e271c..27fa24a883 100644 --- a/src/iao_types.F +++ b/src/iao_types.F @@ -239,8 +239,9 @@ CONTAINS nfrags = 0 DO ii = 1, SIZE(particle_set) - IF (nfrags < particle_set(ii)%fragment_index) & + IF (nfrags < particle_set(ii)%fragment_index) THEN nfrags = particle_set(ii)%fragment_index + END IF END DO logger => cp_get_default_logger() @@ -269,13 +270,13 @@ CONTAINS IF (particle_set(iatom)%fragment_index == jj) THEN totalcol = totalcol + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcoljj = .FALSE. - ELSEIF (lfirstcoljj) THEN + ELSE IF (lfirstcoljj) THEN colskip = colskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF IF (particle_set(iatom)%fragment_index == ii) THEN totalrow = totalrow + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcol = .FALSE. - ELSEIF (lfirstcol) THEN + ELSE IF (lfirstcol) THEN rowskip = rowskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF rowfrag = rowfrag + orb_basis_set_list(ikind)%gto_basis_set%nsgf diff --git a/src/input/cp_output_handling.F b/src/input/cp_output_handling.F index 8abac352bf..ca7c1fb19e 100644 --- a/src/input/cp_output_handling.F +++ b/src/input/cp_output_handling.F @@ -981,33 +981,38 @@ CONTAINS filename_bak_2 = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(i - 1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Moving file "//TRIM(filename_bak_2)// & - " into file "//TRIM(filename_bak_1)//"." + " into file "//TRIM(filename_bak_1)//"." + END IF END IF INQUIRE (FILE=filename_bak_2, EXIST=found) IF (.NOT. found) THEN IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "File "//TRIM(filename_bak_2)//" not existing.." + END IF END IF ELSE ! Shared file: rotate on the source rank only; per-task ! (my_local) files are per-rank, rotated by their owner. - IF (my_local .OR. logger%para_env%is_source()) & + IF (my_local .OR. logger%para_env%is_source()) THEN CALL m_mov(TRIM(filename_bak_2), TRIM(filename_bak_1)) + END IF END IF END DO ! The last backup is always the one with index 1 filename_bak = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Moving file "//TRIM(filename)//" into file "//TRIM(filename_bak)//"." + END IF END IF - IF (my_local .OR. logger%para_env%is_source()) & + IF (my_local .OR. logger%para_env%is_source()) THEN CALL m_mov(TRIM(filename), TRIM(filename_bak)) + END IF ELSE ! Zero the backup history for this new iteration level.. print_key%ibackup(my_backup_level) = 0 @@ -1028,10 +1033,11 @@ CONTAINS END IF IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Writing "//TRIM(print_key%section%name)//" "// & - TRIM(cp_iter_string(logger%iter_info))//" to "// & - TRIM(filename) + TRIM(cp_iter_string(logger%iter_info))//" to "// & + TRIM(filename) + END IF END IF END IF ELSE diff --git a/src/input/cp_parser_ilist_methods.F b/src/input/cp_parser_ilist_methods.F index bb8b41979c..6b178f7ab2 100644 --- a/src/input/cp_parser_ilist_methods.F +++ b/src/input/cp_parser_ilist_methods.F @@ -44,11 +44,12 @@ CONTAINS ind = INDEX(token, "..") READ (UNIT=token(:ind - 1), FMT=*) ilist%istart READ (UNIT=token(ind + 2:), FMT=*) ilist%iend - IF (ilist%istart > ilist%iend) & + IF (ilist%istart > ilist%iend) THEN CALL cp_abort(__LOCATION__, & "Invalid list range specified: "// & TRIM(ADJUSTL(cp_to_string(ilist%istart)))//".."// & TRIM(ADJUSTL(cp_to_string(ilist%iend)))) + END IF ilist%nel_list = ilist%iend - ilist%istart + 1 ilist%ipresent = ilist%istart ilist%in_use = .TRUE. diff --git a/src/input/cp_parser_inpp_methods.F b/src/input/cp_parser_inpp_methods.F index dd2d552f06..1ba2e7f5dc 100644 --- a/src/input/cp_parser_inpp_methods.F +++ b/src/input/cp_parser_inpp_methods.F @@ -53,15 +53,18 @@ CONTAINS is_valid_varname = .FALSE. - IF (LEN(str) == 0) & + IF (LEN(str) == 0) then RETURN + end if - IF (INDEX(alpha, str(1:1)) == 0) & + IF (INDEX(alpha, str(1:1)) == 0) then RETURN + end if DO idx = 2, LEN(str) - IF (INDEX(alphanum, str(idx:idx)) == 0) & + IF (INDEX(alphanum, str(idx:idx)) == 0) then RETURN + end if END DO is_valid_varname = .TRUE. @@ -592,8 +595,9 @@ CONTAINS CPABORT(TRIM(message)) END IF - IF (idx > 0) & + IF (idx > 0) then var_value = TRIM(inpp%variable_value(idx)) + end if newline = input_line(1:pos1 - 3)//var_value//input_line(pos2 + 2:) input_line = newline @@ -605,8 +609,9 @@ CONTAINS pos1 = pos1 + 1 ! move to the start of the variable name pos2 = INDEX(input_line(pos1:), ' ') - IF (pos2 == 0) & + IF (pos2 == 0) then pos2 = LEN_TRIM(input_line(pos1:)) + 1 + end if pos2 = pos1 + pos2 - 2 ! end of the variable name, minus the separating whitespace var_name = input_line(pos1:pos2) diff --git a/src/input/cp_parser_methods.F b/src/input/cp_parser_methods.F index a57066f206..8b9b1bbbc7 100644 --- a/src/input/cp_parser_methods.F +++ b/src/input/cp_parser_methods.F @@ -548,8 +548,9 @@ CONTAINS ! Read input string of fixed length (single line) ! Check for EOF - IF (parser%icol == -1) & + IF (parser%icol == -1) THEN CPABORT("Unexpectetly reached EOF"//TRIM(parser_location(parser))) + END IF length = MIN(len_trim_inputline - parser%icol1 + 1, length) parser%icol1 = parser%icol + 1 diff --git a/src/input/cp_parser_types.F b/src/input/cp_parser_types.F index d4fec0975d..f8a4340268 100644 --- a/src/input/cp_parser_types.F +++ b/src/input/cp_parser_types.F @@ -196,8 +196,9 @@ CONTAINS parser%input_unit = unit_nr IF (PRESENT(file_name)) parser%input_file_name = TRIM(ADJUSTL(file_name)) ELSE - IF (.NOT. PRESENT(file_name)) & + IF (.NOT. PRESENT(file_name)) THEN CPABORT("at least one of filename and unit_nr must be present") + END IF CALL open_file(file_name=TRIM(ADJUSTL(file_name)), & unit_number=parser%input_unit) parser%input_file_name = TRIM(ADJUSTL(file_name)) diff --git a/src/input/input_enumeration_types.F b/src/input/input_enumeration_types.F index 112b8b49ae..ca21d04940 100644 --- a/src/input/input_enumeration_types.F +++ b/src/input/input_enumeration_types.F @@ -175,8 +175,9 @@ CONTAINS END DO PRINT *, enum%i_vals END IF - IF (enum%strict) & + IF (enum%strict) THEN CPABORT("invalid value for enumeration:"//cp_to_string(i)) + END IF res = ADJUSTL(cp_to_string(i)) END IF END FUNCTION enum_i2c @@ -211,11 +212,13 @@ CONTAINS END DO IF (.NOT. found) THEN - IF (enum%strict) & + IF (enum%strict) THEN CPABORT("invalid value for enumeration:"//TRIM(c)) + END IF READ (c, "(i10)", iostat=iostat) res - IF (iostat /= 0) & + IF (iostat /= 0) THEN CPABORT("invalid value for enumeration2:"//TRIM(c)) + END IF END IF END FUNCTION enum_c2i diff --git a/src/input/input_keyword_types.F b/src/input/input_keyword_types.F index 1665d10024..8f33f0b1bd 100644 --- a/src/input/input_keyword_types.F +++ b/src/input/input_keyword_types.F @@ -274,8 +274,9 @@ CONTAINS IF (PRESENT(default_l_val) .OR. PRESENT(default_l_vals) .OR. & PRESENT(default_i_val) .OR. PRESENT(default_i_vals) .OR. & PRESENT(default_r_val) .OR. PRESENT(default_r_vals) .OR. & - PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) & + PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) THEN CPABORT("you should pass either default_val or a default value, not both") + END IF keyword%default_value => default_val IF (ASSOCIATED(default_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN @@ -310,10 +311,11 @@ CONTAINS " assumed undefined type by default") END IF ELSE IF (PRESENT(type_of_var)) THEN - IF (keyword%type_of_var /= type_of_var) & + IF (keyword%type_of_var /= type_of_var) THEN CALL cp_abort(__LOCATION__, & "keyword "//TRIM(keyword%names(1))// & " has a type different from the type of the default_value") + END IF keyword%type_of_var = type_of_var END IF @@ -325,15 +327,17 @@ CONTAINS IF (PRESENT(lone_keyword_l_val) .OR. PRESENT(lone_keyword_l_vals) .OR. & PRESENT(lone_keyword_i_val) .OR. PRESENT(lone_keyword_i_vals) .OR. & PRESENT(lone_keyword_r_val) .OR. PRESENT(lone_keyword_r_vals) .OR. & - PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) & + PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) THEN CALL cp_abort(__LOCATION__, & "you should pass either lone_keyword_val or a lone_keyword value, not both") + END IF keyword%lone_keyword_value => lone_keyword_val CALL val_retain(lone_keyword_val) IF (ASSOCIATED(lone_keyword_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN - IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) & + IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) THEN CPABORT("keyword%enum/=lone_keyword_val%enum") + END IF ELSE IF (ASSOCIATED(keyword%lone_keyword_value)) THEN CPABORT(".NOT. ASSOCIATED(keyword%lone_keyword_value)") @@ -355,8 +359,9 @@ CONTAINS IF (keyword%lone_keyword_value%type_of_var == no_t) THEN CALL val_release(keyword%lone_keyword_value) ELSE - IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) & + IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) THEN CPABORT("lone_keyword_value type incompatible with keyword type") + END IF ! lc_val cannot have lone_keyword_value! IF (keyword%type_of_var == enum_t) THEN IF (keyword%enum%strict) THEN @@ -364,8 +369,9 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) & + IF (.NOT. check) THEN CPABORT("default value not in enumeration : "//keyword%names(1)) + END IF END IF END IF END IF @@ -384,8 +390,9 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) & + IF (.NOT. check) THEN CPABORT("default value not in enumeration : "//keyword%names(1)) + END IF END IF keyword%n_var = SIZE(keyword%default_value%i_val) CASE (real_t) @@ -401,8 +408,9 @@ CONTAINS END SELECT END IF IF (PRESENT(n_var)) keyword%n_var = n_var - IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) & + IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) THEN CPABORT("arrays of lchar_t not supported : "//keyword%names(1)) + END IF IF (PRESENT(unit_str)) THEN ALLOCATE (keyword%unit) @@ -760,10 +768,11 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(keyword%description))) & //"" - IF (ALLOCATED(keyword%deprecation_notice)) & + IF (ALLOCATED(keyword%deprecation_notice)) THEN WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & - //"" + TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & + //"" + END IF IF (ASSOCIATED(keyword%default_value) .AND. & (keyword%type_of_var /= no_t)) THEN diff --git a/src/input/input_parsing.F b/src/input/input_parsing.F index dab4ca7b6b..332e6791ef 100644 --- a/src/input/input_parsing.F +++ b/src/input/input_parsing.F @@ -93,22 +93,25 @@ CONTAINS output_unit = cp_logger_get_default_io_unit() CPASSERT(section_vals%ref_count > 0) - IF (root_sect .AND. parser%icol1 > parser%icol2) & + IF (root_sect .AND. parser%icol1 > parser%icol2) THEN CALL cp_abort(__LOCATION__, & "Error 1: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) + END IF section => section_vals%section IF (root_sect) THEN token = TRIM(ADJUSTL(parser%input_line(parser%icol1:parser%icol2))) ! Ignore leading or trailing blanks CALL uppercase(token) - IF (token /= parser%section_character//section%name) & + IF (token /= parser%section_character//section%name) THEN CALL cp_abort(__LOCATION__, & "Error 2: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) + END IF END IF - IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) & + IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) THEN CALL cp_abort(__LOCATION__, "Section "//TRIM(section%name)// & " should not repeat "//TRIM(parser_location(parser))) + END IF CALL section_vals_add_values(section_vals) irs = SIZE(section_vals%values, 2) @@ -138,10 +141,11 @@ CONTAINS lower_to_upper=.TRUE., at_end=at_end) token = TRIM(ADJUSTL(token)) ! Ignore leading or trailing blanks IF (at_end) THEN - IF (root_sect) & + IF (root_sect) THEN CALL cp_abort(__LOCATION__, & "unexpected end of file while parsing section "// & TRIM(section%name)//" "//TRIM(parser_location(parser))) + END IF EXIT END IF IF (token(1:1) == parser%section_character) THEN @@ -269,15 +273,17 @@ CONTAINS END IF END IF - IF (ALLOCATED(keyword%deprecation_notice)) & + IF (ALLOCATED(keyword%deprecation_notice)) THEN CALL cp_warn(__LOCATION__, & "The specified keyword '"//TRIM(token)// & "' is deprecated and may be removed in a future version: "// & keyword%deprecation_notice) + END IF NULLIFY (el) - IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) & + IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) THEN CALL parser_skip_space(parser) + END IF CALL val_create_parsing(el, type_of_var=keyword%type_of_var, & n_var=keyword%n_var, default_value=keyword%lone_keyword_value, & enum=keyword%enum, unit=keyword%unit, & @@ -289,10 +295,11 @@ CONTAINS IF (.NOT. ASSOCIATED(last_val)) THEN section_vals%values(ik, irs)%list => new_val ELSE - IF (.NOT. keyword%repeats) & + IF (.NOT. keyword%repeats) THEN CALL cp_abort(__LOCATION__, & "Keyword "//TRIM(token)// & " in section "//TRIM(section%name)//" should not repeat.") + END IF IF (ASSOCIATED(last_val, previous_list)) THEN last_val => previous_last ELSE @@ -524,16 +531,18 @@ CONTAINS END IF END IF CASE (lchar_t) - IF (ASSOCIATED(default_value)) & + IF (ASSOCIATED(default_value)) THEN CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot have a lone keyword attribute,"// & " no value is interpreted as empty string"// & TRIM(parser_location(parser))) - IF (n_var /= 1) & + END IF + IF (n_var /= 1) THEN CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot be repeated,"// & " one always represent a whole line, till the end"// & TRIM(parser_location(parser))) + END IF IF (parser_test_next_token(parser) == "EOL") THEN ALLOCATE (c_val_p(1)) c_val_p(1) = ' ' @@ -677,11 +686,12 @@ CONTAINS my_unit => unit END IF END IF - IF (.NOT. cp_unit_compatible(unit, my_unit)) & + IF (.NOT. cp_unit_compatible(unit, my_unit)) THEN CALL cp_abort(__LOCATION__, & "Incompatible units. Defined as ("// & TRIM(cp_unit_desc(unit))//") specified in input as ("// & TRIM(cp_unit_desc(my_unit))//"). These units are incompatible!") + END IF END IF CALL parser_get_object(parser, r_val) IF (ASSOCIATED(unit)) THEN diff --git a/src/input/input_section_types.F b/src/input/input_section_types.F index 917c8edeb1..44662e9ed1 100644 --- a/src/input/input_section_types.F +++ b/src/input/input_section_types.F @@ -326,8 +326,9 @@ CONTAINS IF (ASSOCIATED(section)) THEN CPASSERT(section%ref_count > 0) - IF (.NOT. my_hide_root) & + IF (.NOT. my_hide_root) THEN WRITE (UNIT=unit_nr, FMT="('*** section &',A,' ***')") TRIM(ADJUSTL(section%name)) + END IF IF (level > 1) THEN message = get_section_info(section) CALL print_message(TRIM(a2s(section%description))//TRIM(message), unit_nr, 0, 0, 0) @@ -347,8 +348,9 @@ CONTAINS END DO END IF IF (section%n_subsections > 0 .AND. my_recurse >= 0) THEN - IF (.NOT. my_hide_root) & + IF (.NOT. my_hide_root) THEN WRITE (UNIT=unit_nr, FMT="('** subsections **')") + END IF DO isub = 1, section%n_subsections IF (my_recurse > 0) THEN CALL section_describe(section%subsections(isub)%section, unit_nr, & @@ -358,8 +360,9 @@ CONTAINS END IF END DO END IF - IF (.NOT. my_hide_root) & + IF (.NOT. my_hide_root) THEN WRITE (UNIT=unit_nr, FMT="('*** &end section ',A,' ***')") TRIM(ADJUSTL(section%name)) + END IF ELSE WRITE (unit_nr, "(a)") '
' END IF @@ -586,11 +589,12 @@ CONTAINS section%subsections => new_subsections END IF DO i = 1, section%n_subsections - IF (subsection%name == section%subsections(i)%section%name) & + IF (subsection%name == section%subsections(i)%section%name) THEN CALL cp_abort(__LOCATION__, & "trying to add a subsection with a name ("// & TRIM(subsection%name)//") that was already used in section " & //TRIM(section%name)) + END IF END DO CALL section_retain(subsection) section%n_subsections = section%n_subsections + 1 @@ -761,10 +765,11 @@ CONTAINS isection = section_get_subsection_index(section_vals%section, subsection_name(1:my_index)) IF (isection > 0) res => section_vals%subs_vals(isection, irep)%section_vals - IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) & + IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) THEN CALL cp_abort(__LOCATION__, & "could not find subsection "//TRIM(subsection_name(1:my_index))//" in section "// & TRIM(section_vals%section%name)//" at ") + END IF IF (is_path .AND. ASSOCIATED(res)) THEN res => section_vals_get_subs_vals(res, subsection_name(my_index + 2:LEN_TRIM(subsection_name)), & i_rep_section, can_return_null) @@ -1096,16 +1101,18 @@ CONTAINS PRESENT(c_val) .OR. PRESENT(l_vals) .OR. PRESENT(i_vals) .OR. & PRESENT(r_vals) .OR. PRESENT(c_vals) ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) + END IF keyword => section%keywords(ik)%keyword - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF NULLIFY (my_val) IF (PRESENT(n_rep_val)) n_rep_val = 0 IF (irs <= SIZE(s_vals%values, 2)) THEN ! the section was parsed @@ -1128,11 +1135,12 @@ CONTAINS END IF IF (PRESENT(val)) val => my_val IF (valRequested) THEN - IF (.NOT. ASSOCIATED(my_val)) & + IF (.NOT. ASSOCIATED(my_val)) THEN CALL cp_abort(__LOCATION__, & "Value requested, but no value set getting value from "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF CALL val_get(my_val, l_val=l_val, i_val=i_val, r_val=r_val, & c_val=c_val, l_vals=l_vals, i_vals=i_vals, r_vals=r_vals, & c_vals=c_vals) @@ -1183,15 +1191,17 @@ CONTAINS IF (PRESENT(i_rep_section)) irs = i_rep_section section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + END IF + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF list => s_vals%values(ik, irs)%list END SUBROUTINE section_vals_list_get @@ -1266,20 +1276,22 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) + END IF ! Add values.. DO IF (irs <= SIZE(s_vals%values, 2)) EXIT CALL section_vals_add_values(s_vals) END DO - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF keyword => s_vals%section%keywords(ik)%keyword NULLIFY (my_val) IF (PRESENT(val)) my_val => val @@ -1288,18 +1300,20 @@ CONTAINS PRESENT(r_vals_ptr) .OR. PRESENT(c_vals_ptr) IF (ASSOCIATED(my_val)) THEN ! check better? - IF (valSet) & + IF (valSet) THEN CALL cp_abort(__LOCATION__, & " both val and values present, in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF ELSE ! ignore ? - IF (.NOT. valSet) & + IF (.NOT. valSet) THEN CALL cp_abort(__LOCATION__, & " empty value in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF CPASSERT(valSet) IF (keyword%type_of_var == lchar_t) THEN CALL val_create(my_val, lc_val=c_val, lc_vals_ptr=c_vals_ptr) @@ -1316,11 +1330,12 @@ CONTAINS IF (irk == -1) THEN CALL cp_sll_val_insert_el_at(vals, my_val, index=-1) ELSE IF (irk <= cp_sll_val_get_length(vals)) THEN - IF (irk <= 0) & + IF (irk <= 0) THEN CALL cp_abort(__LOCATION__, & "invalid irk "//TRIM(ADJUSTL(cp_to_string(irk)))// & " in keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF old_val => cp_sll_val_get_el_at(vals, index=irk) CALL val_release(old_val) CALL cp_sll_val_set_el_at(vals, value=my_val, index=irk) @@ -1386,17 +1401,19 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) + END IF ! ignore unset of non set values IF (irs <= SIZE(s_vals%values, 2)) THEN - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF IF (irk == -1) THEN pos => cp_sll_val_get_rest(s_vals%values(ik, irs)%list, iter=-1) ELSE @@ -1589,10 +1606,11 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(section%description))) & //"" - IF (ALLOCATED(section%deprecation_notice)) & + IF (ALLOCATED(section%deprecation_notice)) THEN WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & - //"" + TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & + //"" + END IF IF (ASSOCIATED(section%citations)) THEN DO i = 1, SIZE(section%citations, 1) @@ -1735,10 +1753,11 @@ CONTAINS CPASSERT(irep <= SIZE(s_vals%subs_vals, 2)) isection = section_get_subsection_index(s_vals%section, subsection_name(my_index:LEN_TRIM(subsection_name))) - IF (isection <= 0) & + IF (isection <= 0) THEN CALL cp_abort(__LOCATION__, & "could not find subsection "//subsection_name(my_index:LEN_TRIM(subsection_name))//" in section "// & TRIM(section_vals%section%name)//" at ") + END IF CALL section_vals_retain(new_section_vals) CALL section_vals_release(s_vals%subs_vals(isection, irep)%section_vals) s_vals%subs_vals(isection, irep)%section_vals => new_section_vals @@ -1813,10 +1832,12 @@ CONTAINS END DO END DO IF (.NOT. PRESENT(i_rep_low) .AND. (.NOT. PRESENT(i_rep_high))) THEN - IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) & + IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) THEN CPABORT("Incompatible sizes of values between input and output") - IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) & + END IF + IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) THEN CPABORT("Incompatible sizes of subsections between input and output") + END IF END IF iend = SIZE(section_vals_in%subs_vals, 2) IF (PRESENT(i_rep_high)) iend = i_rep_high diff --git a/src/input/input_val_types.F b/src/input/input_val_types.F index 9ac7220f12..83580f89e0 100644 --- a/src/input/input_val_types.F +++ b/src/input/input_val_types.F @@ -399,23 +399,26 @@ CONTAINS IF (val%type_of_var == lchar_t) THEN l_in = default_string_length*(SIZE(val%c_val) - 1) + & LEN_TRIM(val%c_val(SIZE(val%c_val))) - IF (l_out < l_in) & + IF (l_out < l_in) THEN CALL cp_warn(__LOCATION__, & "val_get will truncate value, value beginning with '"// & TRIM(val%c_val(1))//"' is too long for variable") + END IF DO i = 1, SIZE(val%c_val) c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = & val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length)) IF (l_out <= i*default_string_length) EXIT END DO - IF (l_out > SIZE(val%c_val)*default_string_length) & + IF (l_out > SIZE(val%c_val)*default_string_length) THEN c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = "" + END IF ELSE l_in = LEN_TRIM(val%c_val(1)) - IF (l_out < l_in) & + IF (l_out < l_in) THEN CALL cp_warn(__LOCATION__, & "val_get will truncate value, value '"// & TRIM(val%c_val(1))//"' is too long for variable") + END IF c_val = val%c_val(1) END IF ELSE diff --git a/src/input_cp2k_check.F b/src/input_cp2k_check.F index 273e17ad76..87a01c5aaf 100644 --- a/src/input_cp2k_check.F +++ b/src/input_cp2k_check.F @@ -80,8 +80,9 @@ CONTAINS CPASSERT(ASSOCIATED(input_file)) CPASSERT(input_file%ref_count > 0) ! ext_restart - IF (PRESENT(output_unit)) & + IF (PRESENT(output_unit)) THEN CALL handle_ext_restart(input_declaration, input_file, para_env, output_unit) + END IF ! checks on force_eval section sections => section_vals_get_subs_vals(input_file, "FORCE_EVAL") @@ -146,13 +147,15 @@ CONTAINS ! do not allow the use of external potential section => section_vals_get_subs_vals(sections, "DFT%EXTERNAL_POTENTIAL") CALL section_vals_get(section, explicit=apply_ext_potential) - IF (apply_ext_potential) & + IF (apply_ext_potential) THEN CPABORT("The EXTERNAL_POTENTIAL section is not allowed for the MiMiC runtype.") + END IF ! force eval methods supported with MiMiC CALL section_vals_val_get(sections, "METHOD", i_val=force_eval_method) - IF (force_eval_method /= do_qs) & + IF (force_eval_method /= do_qs) THEN CPABORT("At the moment, only Quickstep method is supported with MiMiC.") + END IF END IF CALL timestop(handle) @@ -431,29 +434,33 @@ CONTAINS IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_COORD") CALL section_vals_set_subs_vals(section2, "SHELL_COORD", section) - IF (check_restart(section1, section2, "SHELL_COORD")) & + IF (check_restart(section1, section2, "SHELL_COORD")) THEN CALL set_restart_info("SHELL COORDINATES", restarted_infos) + END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_POS", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_COORD") CALL section_vals_set_subs_vals(section2, "CORE_COORD", section) - IF (check_restart(section1, section2, "CORE_COORD")) & + IF (check_restart(section1, section2, "CORE_COORD")) THEN CALL set_restart_info("CORE COORDINATES", restarted_infos) + END IF END IF CALL section_vals_val_get(r_section, "RESTART_SHELL_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_VELOCITY") CALL section_vals_set_subs_vals(section2, "SHELL_VELOCITY", section) - IF (check_restart(section1, section2, "SHELL_VELOCITY")) & + IF (check_restart(section1, section2, "SHELL_VELOCITY")) THEN CALL set_restart_info("SHELL VELOCITIES", restarted_infos) + END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_VELOCITY") CALL section_vals_set_subs_vals(section2, "CORE_VELOCITY", section) - IF (check_restart(section1, section2, "CORE_VELOCITY")) & + IF (check_restart(section1, section2, "CORE_VELOCITY")) THEN CALL set_restart_info("CORE VELOCITIES", restarted_infos) + END IF END IF END IF ELSE @@ -977,18 +984,20 @@ CONTAINS CALL section_vals_set_subs_vals(input_file, TRIM(path)//"%AD_LANGEVIN%MASS", section) END SELECT ELSE - IF (input_type /= restart_type) & + IF (input_type /= restart_type) THEN CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of thermostat! Restarting is not possible! "// & "Thermostat will not be restarted! ") - IF (input_region /= restart_region) & + END IF + IF (input_region /= restart_region) THEN CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of REGION! Restarting is not possible! "// & "Thermostat will not be restarted! ") + END IF END IF END IF END SUBROUTINE restart_thermostat diff --git a/src/input_cp2k_restarts_util.F b/src/input_cp2k_restarts_util.F index 2411d815ec..c281e5f8b7 100644 --- a/src/input_cp2k_restarts_util.F +++ b/src/input_cp2k_restarts_util.F @@ -62,10 +62,11 @@ CONTAINS CPASSERT(velocity_section%ref_count > 0) section => velocity_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF ! At least one of the two arguments must be present.. check = PRESENT(particles) .NEQV. PRESENT(velocity) diff --git a/src/input_restart_force_eval.F b/src/input_restart_force_eval.F index 77181ca694..e333517e4b 100644 --- a/src/input_restart_force_eval.F +++ b/src/input_restart_force_eval.F @@ -555,10 +555,11 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT @@ -689,10 +690,11 @@ CONTAINS CPASSERT(dipoles_section%ref_count > 0) section => dipoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF ! At least one of the two arguments must be present.. nloop = SIZE(dipoles, 2) @@ -766,10 +768,11 @@ CONTAINS CPASSERT(quadrupoles_section%ref_count > 0) section => quadrupoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF ! At least one of the two arguments must be present.. nloop = SIZE(quadrupoles, 2) diff --git a/src/input_restart_rng.F b/src/input_restart_rng.F index 51913f61cf..ea236ff010 100644 --- a/src/input_restart_rng.F +++ b/src/input_restart_rng.F @@ -61,10 +61,11 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(rng_section%values, 2) == 1) EXIT diff --git a/src/ipi_driver.F b/src/ipi_driver.F index ea8b57b9a3..19404bd82f 100644 --- a/src/ipi_driver.F +++ b/src/ipi_driver.F @@ -212,8 +212,9 @@ CONTAINS CALL para_env%bcast(combuf) CALL force_env_get(force_env, subsys=subsys) - IF (nat /= subsys%particles%n_els) & + IF (nat /= subsys%particles%n_els) THEN CPABORT("@DRIVER MODE: Uh-oh! Particle number mismatch between i-PI and cp2k input!") + END IF ii = 0 DO ip = 1, subsys%particles%n_els DO idir = 1, 3 diff --git a/src/ipi_server.F b/src/ipi_server.F index 8cb6ac0d66..488e5a19b4 100644 --- a/src/ipi_server.F +++ b/src/ipi_server.F @@ -179,16 +179,18 @@ CONTAINS ! Step 1: See if the client is ready CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "READY") & + IF (TRIM(msgbuffer) /= "READY") THEN CPABORT("i–PI: Expected READY header but recieved "//TRIM(msgbuffer)) + END IF ! Step 2: Send cell and position data to client CALL send_posdata(comm_socket, subsys=ipi_env%subsys) ! Step 3: Ask for status, should be done now CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "HAVEDATA") & + IF (TRIM(msgbuffer) /= "HAVEDATA") THEN CPABORT("i–PI: Expected HAVEDATA header but recieved "//TRIM(msgbuffer)) + END IF ! Step 4: Ask for data ALLOCATE (forces(3, nAtom)) @@ -267,8 +269,9 @@ CONTAINS ! Exchange headers CALL writebuffer(sockfd, msg, msglength) CALL get_header(sockfd, msgbuffer) - IF (TRIM(msgbuffer) /= "FORCEREADY") & + IF (TRIM(msgbuffer) /= "FORCEREADY") THEN CPABORT("i–PI: Expected FORCEREADY header but recieved "//TRIM(msgbuffer)) + END IF ! Recieve data CALL readbuffer(sockfd, energy) diff --git a/src/iterate_matrix.F b/src/iterate_matrix.F index d78f5a3191..4a6b4b3a88 100644 --- a/src/iterate_matrix.F +++ b/src/iterate_matrix.F @@ -1177,8 +1177,9 @@ CONTAINS END IF END DO - IF (.NOT. converged) & + IF (.NOT. converged) THEN CPABORT("dense_matrix_sign_Newton_Schulz did not converge within 100 iterations") + END IF DEALLOCATE (tmp1) DEALLOCATE (tmp2) @@ -1807,8 +1808,9 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) & + IF (abnormal_value(conv)) THEN CPABORT("conv is an abnormal value (NaN/Inf).") + END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN @@ -2028,8 +2030,9 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) & + IF (abnormal_value(conv)) THEN CPABORT("conv is an abnormal value (NaN/Inf).") + END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN diff --git a/src/kg_correction.F b/src/kg_correction.F index ab870ac90a..3377337cde 100644 --- a/src/kg_correction.F +++ b/src/kg_correction.F @@ -309,8 +309,9 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) & + IF (ASSOCIATED(vxc_tau)) THEN ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) + END IF END DO END IF END IF @@ -409,8 +410,9 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) & + IF (ASSOCIATED(vxc_tau)) THEN ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) + END IF END DO END IF END IF diff --git a/src/kg_vertex_coloring_methods.F b/src/kg_vertex_coloring_methods.F index bf437d443f..d95ccc533a 100644 --- a/src/kg_vertex_coloring_methods.F +++ b/src/kg_vertex_coloring_methods.F @@ -667,8 +667,9 @@ CONTAINS valid = .FALSE. CALL check_coloring(graph, valid) - IF (.NOT. valid) & + IF (.NOT. valid) THEN CPABORT("Coloring not valid.") + END IF nnodes = SIZE(kg_env%molecule_set) diff --git a/src/kpoint_io.F b/src/kpoint_io.F index e7e544a0a0..a7e2ee483c 100644 --- a/src/kpoint_io.F +++ b/src/kpoint_io.F @@ -231,7 +231,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -266,7 +266,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 diff --git a/src/kpoint_methods.F b/src/kpoint_methods.F index 1c579b7dac..6abad3f2a7 100644 --- a/src/kpoint_methods.F +++ b/src/kpoint_methods.F @@ -2299,14 +2299,14 @@ CONTAINS CALL dbcsr_iterator_next_block(iter, irow, icol, rblock) IF (.NOT. ALLOCATED(rwork)) THEN ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSEIF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN + ELSE IF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (rwork) ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF IF (.NOT. real_only) THEN IF (.NOT. ALLOCATED(cwork)) THEN ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSEIF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN + ELSE IF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (cwork) ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF diff --git a/src/kpoint_transitional.F b/src/kpoint_transitional.F index fba771ac76..3a0ca3aa07 100644 --- a/src/kpoint_transitional.F +++ b/src/kpoint_transitional.F @@ -47,8 +47,9 @@ CONTAINS TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: res IF (ASSOCIATED(this%ptr_1d)) THEN - IF (SIZE(this%ptr_2d, 2) /= 1) & + IF (SIZE(this%ptr_2d, 2) /= 1) THEN CPABORT("Method not implemented for k-points") + END IF END IF res => this%ptr_1d diff --git a/src/kpoint_types.F b/src/kpoint_types.F index 2f949201c3..10a0dd0c05 100644 --- a/src/kpoint_types.F +++ b/src/kpoint_types.F @@ -566,8 +566,9 @@ CONTAINS IF (PRESENT(full_grid)) full_grid = kpoint%full_grid IF (PRESENT(inversion_symmetry_only)) inversion_symmetry_only = kpoint%inversion_symmetry_only IF (PRESENT(symmetry_backend)) symmetry_backend = kpoint%symmetry_backend - IF (PRESENT(symmetry_reduction_method)) & + IF (PRESENT(symmetry_reduction_method)) THEN symmetry_reduction_method = kpoint%symmetry_reduction_method + END IF IF (PRESENT(use_real_wfn)) use_real_wfn = kpoint%use_real_wfn IF (PRESENT(eps_geo)) eps_geo = kpoint%eps_geo IF (PRESENT(parallel_group_size)) parallel_group_size = kpoint%parallel_group_size @@ -681,8 +682,9 @@ CONTAINS IF (PRESENT(full_grid)) kpoint%full_grid = full_grid IF (PRESENT(inversion_symmetry_only)) kpoint%inversion_symmetry_only = inversion_symmetry_only IF (PRESENT(symmetry_backend)) kpoint%symmetry_backend = symmetry_backend - IF (PRESENT(symmetry_reduction_method)) & + IF (PRESENT(symmetry_reduction_method)) THEN kpoint%symmetry_reduction_method = symmetry_reduction_method + END IF IF (PRESENT(use_real_wfn)) kpoint%use_real_wfn = use_real_wfn IF (PRESENT(eps_geo)) kpoint%eps_geo = eps_geo IF (PRESENT(parallel_group_size)) kpoint%parallel_group_size = parallel_group_size diff --git a/src/kpsym.F b/src/kpsym.F index 170c44e613..4342c92f8b 100644 --- a/src/kpsym.F +++ b/src/kpsym.F @@ -188,10 +188,12 @@ CONTAINS a02(i) = a2(i)/alat a03(i) = a3(i)/alat END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| NUMBER OF ATOMS (STRUCT):",I6)') nat - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",10X,"K TYPE",14X,"X(K)")') + END IF itype = 0 DO i = 1, nat ! Assign an atomic type (for internal purposes) @@ -206,19 +208,22 @@ CONTAINS END IF itype = itype + 1 IF (itype > nsp) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,I4,")")') & - ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & - nsp - IF (iout > 0) & + ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & + nsp + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| THE ARRAY TY IS:",/,9(1X,10I7,/))') & - (ty(j), j=1, nat) + (ty(j), j=1, nat) + END IF CALL stopgm('K290', 'FATAL ERROR') END IF 178 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",6X,I5,I6,3F10.5)') & - i, ty(i), (xkapa(j, i), j=1, 3) + i, ty(i), (xkapa(j, i), j=1, 3) + END IF END DO ! ==--------------------------------------------------------------== ! IS THE STRAIN SIGNIFICANT ? @@ -264,11 +269,12 @@ CONTAINS ! ==--------------------------------------------------------------== invadd = 0 IF (li == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,A,/,A)') & - ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & - ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & - ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' + ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & + ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & + ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' + END IF invadd = 1 END IF ! ==--------------------------------------------------------------== @@ -283,101 +289,125 @@ CONTAINS ! ==--------------------------------------------------------------== ! == GROUP-THEORETICAL INFORMATION == ! ==--------------------------------------------------------------== - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM| GROUP-THEORETICAL INFORMATION:")') + END IF ! IHG .... Point group of the primitive lattice, holohedral - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(" KPSYM| POINT GROUP OF THE PRIMITIVE LATTICE: ",A," SYSTEM")') & - icst(ihg) + icst(ihg) + END IF ! IHC .... Code distinguishing between hexagonal and cubic groups ! ISY .... Code indicating whether the space group is symmorphic IF (isy == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP")') - ELSEIF (isy == 1) THEN - IF (iout > 0) & + END IF + ELSE IF (isy == 1) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP")') - ELSEIF (isy == -1) THEN - IF (iout > 0) & + END IF + ELSE IF (isy == -1) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP WITH NON-STANDARD ORIGIN")') - ELSEIF (isy == -2) THEN - IF (iout > 0) & + END IF + ELSE IF (isy == -2) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP???")') + END IF END IF ! LI ..... Inversions symmetry IF (li == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"NO INVERSION SYMMETRY")') - ELSEIF (li > 0) THEN - IF (iout > 0) & + END IF + ELSE IF (li > 0) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"INVERSION SYMMETRY")') + END IF END IF ! NC ..... Total number of elements in the point group - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(" KPSYM|",4X,"TOTAL NUMBER OF ELEMENTS IN THE POINT GROUP:",I3)') nc - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"TO SUM UP: (",I1,5I3,")")') & - ihg, ihc, isy, li, nc, indpg + ihg, ihc, isy, li, nc, indpg + END IF ! IB ..... List of the rotations constituting the point group - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE ROTATIONS:")') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(7X,12I4)') (ib(i), i=1, nc) + END IF ! V ...... Nonprimitive translations (for nonsymmorphic groups) IF (isy <= 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",4X,"NONPRIMITIVE TRANSLATIONS:")') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,A)') & - ' ROT V IN THE BASIS A1, A2, A3 ', & - 'V IN CARTESIAN COORDINATES' + ' ROT V IN THE BASIS A1, A2, A3 ', & + 'V IN CARTESIAN COORDINATES' + END IF ! Cartesian components of nonprimitive translation. DO i = 1, nc DO j = 1, 3 vv0(j) = v(1, i)*a1(j) + v(2, i)*a2(j) + v(3, i)*a3(j) END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(1X,I3,3F10.5,3X,3F10.5)') & - ib(i), (v(j, i), j=1, 3), vv0 + ib(i), (v(j, i), j=1, 3), vv0 + END IF END DO END IF ! F0 ..... The function defined in Maradudin, Ipatova by ! eq. (3.2.12): atom transformation table. - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(/," KPSYM|",4X,"ATOM TRANSFORMATION TABLE (MARADUDIN,VOSKO):")') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(5(4X,"R AT->AT"))') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(I5," [Identity]")') 1 + END IF DO k = 2, nc DO j = 1, nat - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(I5,2I4)', advance="no") ib(k), j, f0(k, j) - IF ((MOD(j, 5) == 0) .AND. iout > 0) & + END IF + IF ((MOD(j, 5) == 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END DO ! R ...... List of the 3 x 3 rotation matrices - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE 3 X 3 ROTATION MATRICES:")') + END IF IF (ihc == 0) THEN DO k = 1, nc - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(4X,I3," (",I2,": ",A11,")",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + END IF END DO ELSE DO k = 1, nc - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(4X,I3," (",I2,": ",A10,") ",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + END IF END DO END IF ! ==--------------------------------------------------------------== @@ -391,34 +421,42 @@ CONTAINS ! (cubic/hexagonal) will apply to the crystal as well as the Bravais ! lattice. ! ==--------------------------------------------------------------== - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/,1X,19("*"),A,25("*"))') & - ' GENERATION OF SPECIAL POINTS ' + ' GENERATION OF SPECIAL POINTS ' + END IF ! Parameter Q of Monkhorst and Pack, generalized for 3 axes B1,2,3 - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,1X,3I5)') & - ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & - iq1, iq2, iq3 + ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & + iq1, iq2, iq3 + END IF ! WVK0 is the shift of the whole mesh (see Macdonald) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,1X,3F10.5)') & - ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 - IF (iabs(iq1) + iabs(iq2) + iabs(iq3) == 0) GOTO 710 + ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 + END IF + IF (ABS(iq1) + ABS(iq2) + ABS(iq3) == 0) GOTO 710 IF (ABS(istriz) /= 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz + END IF CALL stopgm('K290', 'ISTRIZ WRONG ARGUMENT') END IF - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| SYMMETRIZATION SWITCH: ",I3)', advance="no") istriz + END IF IF (istriz == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" (SYMMETRIZATION OF MONKHORST-PACK MESH)")') + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" (NO SYMMETRIZATION OF MONKHORST-PACK MESH)")') + END IF END IF ! Set to 0. DO i = 1, nkpoint @@ -433,12 +471,15 @@ CONTAINS ! rotations than Bravais lattice. ! We use only the rotations for Bravais lattices IF (ntvec == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR BRAVAIS LATTICE', nc0 - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR CRYSTAL LATTICE', nc - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) ' KPSYM| NO DUPLICATION FOUND' + END IF CALL stopgm('ERROR', & 'SOMETHING IS WRONG IN GROUP DETERMINATION') END IF @@ -446,19 +487,24 @@ CONTAINS DO i = 1, nc0 ib(i) = ib0(i) END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/,1X,20("! "),"WARNING",20("!"))') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' - IF (iout > 0) & + ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' + END IF + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' - IF (iout > 0) & + ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' + END IF + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' - IF (iout > 0) & + ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' + END IF + IF (iout > 0) THEN WRITE (iout, '(1X,20("! "),"WARNING",20("!"),/)') + END IF END IF CALL sppt2(iout, iq1, iq2, iq3, wvk0, nkpoint, & a01, a02, a03, b01, b02, b03, & @@ -467,16 +513,18 @@ CONTAINS ! ==--------------------------------------------------------------== ! == Check on error signals == ! ==--------------------------------------------------------------== - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",1X,I5," SPECIAL POINTS GENERATED")') ntot + END IF IF (ntot == 0) THEN GOTO 710 ELSE IF (ntot < 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,I5,/,A,/,A)') ' KPSYM| DIMENSION NKPOINT =', nkpoint, & - ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & - ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' - ntot = iabs(ntot) + ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & + ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' + END IF + ntot = ABS(ntot) END IF ! Before using the list WVKL as wave vectors, they have to be ! multiplied by 2*Pi @@ -485,9 +533,10 @@ CONTAINS DO i = 1, ntot iswght = iswght + lwght(i) END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(8X,A,T33,A,4X,A)') & - 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' + 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' + END IF ! Set near-zeroes equal to zero: DO l = 1, ntot DO i = 1, 3 @@ -508,17 +557,20 @@ CONTAINS END DO END IF lmax = lwght(l) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, fmt='(1X,I5,3F8.4,I8,T42,12I3)') & - l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) + l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) + END IF DO j = 13, lmax, 12 - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, fmt='(T42,12I3)') & - (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) + (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) + END IF END DO END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(24X,"TOTAL:",I8)') iswght + END IF ! ==--------------------------------------------------------------== 710 CONTINUE ! ==--------------------------------------------------------------== @@ -723,12 +775,14 @@ CONTAINS IF (iout > 0) THEN IF (li > 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(1X,A)') & - 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' + 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' + END IF END IF - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) + END IF END IF END SUBROUTINE group1s @@ -1300,138 +1354,139 @@ CONTAINS ! (Thierry Deutsch - 1998 [Maybe not complete!!]) IF (ihg < 6) THEN IF (nc == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC + END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSEIF (nc == 1) THEN + ELSE IF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSEIF (nc == 2 .AND. ib(2) == 25) THEN + ELSE IF (nc == 2 .AND. ib(2) == 25) THEN ! IB=125 indpg = 2 ! <1>(ci) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 4 .OR. & ! 2[001] - ib(2) == 2 .OR. & ! 2[100] - ib(2) == 3)) THEN ! 2[010] + ELSE IF (nc == 2 .AND. ( & + ib(2) == 4 .OR. & ! 2[001] + ib(2) == 2 .OR. & ! 2[100] + ib(2) == 3)) THEN ! 2[010] ! Monoclinic system ! IB=14 (z-axis) OR ! IB=12 (x-axis) OR ! IB=13 (y-axis) indpg = 3 ! 2 (c2) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 28 .OR. & - ib(2) == 26 .OR. & - ib(2) == 27)) THEN + ELSE IF (nc == 2 .AND. ( & + ib(2) == 28 .OR. & + ib(2) == 26 .OR. & + ib(2) == 27)) THEN ! IB=128 (z-axis) OR ! IB=126 (x-axis) OR ! IB=127 (y-axis) indpg = 4 ! m (c1h) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 28 .OR. & ! 2[001] - ib(4) == 27 .OR. & ! 2[010] - ib(4) == 26 .OR. & ! 2[100] - ib(4) == 37 .OR. & ! -2[-110] - ib(4) == 40)) THEN ! 2[110] + ELSE IF (nc == 4 .AND. ( & + ib(4) == 28 .OR. & ! 2[001] + ib(4) == 27 .OR. & ! 2[010] + ib(4) == 26 .OR. & ! 2[100] + ib(4) == 37 .OR. & ! -2[-110] + ib(4) == 40)) THEN ! 2[110] ! IB=1 425 28 (z-axis) OR ! IB=1 225 26 (x-axis) OR ! IB=1 325 27 (y-axis) OR ! IB=113 2537 (-xy-axis)OR ! IB=116 2540 (xy-axis) indpg = 5 ! 2/m(c2h) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 15 .OR. & - ib(4) == 20 .OR. & - ib(4) == 24)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 15 .OR. & + ib(4) == 20 .OR. & + ib(4) == 24)) THEN ! Tetragonal system ! IB=14 1415 (z-axis) OR ! IB=12 1920 (x-axis) OR ! IB=13 2224 (y-axis) indpg = 11 ! 4 (c4) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 39 .OR. & - ib(4) == 44 .OR. & - ib(4) == 48)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 39 .OR. & + ib(4) == 44 .OR. & + ib(4) == 48)) THEN ! IB=14 3839 (z-axis) OR ! IB=12 4344 (x-axis) OR ! IB=13 4648 (y-axis) indpg = 12 ! <4>(s4) - ELSEIF (nc == 8 .AND. ( & - (ib(3) == 14 .AND. ib(8) == 39) .OR. & - (ib(3) == 19 .AND. ib(8) == 44) .OR. & - (ib(3) == 22 .AND. ib(8) == 48))) THEN + ELSE IF (nc == 8 .AND. ( & + (ib(3) == 14 .AND. ib(8) == 39) .OR. & + (ib(3) == 19 .AND. ib(8) == 44) .OR. & + (ib(3) == 22 .AND. ib(8) == 48))) THEN ! IB=14 1415 2825 3839 (z-axis) OR ! IB=12 1920 2625 4344 (x-axis) OR ! IB=13 2224 2725 4648 (y-axis) indpg = 13 ! 422(d4) - ELSEIF (nc == 8 .AND. ib(4) == 4 .AND. ( & - ib(8) == 16 .OR. & - ib(8) == 20 .OR. & - ib(8) == 24)) THEN + ELSE IF (nc == 8 .AND. ib(4) == 4 .AND. ( & + ib(8) == 16 .OR. & + ib(8) == 20 .OR. & + ib(8) == 24)) THEN ! IB=12 3 413 1415 16 (z-axis) OR ! IB=12 3 417 1920 18 (x-axis) OR ! IB=12 3 421 2224 23 (y-axis) indpg = 14 ! 4/m(c4h) - ELSEIF (nc == 8 .AND. ( & - ib(8) == 40 .OR. & - ib(8) == 42 .OR. & - ib(8) == 47)) THEN + ELSE IF (nc == 8 .AND. ( & + ib(8) == 40 .OR. & + ib(8) == 42 .OR. & + ib(8) == 47)) THEN ! IB=14 1415 2627 3740 (z-axis) OR ! IB=12 1920 2827 4142 (x-axis) OR ! IB=13 2224 2628 4547 (y-axis) indpg = 15 ! 4mm(c4v) - ELSEIF (nc == 8 .AND. ( & - (ib(3) == 13 .AND. ib(8) == 39) .OR. & - (ib(3) == 17 .AND. ib(8) == 44) .OR. & - (ib(3) == 21 .AND. ib(8) == 48))) THEN + ELSE IF (nc == 8 .AND. ( & + (ib(3) == 13 .AND. ib(8) == 39) .OR. & + (ib(3) == 17 .AND. ib(8) == 44) .OR. & + (ib(3) == 21 .AND. ib(8) == 48))) THEN ! IB=14 1316 2627 3839 (z-axis) OR ! IB=12 1718 2827 4344 (x-axis) OR ! IB=13 2123 2628 4648 (y-axis) indpg = 16 ! <4>2m(d2d) - ELSEIF (nc == 16 .AND. ( & - ib(16) == 40 .OR. & - ib(16) == 44 .OR. & - ib(16) == 48)) THEN + ELSE IF (nc == 16 .AND. ( & + ib(16) == 40 .OR. & + ib(16) == 44 .OR. & + ib(16) == 48)) THEN ! IB=12 3 413 1415 1625 2627 2837 3839 40 (z-axis) OR ! IB=12 3 417 1920 1825 2627 2841 4344 42 (x-axis) OR ! IB=12 3 421 2224 2325 2627 2845 4648 47 (y-axis) indpg = 17 ! 4/mmm(d4h) - ELSEIF (nc == 4 .AND. (ib(4) == 4)) THEN + ELSE IF (nc == 4 .AND. (ib(4) == 4)) THEN ! Orthorhombic system ! IB=12 3 4 indpg = 25 ! 222(d2) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 27 .OR. & - ib(4) == 28)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 27 .OR. & + ib(4) == 28)) THEN ! IB=13 2627 (z-axis) OR ! IB=12 2728 (x-axis) OR ! IB=14 2628 (y-axis) OR indpg = 26 ! mm2(c2v) - ELSEIF (nc == 8) THEN + ELSE IF (nc == 8) THEN ! IB=12 3 425 2627 28 indpg = 27 ! mmm(d2h) - ELSEIF (nc == 12 .AND. ( & - ib(12) == 12 .OR. & - ib(12) == 47 .OR. & - ib(12) == 45)) THEN + ELSE IF (nc == 12 .AND. ( & + ib(12) == 12 .OR. & + ib(12) == 47 .OR. & + ib(12) == 45)) THEN ! Cubic system ! IB=12 3 4 5 6 7 8 910 1112 OR ! IB=15 1113 1823 2530 3537 4247 OR ! IB=18 1016 1821 2532 3440 4245 indpg = 28 ! 23 (t) - ELSEIF (nc == 24 .AND. ib(24) == 36) THEN + ELSE IF (nc == 24 .AND. ib(24) == 36) THEN ! IB= 1 2 3 4 5 6 7 8 910 1112 ! 2526 2728 2930 3132 3334 3536 indpg = 29 ! m3 (th) - ELSEIF (nc == 24 .AND. ib(24) == 24) THEN + ELSE IF (nc == 24 .AND. ib(24) == 24) THEN ! IB=12 3 45 6 78 9 1011 12 ! 1314 1516 1718 1920 2122 2324 indpg = 30 ! 432 (o) - ELSEIF (nc == 24 .AND. ib(24) == 48) THEN + ELSE IF (nc == 24 .AND. ib(24) == 48) THEN ! IB=12 3 45 6 78 9 1011 12 ! 3738 3940 4142 4345 4647 48 indpg = 31 ! <4>3m(td) - ELSEIF (nc == 48) THEN + ELSE IF (nc == 48) THEN ! IB=1..48 indpg = 32 ! m3m(oh) ELSE @@ -1441,69 +1496,70 @@ CONTAINS ! Probably a sub-group of 32 indpg = -32 END IF - ELSEIF (ihg >= 6) THEN + ELSE IF (ihg >= 6) THEN IF (nc == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC + END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSEIF (nc == 1) THEN + ELSE IF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSEIF (nc == 2 .AND. ib(2) == 13) THEN + ELSE IF (nc == 2 .AND. ib(2) == 13) THEN ! IB=113 indpg = 2 ! <1>(ci) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 4)) THEN ! 2[001] + ELSE IF (nc == 2 .AND. ( & + ib(2) == 4)) THEN ! 2[001] ! Monoclinic system ! IB=1 4 indpg = 3 ! 2 (c2) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 16)) THEN + ELSE IF (nc == 2 .AND. ( & + ib(2) == 16)) THEN ! IB=116 indpg = 4 ! m (c1h) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 24 .OR. & - ib(4) == 20)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 24 .OR. & + ib(4) == 20)) THEN ! IB=112 1324 OR ! IB=1 813 20 indpg = 5 ! 2/m(c2h) - ELSEIF (nc == 3 .AND. ib(3) == 5) THEN + ELSE IF (nc == 3 .AND. ib(3) == 5) THEN ! Trigonal system ! IB=13 5 indpg = 6 ! 3 (c3) - ELSEIF (nc == 6 .AND. ib(6) == 17) THEN + ELSE IF (nc == 6 .AND. ib(6) == 17) THEN ! IB=113 1517 35 indpg = 7 ! <3>(c3i) - ELSEIF (nc == 6 .AND. ib(6) == 11) THEN + ELSE IF (nc == 6 .AND. ib(6) == 11) THEN ! IB=17 9 1135 indpg = 8 ! 32 (d3) - ELSEIF (nc == 6 .AND. ib(6) == 23) THEN + ELSE IF (nc == 6 .AND. ib(6) == 23) THEN ! IB=13 5 1921 23 indpg = 9 ! 3m (c3v) - ELSEIF (nc == 12 .AND. ib(12) == 23) THEN + ELSE IF (nc == 12 .AND. ib(12) == 23) THEN ! IB=13 5 79 1113 1517 1921 23 indpg = 10 ! <3>m(d3d) - ELSEIF (nc == 6 .AND. ib(6) == 6) THEN + ELSE IF (nc == 6 .AND. ib(6) == 6) THEN ! Hexagonal system ! IB=12 3 45 6 indpg = 18 ! 6 (c6) - ELSEIF (nc == 6 .AND. ib(6) == 18) THEN + ELSE IF (nc == 6 .AND. ib(6) == 18) THEN ! IB=13 5 1416 18 indpg = 19 ! <6>(c3h) - ELSEIF (nc == 12 .AND. ib(12) == 18) THEN + ELSE IF (nc == 12 .AND. ib(12) == 18) THEN ! IB=12 3 45 6 1314 1516 1718 indpg = 20 ! 6/m(c6h) - ELSEIF (nc == 12 .AND. ib(12) == 12) THEN + ELSE IF (nc == 12 .AND. ib(12) == 12) THEN ! IB=12 3 45 6 78 9 1011 12 indpg = 21 ! 622(d6) - ELSEIF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN + ELSE IF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN ! IB=12 3 45 6 1920 2122 2324 indpg = 22 ! 6mm(c6v) - ELSEIF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN + ELSE IF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN ! IB=13 5 79 1114 1618 2022 24 indpg = 23 ! <6>m2(d3h) - ELSEIF (nc == 24) THEN + ELSE IF (nc == 24) THEN ! IB=1..24 indpg = 24 ! 6/mmm(d6h) ELSE @@ -1540,7 +1596,7 @@ CONTAINS xb(i) = a(i, 1)*origin(1) + a(i, 2)*origin(2) + a(i, 3)*origin(3) END DO isy = -1 - ELSEIF (info == 0) THEN + ELSE IF (info == 0) THEN isy = 0 ELSE isy = -2 @@ -1554,83 +1610,98 @@ CONTAINS ! == Output == ! ==--------------------------------------------------------------== IF (iout > 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) + END IF CALL xstring(icst(ihg), i, j) IF ((ihg == 7 .AND. nc == 24) .OR. & (ihg == 5 .AND. nc == 48)) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,A,A)') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & - icst(ihg) (i:j), & - ' GROUP' + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & + icst(ihg) (i:j), & + ' GROUP' + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,A,A,I2,A)') & - ' KPSYM| THE CRYSTAL SYSTEM IS ', & - icst(ihg) (i:j), & - ' WITH ', nc, ' OPERATIONS:' + ' KPSYM| THE CRYSTAL SYSTEM IS ', & + icst(ihg) (i:j), & + ' WITH ', nc, ' OPERATIONS:' + END IF IF (ihc == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '( 5(5(A13),/))') (rname_hexai(ib(i)), i=1, nc) + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(10(5(A13),/))') (rname_cubic(ib(i)), i=1, nc) + END IF END IF END IF ! ==------------------------------------------------------------== IF (isy == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - ELSEIF (isy == -1) THEN - IF (iout > 0) & + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + END IF + ELSE IF (isy == -1) THEN + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - IF (iout > 0) & + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + END IF + IF (iout > 0) THEN WRITE (iout, '(A,A,/,T3,3F10.6,3X,3F10.6)') & - ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & - '[CARTESIAN] [CRYSTAL]', xb, origin - ELSEIF (isy == 0) THEN - IF (iout > 0) & + ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & + '[CARTESIAN] [CRYSTAL]', xb, origin + END IF + ELSE IF (isy == 0) THEN + IF (iout > 0) THEN WRITE (iout, '(A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' (SUM OF TRANSLATION VECTORS=', vs, ')' - ELSEIF (isy == -2) THEN - IF (iout > 0) & + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' (SUM OF TRANSLATION VECTORS=', vs, ')' + END IF + ELSE IF (isy == -2) THEN + IF (iout > 0) THEN WRITE (iout, '(A,A)') & - ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & - ' SYMMORPHIC OR NOT' - IF (iout > 0) & + ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & + ' SYMMORPHIC OR NOT' + END IF + IF (iout > 0) THEN WRITE (iout, '(A,/,A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & - ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & + ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' + END IF END IF IF (indpg > 0) THEN CALL xstring(pgrp(indpg), i, j) CALL xstring(pgrd(indpg), k, l) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & - pgrd(indpg) (k:l), indpg + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & + pgrd(indpg) (k:l), indpg + END IF ELSE CALL xstring(pgrp(-indpg), i, j) CALL xstring(pgrd(-indpg), k, l) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,I2,A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & - ' SUBGROUP OF ', pgrp(-indpg) (i:j), & - pgrd(-indpg) (k:l), -indpg + ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & + ' SUBGROUP OF ', pgrp(-indpg) (i:j), & + pgrd(-indpg) (k:l), -indpg + END IF END IF IF (ntvec == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec + ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec + ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec + END IF END IF END IF @@ -2403,11 +2474,12 @@ CONTAINS 280 CONTINUE END DO END DO - IF (iremov > 0 .AND. iout > 0) & + IF (iremov > 0 .AND. iout > 0) THEN WRITE (iout, '(A,A,/,A,1X,I6,A,/)') & - ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & - 'TRANSLATION VECTORS', & - ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' + ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & + 'TRANSLATION VECTORS', & + ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' + END IF END IF ! ==--------------------------------------------------------------== ! == IN THE MESH OF WAVEVECTORS, NOW SEARCH FOR EQUIVALENT POINTS:== @@ -2500,59 +2572,72 @@ CONTAINS ! == THE LIST OF WEIGHTS LWGHT IS NOT NORMALIZED == ! ==--------------------------------------------------------------== IF (ntot > nkpoint) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) 'IN SPPT2 NUMBER OF SPECIAL POINTS = ', ntot - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) 'BUT NKPOINT = ', nkpoint + END IF ntot = -1 END IF IF (iout > 0) THEN ! Write the index table relating k points in the mesh ! with special k points - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/,A,4X,A)') & - ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' - IF (iout > 0) & + ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' + END IF + IF (iout > 0) THEN WRITE (iout, '(5(4X,"IK -> SK"))') + END IF DO i = 1, imesh iplace = includ(i)/2 - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(1X,I5,1X,I5)', advance="no") i, iplace - IF ((MOD(i, 5) == 0) .AND. iout > 0) & + END IF + IF ((MOD(i, 5) == 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END IF RETURN ! ==--------------------------------------------------------------== ! == ERROR MESSAGES == ! ==--------------------------------------------------------------== 450 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' + END IF CALL stopgm('SPPT2', 'VECTOR OUTSIDE THE 1BZ') ! ==--------------------------------------------------------------== 470 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) 'MESH SIZE EXCEEDS NKPOINT=', nkpoint + END IF CALL stopgm('SPPT2', 'MESH SIZE EXCEEDED') ! ==--------------------------------------------------------------== 490 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' + END IF CALL stopgm('SPPT2', 'VECTOR NOT IN THE LIST') ! ==--------------------------------------------------------------== RETURN @@ -2615,7 +2700,7 @@ CONTAINS igarbg = 0 RETURN ! ==--------------------------------------------------------------== - ELSEIF ((iplace > -2) .AND. (iplace <= 0)) THEN + ELSE IF ((iplace > -2) .AND. (iplace <= 0)) THEN ! The particular HASH function used in this case: rhash = 0.7890_dp*wvk(1) & + 0.6810_dp*wvk(2) & @@ -2639,10 +2724,11 @@ CONTAINS ipoint = list(ihash) END DO ! List too long - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(2A,/,A)') & - ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & - ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' + ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & + ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' + END IF CALL stopgm('MESH', 'WARNING') ! WVK was not found 130 CONTINUE @@ -2654,12 +2740,14 @@ CONTAINS ! IPLACE=0: add WVK to the list list(ihash) = istore IF (istore > nmesh) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,I10,A,/,A,3F10.5)') & - ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & - ' WVK = ', wvk + ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & + ' WVK = ', wvk + END IF CALL stopgm('MESH', 'WARNING') END IF list(istore) = nil @@ -2691,11 +2779,12 @@ CONTAINS ! == Error - beyond list == ! ==--------------------------------------------------------------== 190 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,A,I5,A,/)') & - ' SUBROUTINE MESH *** WARNING ***', & - ' IPLACE = ', iplace, & - ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' + ' SUBROUTINE MESH *** WARNING ***', & + ' IPLACE = ', iplace, & + ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' + END IF DO i = 1, 3 wvk(i) = 1.0e38_dp END DO diff --git a/src/libint_2c_3c.F b/src/libint_2c_3c.F index e7698ae20d..1fa20a7fd6 100644 --- a/src/libint_2c_3c.F +++ b/src/libint_2c_3c.F @@ -147,7 +147,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op == do_potential_coulomb) THEN + ELSE IF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -515,7 +515,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op == do_potential_coulomb) THEN + ELSE IF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -885,7 +885,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF @@ -1135,7 +1135,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF diff --git a/src/libint_wrapper.F b/src/libint_wrapper.F index edebee3a87..93e9f7b84c 100644 --- a/src/libint_wrapper.F +++ b/src/libint_wrapper.F @@ -120,9 +120,10 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) & + IF (${m_max}$ <= m_max) THEN libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & - = F(${m_max}$+1) + = F(${m_max}$+1) + END IF #endif #:endfor @@ -215,9 +216,10 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) & + IF (${m_max}$ <= m_max) THEN libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) + = F(${m_max}$+1) + END IF #endif #:endfor @@ -287,9 +289,10 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) & + IF (${m_max}$ <= m_max) THEN libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) + = F(${m_max}$+1) + END IF #endif #:endfor diff --git a/src/library_tests.F b/src/library_tests.F index b1f2cbd5b5..0c64f82e17 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -287,7 +287,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env INTEGER :: iw - INTEGER :: i, ierr, j, len, ntim, siz + INTEGER :: i, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ca, cb @@ -298,10 +298,8 @@ CONTAINS DO i = 6, 24 len = 2**i IF (8.0_dp*REAL(len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ca(len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (cb(len), STAT=ierr) - IF (ierr /= 0) EXIT + ALLOCATE (ca(len)) + ALLOCATE (cb(len)) CALL RANDOM_NUMBER(ca) ntim = NINT(1.e7_dp/REAL(len, KIND=dp)) @@ -348,7 +346,7 @@ CONTAINS LOGICAL :: test_matmul, test_dgemm INTEGER :: iw - INTEGER :: i, ierr, j, len, ntim, siz + INTEGER :: i, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart, xdum REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: ma, mb, mc @@ -360,12 +358,9 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mb(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mc(len, len), STAT=ierr) - IF (ierr /= 0) EXIT + ALLOCATE (ma(len, len)) + ALLOCATE (mb(len, len)) + ALLOCATE (mc(len, len)) mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -454,12 +449,9 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mb(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mc(len, len), STAT=ierr) - IF (ierr /= 0) EXIT + ALLOCATE (ma(len, len)) + ALLOCATE (mb(len, len)) + ALLOCATE (mc(len, len)) mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -566,8 +558,8 @@ CONTAINS INTEGER, PARAMETER :: ndate(3) = [12, 48, 96] - INTEGER :: iall, ierr, it, j, len, n(3), ntim, & - radix_in, radix_out, siz, stat + INTEGER :: iall, it, j, len, n(3), ntim, radix_in, & + radix_out, siz, stat COMPLEX(KIND=dp), DIMENSION(4, 4, 4) :: zz COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: ca, cb, cc CHARACTER(LEN=7) :: method @@ -605,8 +597,8 @@ CONTAINS len = radix_out n = len IF (16.0_dp*REAL(len*len*len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ra(len, len, len), STAT=ierr) - ALLOCATE (ca(len, len, len), STAT=ierr) + ALLOCATE (ra(len, len, len)) + ALLOCATE (ca(len, len, len)) CALL RANDOM_NUMBER(ra) ca(:, :, :) = ra CALL RANDOM_NUMBER(ra) @@ -652,25 +644,29 @@ CONTAINS CALL fft3d(FWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is changed in out-of-place FFT !" + " Input array is changed in out-of-place FFT !" + END IF ELSE - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is not changed in out-of-place FFT !" + " Input array is not changed in out-of-place FFT !" + END IF END IF ca(:, :, :) = cc CALL fft3d(BWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is changed in out-of-place FFT !" + " Input array is changed in out-of-place FFT !" + END IF ELSE - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is not changed in out-of-place FFT !" + " Input array is not changed in out-of-place FFT !" + END IF END IF IF (para_env%is_source()) WRITE (iw, *) diff --git a/src/linesearch.F b/src/linesearch.F index 3d9977d78f..8948e11682 100644 --- a/src/linesearch.F +++ b/src/linesearch.F @@ -610,8 +610,9 @@ CONTAINS is_done = .FALSE. - IF (this%gave_up) & + IF (this%gave_up) THEN CPABORT("had to give up, should not be called again") + END IF IF (.NOT. this%have_left) THEN this%left_x = 0.0_dp @@ -685,8 +686,9 @@ CONTAINS IF (this%have_left .AND. this%have_middle .AND. this%have_right) THEN a = this%middle_x - this%left_x b = this%right_x - this%middle_x - IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) & + IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) THEN CPABORT("golden-ratio gone") + END IF IF (a < b) THEN step_size = this%middle_x + a/phi diff --git a/src/local_gemm_api.F b/src/local_gemm_api.F index 7812c45cc1..e45895578f 100644 --- a/src/local_gemm_api.F +++ b/src/local_gemm_api.F @@ -8,6 +8,7 @@ MODULE local_gemm_api USE ISO_C_BINDING, ONLY: C_NULL_PTR, & C_PTR + USE kinds, ONLY: dp #if defined(__SPLA) && defined(__OFFLOAD_GEMM) USE input_constants, ONLY: do_dgemm_spla USE ISO_C_BINDING, ONLY: C_ASSOCIATED, & @@ -83,25 +84,25 @@ CONTAINS INTEGER, INTENT(in) :: m INTEGER, INTENT(in) :: n INTEGER, INTENT(in) :: k - REAL(8), INTENT(in) :: alpha + REAL(KIND=dp), INTENT(in) :: alpha #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(8), DIMENSION(*), INTENT(in), TARGET :: A + REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: A #else - REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: A + REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: A #endif INTEGER, INTENT(in) :: lda #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(8), DIMENSION(*), INTENT(in), TARGET :: B + REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: B #else - REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: B + REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: B #endif INTEGER, INTENT(in) :: ldb - REAL(8), INTENT(in) :: beta + REAL(KIND=dp), INTENT(in) :: beta #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(8), DIMENSION(*), INTENT(inout), TARGET ::C + REAL(KIND=dp), DIMENSION(*), INTENT(inout), TARGET ::C #else - REAL(8), DIMENSION(:, :), INTENT(inout), TARGET :: C + REAL(KIND=dp), DIMENSION(:, :), INTENT(inout), TARGET :: C #endif INTEGER, INTENT(in) :: ldc CLASS(local_gemm_ctxt_type), INTENT(inout) :: ctx diff --git a/src/localization_tb.F b/src/localization_tb.F index 417e0fa0f7..866e1d491f 100644 --- a/src/localization_tb.F +++ b/src/localization_tb.F @@ -147,7 +147,7 @@ CONTAINS IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSEIF (dft_control%restricted) THEN + ELSE IF (dft_control%restricted) THEN IF (iounit > 0) WRITE (iounit, *) & " Unclear how we define MOs / localization in the restricted case ... skipping" ELSE diff --git a/src/localized_moments.F b/src/localized_moments.F index 7f6782fb0e..6a82b95e68 100644 --- a/src/localized_moments.F +++ b/src/localized_moments.F @@ -737,9 +737,10 @@ CONTAINS DO idir = 1, 3 CALL dbcsr_get_readonly_block_p(moments_der(i, idir)%matrix, & iatom, jatom, oblock, found) - IF (found) & + IF (found) THEN qupole_der((i - 1)*3 + idir) = & - qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) + qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) + END IF END DO END DO END IF diff --git a/src/lri_optimize_ri_basis_types.F b/src/lri_optimize_ri_basis_types.F index 41bf462a06..4a79d3914a 100644 --- a/src/lri_optimize_ri_basis_types.F +++ b/src/lri_optimize_ri_basis_types.F @@ -227,8 +227,7 @@ CONTAINS END DO DO ishell = 1, gto_basis_set%nshell(iset) - gcc(:, ishell, iset) = gcc(:, ishell, iset)/ & - SQRT(DOT_PRODUCT(gcc(:, ishell, iset), gcc(:, ishell, iset))) + gcc(:, ishell, iset) = gcc(:, ishell, iset)/NORM2(gcc(:, ishell, iset)) END DO END DO diff --git a/src/manybody_eam.F b/src/manybody_eam.F index 0819359be8..38cc5ba35b 100644 --- a/src/manybody_eam.F +++ b/src/manybody_eam.F @@ -186,7 +186,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) @@ -196,7 +196,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -233,7 +233,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -247,7 +247,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) diff --git a/src/manybody_gal.F b/src/manybody_gal.F index 8c72d24322..cb57bcddd6 100644 --- a/src/manybody_gal.F +++ b/src/manybody_gal.F @@ -81,7 +81,8 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair - rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) !Vector in pbc from j to i + !Vector in pbc from j to i + rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only ALLOCATE (gal%n_vectors(3, SIZE(particle_set))) @@ -98,7 +99,8 @@ CONTAINS Vang = 0.0_dp IF (gcn_weight2 /= 0.0) THEN - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, only the first time + ! that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -106,13 +108,14 @@ CONTAINS particle_set, cell) END IF - nvec(:) = gal%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen + !Else, retrive it, should not have moved sinc metal is supposed to be frozen + nvec(:) = gal%n_vectors(:, jparticle) !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) + weight = EXP(-NORM2(rji)/gal%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = angular(gal, r_last_update_pbc, iparticle, cell, particle_set, nvec, & @@ -223,12 +226,13 @@ CONTAINS IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) drjk2 = DOT_PRODUCT(rjk, rjk) - IF (drjk2 > gal%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + IF (drjk2 > gal%rcutsq) CYCLE normale(:) = normale(:) - rjk(:) !Build the normal, vector by vector END DO ! Normalisation of the vector - normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) + normale(:) = normale(:)/NORM2(normale) END FUNCTION normale @@ -264,9 +268,11 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (element_symbol_k == gal%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r1) !Build the sum of the exponential weights - IF (element_symbol_k == gal%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r2) !Build the sum of the exponential weights + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal%rcutsq) CYCLE + !Build the sum of the exponential weights + IF (element_symbol_k == gal%met1) somme = somme + EXP(-NORM2(rki)/gal%r1) + IF (element_symbol_k == gal%met2) somme = somme + EXP(-NORM2(rki)/gal%r2) END DO END FUNCTION somme @@ -317,11 +323,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -335,7 +341,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -390,7 +396,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only @@ -407,7 +413,8 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IF (gcn_weight2 /= 0.0) THEN - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, only the first time + ! that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -524,7 +531,7 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) + weight_rji = EXP(-NORM2(rji)/gal%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system @@ -532,11 +539,13 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - drki = SQRT(DOT_PRODUCT(rki, rki)) + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal%rcutsq) CYCLE + drki = NORM2(rki) rki_hat(:) = rki(:)/drki - IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) !Build the sum of derivativs + !Build the sum of derivativs + IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) IF (element_symbol_k == gal%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r2)*EXP(-drki/gal%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -587,11 +596,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -603,14 +612,15 @@ CONTAINS END IF rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole + rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector + ! Theta is the angle between the normal to the surface and the dipole + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -618,7 +628,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*gal%a1*SIN(theta) - gal%a2*2.0_dp*SIN(2.0_dp*theta) - & gal%a3*3.0_dp*SIN(3.0_dp*theta) - gal%a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term diff --git a/src/manybody_gal21.F b/src/manybody_gal21.F index c31ac17f5c..7604fe379c 100644 --- a/src/manybody_gal21.F +++ b/src/manybody_gal21.F @@ -105,7 +105,8 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Vang = 0.0_dp - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, + ! only the first time that an interaction with the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -113,13 +114,14 @@ CONTAINS particle_set, cell) END IF - nvec(:) = gal21%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen + ! Else, retrive it, should not have moved sinc metal is supposed to be frozen + nvec(:) = gal21%n_vectors(:, jparticle) !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal21, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) + weight = EXP(-NORM2(rji)/gal21%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = 0.0_dp @@ -229,15 +231,18 @@ CONTAINS IF (kparticle == jparticle) CYCLE !Avoid the principal Me atom (j) in the counting CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals + !Keep only metals + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) - drjk = SQRT(DOT_PRODUCT(rjk, rjk)) - IF (drjk > gal21%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair - normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) !Build the normal, vector by vector + drjk = NORM2(rjk) + !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + IF (drjk > gal21%rcutsq) CYCLE + !Build the normal, vector by vector + normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) END DO ! Normalisation of the vector - normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) + normale(:) = normale(:)/NORM2(normale) END FUNCTION normale @@ -269,11 +274,14 @@ CONTAINS DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals + !Keep only metals + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (element_symbol_k == gal21%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r1) !Build the sum of the exponential weights - IF (element_symbol_k == gal21%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r2) !Build the sum of the exponential weights + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal21%rcutsq) CYCLE + !Build the sum of the exponential weights + IF (element_symbol_k == gal21%met1) somme = somme + EXP(-NORM2(rki)/gal21%r1) + IF (element_symbol_k == gal21%met2) somme = somme + EXP(-NORM2(rki)/gal21%r2) END DO END FUNCTION somme @@ -325,11 +333,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -348,7 +356,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -359,8 +367,7 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) - VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & - EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) + VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*NORM2(rjh1)) + EXP(-BH*NORM2(rjh2))) ! For fit purpose IF (gal21%express .AND. energy) THEN @@ -370,9 +377,8 @@ CONTAINS IF (index_outfile > 0) WRITE (index_outfile, *) "Fourier", costheta, COS(2.0_dp*theta), COS(3.0_dp*theta), & COS(4.0_dp*theta) !, theta - IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & - EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2))) - !IF (index_outfile > 0) WRITE (index_outfile, *) "H_r6", -1/DOT_PRODUCT(rjh1,rjh1)**3 -1/DOT_PRODUCT(rjh2,rjh2)**3 + IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*NORM2(rjh1)) + & + EXP(-BH*NORM2(rjh2)) CALL cp_print_key_finished_output(index_outfile, logger, mm_section, & "PRINT%PROGRAM_RUN_INFO") @@ -415,7 +421,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal21%n_vectors)) THEN !First calling of the forcefield only @@ -430,7 +436,8 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with + ! the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -566,19 +573,22 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) + weight_rji = EXP(-NORM2(rji)/gal21%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals + !Keep only metals + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - drki = SQRT(DOT_PRODUCT(rki, rki)) + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal21%rcutsq) CYCLE + drki = NORM2(rki) rki_hat(:) = rki(:)/drki - IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) !Build the sum of derivativs + !Build the sum of derivativs + IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) IF (element_symbol_k == gal21%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r2)*EXP(-drki/gal21%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -641,11 +651,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -662,14 +672,14 @@ CONTAINS a4 = gal21%a41 + gal21%a42*gal21%gcn(jparticle) + gal21%a43*gal21%gcn(jparticle)*gal21%gcn(jparticle) rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole + rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) ! Theta is the angle between the normal to the surface and the dipole IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -677,7 +687,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*a1*SIN(theta) - a2*2.0_dp*SIN(2.0_dp*theta) - & a3*3.0_dp*SIN(3.0_dp*theta) - a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term @@ -695,35 +705,35 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) f_nonbond(1:3, index_h1) = f_nonbond(1:3, index_h1) + (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))*rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))*rjh1(:)/NORM2(rjh1) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh1(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & - *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))) & + *rjh1(:)/NORM2(rjh1) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh1(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & - *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))) & + *rjh1(:)/NORM2(rjh1) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh1(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & - *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))) & + *rjh1(:)/NORM2(rjh1) END IF rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) f_nonbond(1:3, index_h2) = f_nonbond(1:3, index_h2) + ((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh2(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh2(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh2(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) END IF END SUBROUTINE angular_d diff --git a/src/manybody_nequip.F b/src/manybody_nequip.F index adff300a10..9938d0b82b 100644 --- a/src/manybody_nequip.F +++ b/src/manybody_nequip.F @@ -468,8 +468,9 @@ CONTAINS END IF IF (ASSOCIATED(neq_data%force)) THEN - IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) & + IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) THEN DEALLOCATE (neq_data%force, neq_data%use_indices) + END IF END IF IF (.NOT. ASSOCIATED(neq_data%force)) THEN diff --git a/src/manybody_potential.F b/src/manybody_potential.F index 16b5faec93..9de5d3949d 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -639,8 +639,9 @@ CONTAINS END DO END DO ! ACE - IF (any_ace) & + IF (any_ace) THEN CALL ace_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + END IF DO ikind = 1, nkinds DO jkind = ikind, nkinds @@ -648,8 +649,9 @@ CONTAINS END DO END DO ! DEEPMD - IF (any_deepmd) & + IF (any_deepmd) THEN CALL deepmd_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + END IF ! NEQUIP DO ikind = 1, nkinds diff --git a/src/manybody_siepmann.F b/src/manybody_siepmann.F index 42c619b843..09e29c1ef7 100644 --- a/src/manybody_siepmann.F +++ b/src/manybody_siepmann.F @@ -185,7 +185,7 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) IF (kparticle == jparticle) CYCLE @@ -243,7 +243,7 @@ CONTAINS F = siepmann%F rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji nparticle = SIZE(r_last_update_pbc) @@ -339,19 +339,19 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) DO iatom = 1, natom CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = SQRT(DOT_PRODUCT(rih, rih)) + drih = NORM2(rih) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -363,21 +363,21 @@ CONTAINS ELSE CPABORT("No H atoms for O found") END IF - ELSEIF (count_h == 1) THEN + ELSE IF (count_h == 1) THEN IF (siepmann%allow_oh_formation) THEN IF (PRESENT(nr_oh)) nr_oh = nr_oh + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Only one H atom of O atom found") END IF - ELSEIF (count_h == 3) THEN + ELSE IF (count_h == 3) THEN IF (siepmann%allow_h3o_formation) THEN IF (PRESENT(nr_h3o)) nr_h3o = nr_h3o + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Three H atoms for O atom found") END IF - ELSEIF (count_h > 3) THEN + ELSE IF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -386,7 +386,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = SQRT(DOT_PRODUCT(rix, rix)) + drix = NORM2(rix) cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp IF (cosphi > +1.0_dp) cosphi = +1.0_dp @@ -441,7 +441,7 @@ CONTAINS cell_v, cell, rcutsq, & particle_set) rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji DO iatom = 1, natom @@ -449,23 +449,23 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = SQRT(DOT_PRODUCT(rih, rih)) + drih = NORM2(rih) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO IF (count_h == 0 .AND. .NOT. siepmann%allow_o_formation) THEN CPABORT("No H atoms for O found") - ELSEIF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN + ELSE IF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN CPABORT("Only one H atom for O atom found") - ELSEIF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN + ELSE IF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN CPABORT("Three H atoms for O atom found") - ELSEIF (count_h > 3) THEN + ELSE IF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -474,7 +474,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = SQRT(DOT_PRODUCT(rix, rix)) + drix = NORM2(rix) rix_hat(:) = rix(:)/drix cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp @@ -561,7 +561,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji fac = -1.0_dp !gradient to force @@ -646,7 +646,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) fac = -1.0_dp Phi_ij = siep_Phi_ij(siepmann, r_last_update_pbc, iparticle, jparticle, & diff --git a/src/manybody_tersoff.F b/src/manybody_tersoff.F index 9f86baecab..719e662a37 100644 --- a/src/manybody_tersoff.F +++ b/src/manybody_tersoff.F @@ -346,7 +346,7 @@ CONTAINS lambda3 = tersoff%lambda3 rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = SQRT(DOT_PRODUCT(rij, rij)) + drij = NORM2(rij) ter_zeta_ij = 0.0_dp DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) @@ -413,7 +413,7 @@ CONTAINS rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = SQRT(DOT_PRODUCT(rij, rij)) + drij = NORM2(rij) rij_hat(:) = rij(:)/drij nparticle = SIZE(r_last_update_pbc) @@ -576,7 +576,7 @@ CONTAINS CALL timeset(routineN, handle) rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = SQRT(DOT_PRODUCT(rij, rij)) + drij = NORM2(rij) rij_hat(:) = rij(:)/drij fac = -0.5_dp diff --git a/src/mao_basis.F b/src/mao_basis.F index ed28ab101b..6234629519 100644 --- a/src/mao_basis.F +++ b/src/mao_basis.F @@ -261,8 +261,9 @@ CONTAINS ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) & + IF (col_blk_sizes(iab) < 0) THEN CPABORT("Minimum number of MAOs has to be specified in KIND section for all elements") + END IF END DO DO ispin = 1, nspin ! coefficients diff --git a/src/mao_io.F b/src/mao_io.F index 53728ce974..1b300ea47e 100644 --- a/src/mao_io.F +++ b/src/mao_io.F @@ -122,8 +122,10 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) & ! catch corner-case + IF (SIZE(local_block) > 0) THEN + ! catch corner-case mpi_buffer(:, :) = local_block(:, :) + END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/mao_wfn_analysis.F b/src/mao_wfn_analysis.F index ba7f41bdc2..d0d7132444 100644 --- a/src/mao_wfn_analysis.F +++ b/src/mao_wfn_analysis.F @@ -243,8 +243,9 @@ CONTAINS CALL get_particle_set(particle_set, qs_kind_set, nmao=col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) & + IF (col_blk_sizes(iab) < 0) THEN CPABORT("Number of MAOs has to be specified in KIND section for all elements") + END IF END DO DO ispin = 1, nspin ! coeficients diff --git a/src/metadyn_tools/graph.F b/src/metadyn_tools/graph.F index 92444bd6da..62eb7713ea 100644 --- a/src/metadyn_tools/graph.F +++ b/src/metadyn_tools/graph.F @@ -200,8 +200,9 @@ PROGRAM graph END IF END DO - IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) & + IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) THEN CPABORT("Error! You've to specify either ORAC, CP2K or CPMD!") + END IF ! For CPMD move filename to colvar_mtd IF (l_cpmd) THEN @@ -358,9 +359,10 @@ PROGRAM graph END IF END DO - IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) & + IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) THEN CALL cp_abort(__LOCATION__, & "-find-path requires the specification of -point-a and -point-b !") + END IF ELSE ALLOCATE (mep_input_data%minima(0, 0)) END IF @@ -647,7 +649,7 @@ PROGRAM graph IF (.NOT. lstride .AND. MOD(it, nwr) == 0) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" - ELSEIF (.NOT. lstride .AND. it == nt) THEN + ELSE IF (.NOT. lstride .AND. it == nt) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" END IF END DO Hills @@ -663,7 +665,7 @@ PROGRAM graph IF (ncount < 10) THEN WRITE (out3_stride, '(A,i1)') TRIM(out3), ncount - ELSEIF (ncount < 100) THEN + ELSE IF (ncount < 100) THEN WRITE (out3_stride, '(A,i2)') TRIM(out3), ncount ELSE WRITE (out3_stride, '(A,i3)') TRIM(out3), ncount diff --git a/src/metadyn_tools/graph_methods.F b/src/metadyn_tools/graph_methods.F index 739fd093e7..8ec364e70e 100644 --- a/src/metadyn_tools/graph_methods.F +++ b/src/metadyn_tools/graph_methods.F @@ -323,7 +323,7 @@ CONTAINS fes_old = fes_now !WRITE(10+j,'(10f20.10)')(xx(id),id=ndim,1,-1),-fes(pnt) - norm_dx = SQRT(DOT_PRODUCT(dx, dx)) + norm_dx = NORM2(dx) IF (norm_dx == 0.0_dp) EXIT ! It is in a really flat region xx = xx - MIN(0.1_dp, norm_dx)*dx/norm_dx ! Re-evaluating pos @@ -448,7 +448,7 @@ CONTAINS ! compute average length (distance 1) DO irep = 2, nreplica xx = pos(:, irep) - pos(:, irep - 1) - avg1 = avg1 + SQRT(DOT_PRODUCT(xx, xx)) + avg1 = avg1 + NORM2(xx) END DO avg1 = avg1/REAL(nreplica - 1, KIND=dp) @@ -456,7 +456,7 @@ CONTAINS ! compute average length (distance 2) DO irep = 3, nreplica xx = pos(:, irep) - pos(:, irep - 2) - avg2 = avg2 + SQRT(DOT_PRODUCT(xx, xx)) + avg2 = avg2 + NORM2(xx) END DO avg2 = avg2/REAL(nreplica - 2, KIND=dp) @@ -478,7 +478,7 @@ CONTAINS davg2 = 0.0_dp IF (irep < nf - 1) THEN xx = pos(:, irep) - pos(:, irep + 2) - xx0 = SQRT(DOT_PRODUCT(xx, xx)) + xx0 = NORM2(xx) dxx = 1.0_dp/xx0*xx ene = ene + 0.25_dp*mep_input_data%kb*(xx0 - avg2)**2 davg2 = davg2 + dxx @@ -486,7 +486,7 @@ CONTAINS IF (irep > ns + 1) THEN xx = pos(:, irep) - pos(:, irep - 2) - yy0 = SQRT(DOT_PRODUCT(xx, xx)) + yy0 = NORM2(xx) dyy = 1.0_dp/yy0*xx davg2 = davg2 + dyy END IF @@ -503,11 +503,11 @@ CONTAINS ! Evaluation of the elastic term ! ------------------------------------------------------------- xx = pos(:, irep) - pos(:, irep + 1) - yy0 = SQRT(DOT_PRODUCT(xx, xx)) + yy0 = NORM2(xx) dyy = 1.0_dp/yy0*xx xx = pos(:, irep) - pos(:, irep - 1) - xx0 = SQRT(DOT_PRODUCT(xx, xx)) + xx0 = NORM2(xx) dxx = 1.0_dp/xx0*xx davg1 = (dxx + dyy)/REAL(nreplica - 1, KIND=dp) @@ -517,11 +517,11 @@ CONTAINS ! Evaluate the tangent xx = pos(:, irep + 1) - pos(:, irep) - xx = xx/SQRT(DOT_PRODUCT(xx, xx)) + xx = xx/NORM2(xx) yy = pos(:, irep) - pos(:, irep - 1) - yy = yy/SQRT(DOT_PRODUCT(yy, yy)) + yy = yy/NORM2(yy) tang = xx + yy - tang = tang/SQRT(DOT_PRODUCT(tang, tang)) + tang = tang/NORM2(tang) xx = derivative(fes, ipos, iperd, ndim, ngrid, dp_grid) dx(:, irep) = DOT_PRODUCT(dx(:, irep), tang)*tang + & @@ -536,7 +536,7 @@ CONTAINS ene = ene + fes_rep(irep) IF ((irep == 1) .OR. (irep == nreplica)) CYCLE - norm_dx = SQRT(DOT_PRODUCT(dx(:, irep), dx(:, irep))) + norm_dx = NORM2(dx(:, irep)) IF (norm_dx /= 0.0_dp) THEN pos(:, irep) = pos(:, irep) - MIN(0.1_dp, norm_dx)*dx(:, irep)/norm_dx END IF diff --git a/src/metadynamics_types.F b/src/metadynamics_types.F index a299e450b9..985188607a 100644 --- a/src/metadynamics_types.F +++ b/src/metadynamics_types.F @@ -272,8 +272,9 @@ CONTAINS END IF ! Langevin on COLVARS - IF (meta_env%langevin) & + IF (meta_env%langevin) THEN DEALLOCATE (meta_env%rng) + END IF NULLIFY (meta_env%time) NULLIFY (meta_env%metadyn_section) diff --git a/src/metadynamics_utils.F b/src/metadynamics_utils.F index 91b33ff467..72834021df 100644 --- a/src/metadynamics_utils.F +++ b/src/metadynamics_utils.F @@ -157,9 +157,10 @@ CONTAINS "Overriding input specification!") END IF check = meta_env%hills_env%nt_hills >= meta_env%hills_env%min_nt_hills - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "MIN_NT_HILLS must have a value smaller or equal to NT_HILLS! "// & "Cross check with the input reference!") + END IF !RG Adaptive hills CALL section_vals_val_get(metadyn_section, "MIN_DISP", r_val=meta_env%hills_env%min_disp) CALL section_vals_val_get(metadyn_section, "OLD_HILL_NUMBER", i_val=meta_env%hills_env%old_hill_number) @@ -189,15 +190,18 @@ CONTAINS IF (meta_env%well_tempered) THEN meta_env%hills_env%wtcontrol = meta_env%hills_env%wtcontrol .OR. check check = meta_env%hills_env%wtcontrol - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "When using Well-Tempered metadynamics, "// & "DELTA_T (or WTGAMMA) should be explicitly specified.") - IF (meta_env%extended_lagrange) & + END IF + IF (meta_env%extended_lagrange) THEN CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with extended-lagrangian formulation.") - IF (meta_env%hills_env%min_disp > 0.0_dp) & + END IF + IF (meta_env%hills_env%min_disp > 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with Adaptive hills.") + END IF END IF CALL section_vals_val_get(metadyn_section, "COLVAR_AVG_TEMPERATURE_RESTART", & @@ -207,12 +211,13 @@ CONTAINS CALL metavar_read(meta_env%metavar(i), meta_env%extended_lagrange, & meta_env%langevin, i, metavar_section) check = (meta_env%metavar(i)%icolvar <= number_allocated_colvars) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "An error occurred in the specification of COLVAR for METAVAR. "// & "Specified COLVAR #("//TRIM(ADJUSTL(cp_to_string(meta_env%metavar(i)%icolvar)))//") "// & "is larger than the maximum number of COLVARS defined in the SUBSYS ("// & TRIM(ADJUSTL(cp_to_string(number_allocated_colvars)))//") !") + END IF END DO ! Parsing the Multiple Walkers Info @@ -235,12 +240,13 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(walkers_section, "WALKERS_STATUS", i_vals=walkers_status) check = (SIZE(walkers_status) == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "size of the WALKERS_STATUS. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") + END IF meta_env%multiple_walkers%walkers_status = walkers_status ELSE meta_env%multiple_walkers%walkers_status = 0 @@ -251,12 +257,13 @@ CONTAINS CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & n_rep_val=n_rep) check = (n_rep == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "number of Walkers File names provided. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") + END IF DO i = 1, n_rep CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & i_rep_val=i, c_val=walkers_file_name) diff --git a/src/minbas_methods.F b/src/minbas_methods.F index 57411747cf..96f1c421df 100644 --- a/src/minbas_methods.F +++ b/src/minbas_methods.F @@ -138,8 +138,9 @@ CONTAINS nmao = SUM(col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) & + IF (col_blk_sizes(iab) < 0) THEN CPABORT("Number of MAOs has to be specified in KIND section for all elements") + END IF END DO CALL get_mo_set(mo_set=mos(1), nao=nao, nmo=nmo) @@ -167,7 +168,7 @@ CONTAINS WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' END IF do_minbas = .FALSE. - ELSEIF (nmo /= nmx) THEN + ELSE IF (nmo /= nmx) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A)') 'Different Number of Alpha and Beta MOs' WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' diff --git a/src/minbas_wfn_analysis.F b/src/minbas_wfn_analysis.F index bd4c617ca7..3c501d3076 100644 --- a/src/minbas_wfn_analysis.F +++ b/src/minbas_wfn_analysis.F @@ -424,9 +424,9 @@ CONTAINS wij = ABS(SUM(qblock*sblock))/REAL(n, KIND=dp) IF (wij > 0.1_dp) THEN ecount(jatom, 1) = ecount(jatom, 1) + 1 - ELSEIF (wij > 0.01_dp) THEN + ELSE IF (wij > 0.01_dp) THEN ecount(jatom, 2) = ecount(jatom, 2) + 1 - ELSEIF (wij > 0.001_dp) THEN + ELSE IF (wij > 0.001_dp) THEN ecount(jatom, 3) = ecount(jatom, 3) + 1 END IF END IF diff --git a/src/minimax/minimax_exp.F b/src/minimax/minimax_exp.F index af4d922b38..2d9554e462 100644 --- a/src/minimax/minimax_exp.F +++ b/src/minimax/minimax_exp.F @@ -142,7 +142,7 @@ CONTAINS CALL get_minimax_coeff_k15(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k15 END IF - ELSEIF (k <= 53) THEN + ELSE IF (k <= 53) THEN CALL get_minimax_coeff_k53(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k53 ELSE diff --git a/src/minimax/minimax_rpa.F b/src/minimax/minimax_rpa.F index 869a85a9e8..9d89e943ed 100644 --- a/src/minimax/minimax_rpa.F +++ b/src/minimax/minimax_rpa.F @@ -155,7 +155,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 2) :: fit_coef - REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = (/8.4569134345088148E-01_dp, & + REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = [8.4569134345088148E-01_dp, & -2.3864746901255809E-01_dp, -1.1361819501552294E-01_dp, 6.7690505100738471E-02_dp, & 5.3985186361341728E-03_dp, -1.9612317325166117E-02_dp, 7.3513074383591715E-03_dp, & 1.9996243815975012E-03_dp, -3.1205386442664557E-03_dp, 6.2573451848435199E-04_dp, & @@ -172,8 +172,8 @@ CONTAINS -3.6844989012010113E-06_dp, -7.8361514387479545E+00_dp, -3.6112788486477720E+00_dp, & 9.5851351388967405E+00_dp, 7.2698001012821694E+00_dp, -1.1403856909523945E+01_dp, & -1.7651082087203267E+01_dp, 3.2669706643838275E+01_dp, -5.4176678145626020E+00_dp, & - -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp/) - REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 2, 2/)) + -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp] + REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE([c01], [13, 2, 2]) INTEGER :: irange @@ -205,7 +205,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 4) :: fit_coef - REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = (/4.9649110596357299E-01_dp, & + REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = [4.9649110596357299E-01_dp, & -1.8397680763708085E-01_dp, -2.6764777836094898E-02_dp, 1.4685597048762128E-02_dp, & 3.8551475599549168E-03_dp, -6.6371384965829621E-04_dp, -8.2857349546675376E-04_dp, & 3.7111617653054724E-05_dp, 1.2814660801267966E-04_dp, 6.1538340479780230E-06_dp, & @@ -257,8 +257,8 @@ CONTAINS -4.9301857791232557E+01_dp, 3.1465928358831281E+00_dp, 7.7404606802819202E+01_dp, & -3.3013072565887242E+01_dp, -1.2019494685884978E+02_dp, 1.5486223363142261E+02_dp, & 3.2337501402758228E+01_dp, -1.8488455295931200E+02_dp, 5.0234562973130487E+01_dp, & - 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp/) - REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 4, 3/)) + 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp] + REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 4, 3]) INTEGER :: irange @@ -295,7 +295,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 6) :: fit_coef - REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = (/4.7223379816403283E-01_dp, & + REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = [4.7223379816403283E-01_dp, & -2.2042504935487547E-01_dp, -1.0700855642800766E-01_dp, 2.9282041797865813E-02_dp, & 3.3026836310057026E-02_dp, 1.1386996102844459E-02_dp, -1.2818345627763791E-02_dp, & -4.0229827105483680E-03_dp, 5.2714678853526230E-03_dp, -5.7896018199156346E-03_dp, & @@ -373,8 +373,8 @@ CONTAINS -1.7804086701584447E+02_dp, 5.3879411878296139E+01_dp, 2.5019726837316304E+02_dp, & -2.4632876610675547E+02_dp, -2.3728096521661567E+02_dp, 7.2832435058031899E+02_dp, & -6.3406381009820018E+02_dp, 7.2166814993792187E+01_dp, 2.2865645970566064E+02_dp, & - -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp/) - REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 6, 3/)) + -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp] + REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 6, 3]) INTEGER :: irange @@ -411,7 +411,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 8) :: fit_coef - REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = (/4.0437679455062153E-01_dp, & + REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = [4.0437679455062153E-01_dp, & -1.9968645981826424E-01_dp, -9.6669556285432015E-02_dp, 2.6839132012201752E-02_dp, & 3.6190132805626725E-02_dp, 4.1166010414531336E-03_dp, -1.0769456290470580E-02_dp, & -8.7529874160434775E-05_dp, 5.7309585756926467E-03_dp, -1.0860752534826048E-02_dp, & @@ -515,8 +515,8 @@ CONTAINS -6.8223088256704716E+02_dp, 3.4708903230411840E+02_dp, 1.0990846081358511E+03_dp, & -1.7164437218305100E+03_dp, -5.1026413431245879E+02_dp, 4.8843366036040652E+03_dp, & -7.6063698448775094E+03_dp, 5.5268501397810141E+03_dp, -6.4043799549226162E+02_dp, & - -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp/) - REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 8, 3/)) + -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp] + REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 8, 3]) INTEGER :: irange @@ -553,7 +553,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 10) :: fit_coef - REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = (/-4.8858613834160547E-01_dp, & + REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = [-4.8858613834160547E-01_dp, & 3.4033685149450971E-01_dp, -1.0142642654121627E-01_dp, 1.8656576613307461E+00_dp, & -2.2611249862234847E-07_dp, -4.2139600757794465E-01_dp, 2.7923611356976985E-01_dp, & 4.7524652113269663E-03_dp, -5.0664309914469052E-01_dp, 9.4151166751519222E-01_dp, & @@ -593,8 +593,8 @@ CONTAINS -2.0215919999407249E+03_dp, 1.3397278899112848E+03_dp, 3.2785602402023524E+03_dp, & -6.7015638377241066E+03_dp, 8.2607523725594240E+02_dp, 1.7011468237133256E+04_dp, & -3.7898634628790373E+04_dp, 4.6113041763967398E+04_dp, -3.4882603781213867E+04_dp, & - 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6550926316288959E-01_dp, & + 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6550926316288959E-01_dp, & -1.4194808279243129E-01_dp, -1.8340243943233556E-02_dp, 1.5594859644926301E-02_dp, & 6.5213609288545414E-03_dp, -7.2580394496045918E-04_dp, -1.4367869259991610E-03_dp, & -5.1441935266499043E-04_dp, 1.1018516863846910E-04_dp, 1.3857094404802231E-04_dp, & @@ -727,9 +727,8 @@ CONTAINS -9.5025460048391619E+02_dp, 1.8084927413816368E+02_dp, 4.5372254459206868E-01_dp, & -3.2706671239427972E-08_dp, -6.0956447616697843E-02_dp, 4.0392497654627497E-02_dp, & -5.9611390145588245E-03_dp, -6.4482812112108656E-02_dp, 1.3285507045769324E-01_dp, & - -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp/) - REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02/), (/13, 10, 4/)) + -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp] + REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 10, 4]) INTEGER :: irange @@ -771,7 +770,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 12) :: fit_coef - REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = (/-2.1886099081761100E-02_dp, & + REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = [-2.1886099081761100E-02_dp, & 1.6493591518278907E-03_dp, 1.1789604920345118E-03_dp, 6.4862232853117350E+00_dp, & -1.7754848782963699E+00_dp, -1.3982954414549702E+00_dp, 8.0870739791892121E-01_dp, & -3.2912209721480506E-01_dp, 6.6541689936850468E-01_dp, -7.1706760669376735E-01_dp, & @@ -846,8 +845,8 @@ CONTAINS 4.8176388108956071E+03_dp, 1.0175276953355078E+04_dp, -2.6714845272387549E+04_dp, & 1.3141868511851815E+04_dp, 5.7600064337445598E+04_dp, -1.7044732018512717E+05_dp, & 2.5361567867653081E+05_dp, -2.3362423558935185E+05_dp, 1.2691185251979054E+05_dp, & - -3.1278542676771558E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.3880318322659616E-01_dp, & + -3.1278542676771558E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.3880318322659616E-01_dp, & -1.3504254699048457E-01_dp, -1.8598173825632135E-02_dp, 1.5951626606880761E-02_dp, & 7.2684956676590529E-03_dp, -5.7141087071240480E-04_dp, -1.5395949213734461E-03_dp, & -7.1572363929054415E-04_dp, 3.6877254806601694E-05_dp, 5.4320682223059976E-06_dp, & @@ -980,9 +979,8 @@ CONTAINS -1.0634490523999061E+02_dp, 2.1350371455168180E+01_dp, 3.4511581153937105E+00_dp, & -4.6074986504725718E-01_dp, -4.1793306232973060E-01_dp, 1.1447565909224683E-01_dp, & -9.1392964448968397E-02_dp, 1.8219557370192899E-01_dp, -1.6634354182093192E-01_dp, & - 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp/) - REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02/), (/13, 12, 4/)) + 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp] + REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 12, 4]) INTEGER :: irange @@ -1024,7 +1022,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 14) :: fit_coef - REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = (/-4.1754731782680632E-02_dp, & + REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = [-4.1754731782680632E-02_dp, & 6.9637423606893978E-03_dp, 9.8317123038661812E-04_dp, 9.3141247748056060E+00_dp, & -3.3034187378384154E+00_dp, -2.3099777024265484E+00_dp, 1.9795050912537626E+00_dp, & -8.5251482053787397E-01_dp, 1.2153039011546896E+00_dp, -1.4541564892554977E+00_dp, & @@ -1133,8 +1131,8 @@ CONTAINS -6.0796509451681840E-03_dp, -1.2729055327721569E+04_dp, 1.1355442435730931E+04_dp, & 1.9420434975201191E+04_dp, -5.7157101053784776E+04_dp, 4.1961441009360387E+04_dp, & 8.2301170473632315E+04_dp, -2.9848869860082364E+05_dp, 4.7636758440468600E+05_dp, & - -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6444089699692058E-01_dp, & + -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6444089699692058E-01_dp, & -1.5470504999202458E-01_dp, -4.6856578935403119E-02_dp, 2.5042624726789489E-02_dp, & 1.9131665599864848E-02_dp, -2.9696778036559586E-03_dp, -3.7556543742271655E-03_dp, & 1.6266657874186815E-04_dp, 4.6360340975112090E-03_dp, -7.8332396642386976E-03_dp, & @@ -1267,9 +1265,8 @@ CONTAINS 1.3457500127744759E-03_dp, 3.1573603989801897E-04_dp, 3.6037055399201039E+00_dp, & -8.0542869559173069E-01_dp, -6.3866068626924610E-01_dp, 3.6581611775536099E-01_dp, & -1.8032325305523136E-01_dp, 3.1726528871551424E-01_dp, -3.4024223010999666E-01_dp, & - 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp/) - REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02/), (/13, 14, 4/)) + 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp] + REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 14, 4]) INTEGER :: irange @@ -1311,7 +1308,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 16) :: fit_coef - REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = (/-8.9013840273255062E+02_dp, & + REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = [-8.9013840273255062E+02_dp, & 4.4450456221108550E+02_dp, 5.3174323393059228E+02_dp, -1.2592882857295644E+03_dp, & 1.0557554278716216E+03_dp, -3.5046238641220043E+02_dp, 1.2930757301899466E+03_dp, & 1.1516939780618657E-03_dp, -1.6608759395740256E+03_dp, 1.4462154462223984E+03_dp, & @@ -1322,8 +1319,8 @@ CONTAINS 1.9619149559132464E+04_dp, 2.5759373028729122E+04_dp, -7.7020575840804217E+04_dp, & 6.3201727988014049E+04_dp, 6.8163632238120859E+04_dp, -2.9053341169350612E+05_dp, & 4.7359098571404989E+05_dp, -4.6694609866564447E+05_dp, 2.7229709401159501E+05_dp, & - -7.2557173401722219E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7310961221813451E-01_dp, & + -7.2557173401722219E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7310961221813451E-01_dp, & -9.5711109831144323E-02_dp, -2.5960297888544426E-02_dp, 7.7258590328211849E-03_dp, & 5.1368496261163018E-03_dp, -1.1234374052788891E-03_dp, -1.0608869644587510E-03_dp, & 4.0213920388401469E-04_dp, 3.0775150301006290E-04_dp, -5.8915574825377335E-05_dp, & @@ -1456,8 +1453,8 @@ CONTAINS -1.6811781491598083E+01_dp, 4.2614301447710945E+00_dp, 4.2182283329260298E+02_dp, & -9.0232374730691106E+02_dp, 7.1913307941971050E+02_dp, 6.5788926678577425E+01_dp, & -5.6847305624230580E+02_dp, 3.2522974861279704E+02_dp, 1.3143394779042333E+02_dp, & - -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.8863592203480596E+02_dp, & + -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.8863592203480596E+02_dp, & 1.0528430973221714E+02_dp, -1.5857007223981109E+01_dp, 1.8276946029107571E+03_dp, & -4.8112032981737193E+03_dp, 6.1258592600600687E+03_dp, -4.0381542724034271E+03_dp, & 3.2440486268768652E+01_dp, 2.9756759864086989E+03_dp, -3.5826087401832801E+03_dp, & @@ -1590,9 +1587,9 @@ CONTAINS 1.4478597281785360E+02_dp, 1.1301880394535623E+01_dp, -1.5313609799645960E+02_dp, & 1.5075591149117258E+02_dp, -5.3325987923237058E+01_dp, 2.9560124699329253E+02_dp, & 1.7113342586626282E-04_dp, -2.4662390250801528E+02_dp, 2.1474962274139023E+02_dp, & - -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp/) + -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp] REAL(KIND=dp), DIMENSION(13, 16, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03/), (/13, 16, 4/)) + coefdata = RESHAPE([c01, c02, c03], [13, 16, 4]) INTEGER :: irange @@ -1634,7 +1631,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 18) :: fit_coef - REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = (/-8.4609670938814907E+02_dp, & + REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = [-8.4609670938814907E+02_dp, & 5.2521889455815938E+02_dp, -1.8158803681882837E+01_dp, -1.9195843056246903E+02_dp, & 4.7038182235191250E+01_dp, 4.4962618821808661E+01_dp, 2.3952550076762327E+03_dp, & 7.3919658606953450E-04_dp, -3.3678854403725500E+03_dp, 2.7630103823335253E+03_dp, & @@ -1679,8 +1676,8 @@ CONTAINS 7.9756724721310873E-03_dp, -3.6633955682749525E+04_dp, 3.0054168139170702E+04_dp, & 3.0244619250697619E+04_dp, -8.9553753522321902E+04_dp, 7.9875735584514681E+04_dp, & 1.7524458945017868E+04_dp, -1.3188240705569120E+05_dp, 1.3592402872600380E+05_dp, & - -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7491556688515650E-01_dp, & + -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7491556688515650E-01_dp, & -1.0138397977284885E-01_dp, -3.9049726894672010E-02_dp, 1.2625689412991524E-02_dp, & 1.2491380414983764E-02_dp, -3.7765616302317911E-03_dp, -5.1175283467075521E-03_dp, & 1.4632298825565039E-03_dp, 3.6642955364173022E-03_dp, -2.0156097072982762E-03_dp, & @@ -1813,8 +1810,8 @@ CONTAINS 2.9781052441439151E-02_dp, -1.4527696704126849E-02_dp, 1.7339641636383043E+01_dp, & -1.1465395481325789E+01_dp, -2.7302697069655961E+00_dp, 4.4629359221611402E+00_dp, & 7.1614646223286882E-01_dp, -1.4605259953560206E+00_dp, -1.0335490616197762E+00_dp, & - 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/8.6574572823904627E-01_dp, & + 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [8.6574572823904627E-01_dp, & -1.6889080712338411E-01_dp, -3.8729713566779244E-03_dp, 4.1076303571384891E+01_dp, & -3.6684994925539350E+01_dp, -3.4268355391161074E+00_dp, 1.6994010089726881E+01_dp, & -1.2988970233372894E+00_dp, -6.3669393876591824E+00_dp, -1.4789915209996456E+00_dp, & @@ -1947,9 +1944,9 @@ CONTAINS 1.3132457381744328E+02_dp, -3.8713782602971918E+01_dp, -3.5040157951924371E+01_dp, & 3.7792017841024283E+01_dp, -1.0016991740016113E+01_dp, 4.5777593919577163E+02_dp, & 8.1637641969554641E-05_dp, -3.6580205008674420E+02_dp, 3.0011032726156765E+02_dp, & - -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp/) + -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp] REAL(KIND=dp), DIMENSION(13, 18, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03/), (/13, 18, 4/)) + coefdata = RESHAPE([c01, c02, c03], [13, 18, 4]) INTEGER :: irange @@ -1991,7 +1988,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 20) :: fit_coef - REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = (/-6.3360994610628929E-01_dp, & + REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = [-6.3360994610628929E-01_dp, & 9.7649518951989356E-01_dp, -1.0559988395317237E+00_dp, 7.8078414899977844E-01_dp, & -3.5500159005989329E-01_dp, 7.4673135592582374E-02_dp, 2.6285615412587124E+00_dp, & 1.5860173767897436E-07_dp, -3.6913389708324101E-01_dp, 3.7465972064134995E-01_dp, & @@ -2071,8 +2068,8 @@ CONTAINS -1.0102666755386532E+05_dp, 1.0253508247597031E+05_dp, 1.0602636418265585E+05_dp, & -4.0728952867028292E+05_dp, 4.6976444940836332E+05_dp, 5.8500781101532266E+04_dp, & -1.2055500949944141E+06_dp, 2.3598896259778733E+06_dp, -2.5585975849316372E+06_dp, & - 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.5561005851553148E-01_dp, & + 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.5561005851553148E-01_dp, & -9.8727639373792656E-02_dp, -3.5824853081321391E-02_dp, 1.3639809429163310E-02_dp, & 1.2140312218587666E-02_dp, -4.6051578600266093E-03_dp, -5.2440292404026837E-03_dp, & 1.6141788048728977E-03_dp, 4.9068438183985687E-03_dp, -3.8643109440260576E-03_dp, & @@ -2205,8 +2202,8 @@ CONTAINS 1.4996446737543528E+02_dp, -3.0374236420884017E+01_dp, 2.5318787052609042E+00_dp, & -4.5232522380132079E-01_dp, -2.4894203765998704E-01_dp, 3.7844517569960621E-02_dp, & 6.7481113092261444E-02_dp, -1.8350883302710324E-03_dp, -3.7893183999051401E-02_dp, & - 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.4867222607997398E-03_dp, & + 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.4867222607997398E-03_dp, & 7.4160230219779905E-03_dp, -1.8338341118192985E-03_dp, 3.6656246502838239E+00_dp, & -1.0862821007061922E+00_dp, -4.7299838594788851E-01_dp, 2.1791529395255307E-01_dp, & 1.6235258776392880E-01_dp, -5.9164629917823931E-02_dp, -1.0182204867540855E-01_dp, & @@ -2339,9 +2336,9 @@ CONTAINS 2.0849621635227758E-01_dp, -2.2855126470711301E-01_dp, 1.7151231132777350E-01_dp, & -7.9338970506037887E-02_dp, 1.7034794798258115E-02_dp, 1.1561315825459209E+00_dp, & 4.6876842564306299E-08_dp, -1.0903099661435091E-01_dp, 1.1066333209885304E-01_dp, & - -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp/) + -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp] REAL(KIND=dp), DIMENSION(13, 20, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03/), (/13, 20, 4/)) + coefdata = RESHAPE([c01, c02, c03], [13, 20, 4]) INTEGER :: irange @@ -2383,7 +2380,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 22) :: fit_coef - REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = (/-2.5319035989384675E+00_dp, & + REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = [-2.5319035989384675E+00_dp, & -3.1868909327109335E-01_dp, 7.3902114944100665E+00_dp, -1.8431274144078589E+01_dp, & 2.9378426424405447E+01_dp, -3.3161724592145767E+01_dp, 2.5816413812770147E+01_dp, & -1.2469330304705172E+01_dp, 2.8128079338690761E+00_dp, 2.4584353206019742E+01_dp, & @@ -2460,8 +2457,8 @@ CONTAINS 2.1221227425035721E+05_dp, 1.9513181165124831E+05_dp, -8.3228931356148690E+05_dp, & 1.0686042433396007E+06_dp, -1.6890882361242565E+05_dp, -2.0275393275062682E+06_dp, & 4.3886071943292571E+06_dp, -4.9464312502375301E+06_dp, 3.1275647455199584E+06_dp, & - -8.7618952854779735E+05_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.9140383852290629E-01_dp, & + -8.7618952854779735E+05_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.9140383852290629E-01_dp, & -6.8714312208041611E-02_dp, -9.1979524758077930E-03_dp, 4.0542016308222793E-03_dp, & 1.3043896673939879E-03_dp, -3.3077626826676678E-04_dp, -1.1713733973944338E-04_dp, & 7.6096932007647678E-05_dp, 1.6862094749663900E-05_dp, -1.8859482112709049E-05_dp, & @@ -2594,8 +2591,8 @@ CONTAINS -3.8649136037865522E-01_dp, 2.2567746326676860E-01_dp, 7.4213954026122252E+01_dp, & -1.4804950267684572E+02_dp, 1.2495507784125873E+02_dp, -2.4776264817547396E+01_dp, & -4.2930419560902017E+01_dp, 2.9472395507465627E+01_dp, 1.0097402469676231E+01_dp, & - -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.4561539999459816E+01_dp, & + -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.4561539999459816E+01_dp, & 4.8544787554718685E+00_dp, -6.3387746031848102E-01_dp, 1.5731981998839461E+02_dp, & -3.7106120150889751E+02_dp, 4.0538316285381757E+02_dp, -1.9862435563464234E+02_dp, & -4.2159595434504858E+01_dp, 1.1123116084380190E+02_dp, -3.2616679588589356E+01_dp, & @@ -2728,8 +2725,8 @@ CONTAINS 2.4122252521897924E+00_dp, -9.7999682646599489E+00_dp, 7.9639626818274714E+00_dp, & -2.9529703827741800E+00_dp, 4.3437020501980872E-01_dp, 1.3418598639315178E+02_dp, & -1.4639064170062176E+02_dp, 7.9688822975923612E+00_dp, 6.9963146941480773E+01_dp, & - -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2105999150585166E+01_dp, & + -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2105999150585166E+01_dp, & -2.2551854693657698E+00_dp, -3.0252257829864192E+01_dp, 3.2690274416605568E+01_dp, & -1.5006475584487145E+01_dp, 2.7494470603903425E+00_dp, 3.4045498207568971E+02_dp, & -4.7133760448357106E+02_dp, 1.1327780050673924E+02_dp, 2.2523014020490135E+02_dp, & @@ -2862,9 +2859,9 @@ CONTAINS -1.1263108188627524E-02_dp, 2.3148160729056904E+00_dp, -5.9940875579716151E+00_dp, & 9.7525037514957766E+00_dp, -1.1202621964616382E+01_dp, 8.8723971586232349E+00_dp, & -4.3615551235670349E+00_dp, 1.0019327026030862E+00_dp, 1.0890417035686898E+01_dp, & - -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp/) + -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp] REAL(KIND=dp), DIMENSION(13, 22, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 22, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04], [13, 22, 5]) INTEGER :: irange @@ -2911,7 +2908,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 24) :: fit_coef - REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = (/-3.4185637511153556E+02_dp, & + REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = [-3.4185637511153556E+02_dp, & 3.0668182445881496E+02_dp, -4.1209664021967029E+02_dp, 3.7330789502174974E+02_dp, & -2.3245333897278655E+02_dp, 1.3019687281058577E+02_dp, -7.4166370900253412E+01_dp, & 3.1434861912054572E+01_dp, -6.1992398402862987E+00_dp, 3.3062345634073872E+03_dp, & @@ -3031,8 +3028,8 @@ CONTAINS -3.7306629896332178E+05_dp, 4.1394566251683736E+05_dp, 3.3744969046701316E+05_dp, & -1.5791948214027057E+06_dp, 2.1917044569001873E+06_dp, -7.9115467427151953E+05_dp, & -3.0601023356753197E+06_dp, 7.4427363873937679E+06_dp, -8.7248223821029570E+06_dp, & - 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8031277973538481E-01_dp, & + 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8031277973538481E-01_dp, & -6.7333985536224536E-02_dp, -8.9222590966419636E-03_dp, 4.3313443199331000E-03_dp, & 1.3612994231258369E-03_dp, -4.2134528860866431E-04_dp, -1.3958926498276367E-04_dp, & 1.0459985085575114E-04_dp, 2.4321788489287324E-05_dp, -2.5628407616984446E-05_dp, & @@ -3165,8 +3162,8 @@ CONTAINS -3.8414425007098330E-01_dp, 7.5502828561301874E-02_dp, 1.5429572442140103E+01_dp, & -1.9205543991334537E+01_dp, 7.1837956925844102E+00_dp, 4.1527008022568523E+00_dp, & -3.9604373888031548E+00_dp, -1.2184620720634423E+00_dp, 2.1268242758491254E+00_dp, & - 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/1.1553671463453488E+00_dp, & + 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [1.1553671463453488E+00_dp, & -7.6780781804979914E-01_dp, 1.7390307652239254E-01_dp, 2.8165264234356147E+01_dp, & -4.2781018965163859E+01_dp, 2.3179056548048951E+01_dp, 5.2439089413556950E+00_dp, & -1.1643001503346785E+01_dp, 4.5770373921564939E-01_dp, 5.5851597940226441E+00_dp, & @@ -3299,8 +3296,8 @@ CONTAINS 1.9287416985295423E-02_dp, -9.7735471490287135E-03_dp, -5.4153420961059818E-03_dp, & 6.2996178645704911E-03_dp, -1.6741808988248179E-03_dp, 3.2323307090443092E+00_dp, & -7.5868899537917556E-01_dp, -3.6403112314198777E-01_dp, 1.3638032105863709E-01_dp, & - 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.5411208403973456E-02_dp, & + 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.5411208403973456E-02_dp, & 5.7808629859203861E-02_dp, -5.0196351778645114E-02_dp, 5.2149034144752344E-03_dp, & 9.5271530622531974E-03_dp, -3.3982153227889275E-03_dp, 5.4948218832066447E+00_dp, & -1.9768544283573861E+00_dp, -7.8540931963005123E-01_dp, 5.1224166160961682E-01_dp, & @@ -3433,9 +3430,9 @@ CONTAINS 8.6197068058446064E+01_dp, -1.1457176948523994E+02_dp, 1.0089516510941472E+02_dp, & -7.0493679332727382E+01_dp, 4.8625058388200841E+01_dp, -2.9732088584351676E+01_dp, & 1.1947228503152537E+01_dp, -2.1840920197937304E+00_dp, 1.0166774272757106E+03_dp, & - -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp/) + -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp] REAL(KIND=dp), DIMENSION(13, 24, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 24, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04], [13, 24, 5]) INTEGER :: irange @@ -3482,7 +3479,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 26) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8838771004380783E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8838771004380783E-01_dp, & -7.8098504554216852E-02_dp, -1.5170263296839995E-02_dp, 8.2399169935392508E-03_dp, & 3.5286892847422469E-03_dp, -1.8215194066877041E-03_dp, -9.0884305814463765E-04_dp, & 6.8756727909990219E-04_dp, 3.7413977081317160E-04_dp, -2.6705465221031334E-04_dp, & @@ -3615,8 +3612,8 @@ CONTAINS -3.7209893008122726E-02_dp, 4.6211560443511707E-03_dp, 4.9425542029764467E+00_dp, & -3.3299793049425701E+00_dp, -1.5240471603939173E-02_dp, 9.6617116551502813E-01_dp, & -5.4487412666999822E-02_dp, -4.4981543663568441E-01_dp, 5.4235895382646740E-02_dp, & - 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/3.5632823078643500E-01_dp, & + 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [3.5632823078643500E-01_dp, & -1.4001776162509430E-01_dp, 2.2286666712875530E-02_dp, 8.7125285885676789E+00_dp, & -7.4679426200738366E+00_dp, 8.3805209926335500E-01_dp, 2.2477163058559704E+00_dp, & -6.0060735276290700E-01_dp, -1.0331040612400506E+00_dp, 3.9698448728282515E-01_dp, & @@ -3749,8 +3746,8 @@ CONTAINS -1.5690448976060742E+00_dp, -1.4469520844727743E+01_dp, 1.5229016181347497E+01_dp, & -6.7413191274813640E+00_dp, 1.1871712862612187E+00_dp, 2.8292219949744720E+02_dp, & -3.3466585644002333E+02_dp, 6.5399374381441106E+01_dp, 1.3547954808764075E+02_dp, & - -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.1951406154569082E+01_dp, & + -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.1951406154569082E+01_dp, & -2.7863833003973856E+01_dp, -2.4615790099798474E+01_dp, 4.4154903132889864E+01_dp, & -2.4321043128719936E+01_dp, 5.0336537486842516E+00_dp, 7.0657858026784504E+02_dp, & -1.0528573743078830E+03_dp, 4.1625512279061735E+02_dp, 3.6427444425345516E+02_dp, & @@ -3883,8 +3880,8 @@ CONTAINS 5.9384272779209310E-02_dp, -6.6034549944533560E-02_dp, 6.3165197301667780E-02_dp, & -5.8533667022985264E-02_dp, 4.7080124186021241E-02_dp, -2.8040678094242519E-02_dp, & 1.0590404330460124E-02_dp, -1.8887168866975497E-03_dp, 3.2950022547352660E+00_dp, & - -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-7.8836509708512373E-02_dp, & + -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-7.8836509708512373E-02_dp, & 1.3178061660818258E-01_dp, -1.4891101086305505E-01_dp, 1.4038052557472530E-01_dp, & -1.2827505792189706E-01_dp, 1.0306674552536969E-01_dp, -6.1520533848826123E-02_dp, & 2.3216931723502306E-02_dp, -4.1222161991565217E-03_dp, 5.6592328962619902E+00_dp, & @@ -4017,8 +4014,8 @@ CONTAINS -1.7064535222921169E+01_dp, 1.9476350353952395E+01_dp, -1.8590436540559089E+01_dp, & 3.1925275522724674E+00_dp, 4.1158324783342913E+01_dp, -1.1921515605115852E+02_dp, & 2.0979218330367425E+02_dp, -2.5985281813994447E+02_dp, 2.2199832068654112E+02_dp, & - -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp/) - REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = (/-2.7907357414271074E-05_dp, & + -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp] + REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = [-2.7907357414271074E-05_dp, & -4.8826106427338516E+01_dp, 5.5726828156877396E+01_dp, -5.0511477178292488E+01_dp, & 2.9783692652581260E+00_dp, 1.2761594545085276E+02_dp, -3.5194583503612256E+02_dp, & 6.0567238480576850E+02_dp, -7.3810346857458831E+02_dp, 6.2201716742048916E+02_dp, & @@ -4048,9 +4045,9 @@ CONTAINS -6.7753046300068102E+05_dp, 7.7323771401862660E+05_dp, 5.5823523395335092E+05_dp, & -2.8474678682125942E+06_dp, 4.1915016169727501E+06_dp, -2.1435582467267131E+06_dp, & -4.2583193954617819E+06_dp, 1.1939190162504816E+07_dp, -1.4588866431316955E+07_dp, & - 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp/) + 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp] REAL(KIND=dp), DIMENSION(13, 26, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 26, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 26, 5]) INTEGER :: irange @@ -4097,7 +4094,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 28) :: fit_coef - REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = (/-4.9474578762585689E-04_dp, & + REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = [-4.9474578762585689E-04_dp, & -2.5939403957639643E+03_dp, 3.0352874416549189E+03_dp, -1.9742442806612846E+03_dp, & -1.5969761709828460E+03_dp, 9.5497831811419619E+03_dp, -2.1791219784053799E+04_dp, & 3.4007167063977518E+04_dp, -3.8426789298450683E+04_dp, 3.0290020612758195E+04_dp, & @@ -4170,8 +4167,8 @@ CONTAINS -2.4363178639415667E-01_dp, -1.2048752475226286E+06_dp, 1.4098050382019044E+06_dp, & 9.0383108002498816E+05_dp, -5.0245780711403918E+06_dp, 7.7751430360333202E+06_dp, & -4.9183263330898508E+06_dp, -5.5122178990547452E+06_dp, 1.8712359903900910E+07_dp, & - -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8855631887642382E-01_dp, & + -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8855631887642382E-01_dp, & -8.1829231046632769E-02_dp, -1.8950903102790816E-02_dp, 1.1349898287774197E-02_dp, & 5.7338935886024562E-03_dp, -3.6475885523936957E-03_dp, -2.1458998142384776E-03_dp, & 1.4787405505064602E-03_dp, 1.8498537181843471E-03_dp, -1.9614757255708645E-03_dp, & @@ -4304,8 +4301,8 @@ CONTAINS 1.1382083100254657E-03_dp, -3.9779179490065093E-04_dp, 1.4924251913695632E+00_dp, & -5.1831019334185813E-01_dp, -1.0671352469554986E-01_dp, 9.3839903685068102E-02_dp, & 3.2490232771881414E-02_dp, -3.4916436688308940E-02_dp, -1.3379509563995902E-02_dp, & - 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/7.7725039723149673E-03_dp, & + 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [7.7725039723149673E-03_dp, & 1.1145706792479703E-04_dp, -5.6097890673260616E-04_dp, 2.6197138414537928E+00_dp, & -1.1878855591113402E+00_dp, -1.3669541461047707E-01_dp, 2.5880924857422194E-01_dp, & 3.9410663226141771E-02_dp, -1.0161291074659663E-01_dp, -1.4845376770825033E-02_dp, & @@ -4438,8 +4435,8 @@ CONTAINS 1.8202124035828973E-01_dp, -2.3777194345333863E-01_dp, 9.8820369139971026E-02_dp, & -6.2744671316908003E-03_dp, -4.3699523495120468E-03_dp, 1.1856221271082283E+01_dp, & -5.2568207235502564E+00_dp, -1.5969164750173954E+00_dp, 1.6461069205315015E+00_dp, & - 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.7852818456494469E-01_dp, & + 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.7852818456494469E-01_dp, & 4.8067555347683755E-01_dp, -7.7452581263261322E-01_dp, 4.1934407249887440E-01_dp, & -8.9234614648328783E-02_dp, 1.6775465007990663E-03_dp, 2.2972132228999541E+01_dp, & -1.2898901071815617E+01_dp, -2.9797860863789967E+00_dp, 4.6560435611069622E+00_dp, & @@ -4572,8 +4569,8 @@ CONTAINS 8.7770738779350062E+00_dp, -1.1095172356986756E+01_dp, 1.0314862293028543E+01_dp, & -8.8233143705921826E+00_dp, 7.0699089843034164E+00_dp, -4.4024286308950149E+00_dp, & 1.7350313146222107E+00_dp, -3.1699935067362639E-01_dp, 1.3246229877703036E+02_dp, & - -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-1.7228109793468004E+01_dp, & + -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-1.7228109793468004E+01_dp, & 2.4108285826088757E+01_dp, -3.1362122687167119E+01_dp, 2.9105748579791722E+01_dp, & -2.4011018345543842E+01_dp, 1.8874442598138845E+01_dp, -1.1844908362658735E+01_dp, & 4.7389221341553531E+00_dp, -8.7620232886140437E-01_dp, 3.1319177678658934E+02_dp, & @@ -4706,9 +4703,9 @@ CONTAINS -6.6016663782193780E+02_dp, 7.7249587755502171E+02_dp, -6.0564642881603584E+02_dp, & -1.6334533603788654E+02_dp, 2.0809169575290675E+03_dp, -5.2520819705711947E+03_dp, & 8.7142803953445527E+03_dp, -1.0381449011333283E+04_dp, 8.6066748064158692E+03_dp, & - -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp/) + -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp] REAL(KIND=dp), DIMENSION(13, 28, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 28, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 28, 5]) INTEGER :: irange @@ -4755,7 +4752,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 30) :: fit_coef - REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = (/-3.0692468631051978E-08_dp, & + REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = [-3.0692468631051978E-08_dp, & -3.9609383383921665E-01_dp, 4.7587580740675417E-01_dp, -5.5706375318965173E-01_dp, & 3.4546263714113901E-01_dp, 5.4776062905207357E-01_dp, -2.4141552540426781E+00_dp, & 4.9577847041515470E+00_dp, -6.8295343742172383E+00_dp, 6.3573367557181761E+00_dp, & @@ -4872,8 +4869,8 @@ CONTAINS 2.5461696440140237E+06_dp, 1.4577959403430095E+06_dp, -8.8776723555507679E+06_dp, & 1.4429270679797074E+07_dp, -1.0764718275979346E+07_dp, -6.0081024069717359E+06_dp, & 2.8423455083762139E+07_dp, -3.8351286309245549E+07_dp, 2.6572649225598279E+07_dp, & - -7.9000536567775914E+06_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8728308171438685E-01_dp, & + -7.9000536567775914E+06_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8728308171438685E-01_dp, & -7.4958225804522882E-02_dp, -1.7654418697317781E-02_dp, 1.0337296188123402E-02_dp, & 5.3074367941912289E-03_dp, -3.4737735619981940E-03_dp, -2.0980081422520588E-03_dp, & 1.3332352270175691E-03_dp, 1.8928638178553657E-03_dp, -2.0371064972525598E-03_dp, & @@ -5006,8 +5003,8 @@ CONTAINS 3.0587066325522777E+01_dp, -9.7246696807779784E+00_dp, 2.3046596783109666E-01_dp, & -5.0266863054748409E-02_dp, -1.7179737588739360E-02_dp, 5.4654515693096711E-03_dp, & 4.7852361622912525E-03_dp, -1.7421101769864551E-03_dp, -1.9440310548800761E-03_dp, & - 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.3785652584517211E-04_dp, & + 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.3785652584517211E-04_dp, & 4.0415260781371566E-04_dp, -1.1566827381466792E-04_dp, 7.4614843698202982E-01_dp, & -1.8831297390879426E-01_dp, -5.5307781300718430E-02_dp, 2.5755321163507486E-02_dp, & 1.6130804272204945E-02_dp, -8.8949071784985307E-03_dp, -6.6594057854666763E-03_dp, & @@ -5140,8 +5137,8 @@ CONTAINS 1.6273475095842586E-03_dp, -8.9025885910407965E-04_dp, -3.6671922956720823E-04_dp, & 4.8507440460371750E-04_dp, -1.3211072877791544E-04_dp, 8.5654480285554591E-01_dp, & -1.1200920153309295E-01_dp, -6.0375651330303620E-02_dp, 1.2480943363126322E-02_dp, & - 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2061351968797813E-03_dp, & + 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2061351968797813E-03_dp, & 7.2651800654771788E-03_dp, -4.9666091131882828E-03_dp, -6.0509045722459322E-04_dp, & 1.7074706793122701E-03_dp, -5.0886032182887841E-04_dp, 1.7258143200373688E+00_dp, & -2.9884323352649256E-01_dp, -1.4775030321223576E-01_dp, 4.7248271588260116E-02_dp, & @@ -5274,8 +5271,8 @@ CONTAINS 2.2562073529423785E-02_dp, -2.5951410486921640E-02_dp, 2.5567379426983138E-02_dp, & -2.4333781051323347E-02_dp, 2.0151995146635144E-02_dp, -1.2400482709093779E-02_dp, & 4.8452373650168124E-03_dp, -8.9294844328912499E-04_dp, 1.8352119311378547E+00_dp, & - -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-3.6931298185134437E-02_dp, & + -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-3.6931298185134437E-02_dp, & 6.2239013775737956E-02_dp, -7.2288174936489244E-02_dp, 7.0693666064322772E-02_dp, & -6.6776211112181863E-02_dp, 5.5274684972707100E-02_dp, -3.4069532004586962E-02_dp, & 1.3318163740503416E-02_dp, -2.4516852040202333E-03_dp, 3.4526910112953169E+00_dp, & @@ -5408,9 +5405,9 @@ CONTAINS -1.5296272228579366E-01_dp, 1.8377288757765206E-01_dp, -2.1880198683428151E-01_dp, & 1.4228504563245828E-01_dp, 1.9523650997654252E-01_dp, -9.0945729598550951E-01_dp, & 1.8916140218456958E+00_dp, -2.6232469600311217E+00_dp, 2.4527671312473118E+00_dp, & - -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp/) + -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp] REAL(KIND=dp), DIMENSION(13, 30, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 30, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 30, 5]) INTEGER :: irange @@ -5457,7 +5454,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 32) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8440983439459679E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8440983439459679E-01_dp, & -7.0479249003300562E-02_dp, -1.6832381157590469E-02_dp, 9.9837323526780937E-03_dp, & 5.1989041899428937E-03_dp, -3.5423416042951205E-03_dp, -2.1543663571483209E-03_dp, & 1.3096125508292179E-03_dp, 2.2049401312140603E-03_dp, -2.5023058617921153E-03_dp, & @@ -5590,8 +5587,8 @@ CONTAINS 9.8497860011119158E+00_dp, -3.3639190612129344E+00_dp, 5.9487274112930379E+02_dp, & -1.7978611801015538E+03_dp, 2.7622843520701335E+03_dp, -2.5880461605405826E+03_dp, & 1.4022414211295804E+03_dp, -2.0359258628022113E+02_dp, -2.6091417556034258E+02_dp, & - 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/2.9539145031653501E+01_dp, & + 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [2.9539145031653501E+01_dp, & 4.7715049407002184E+00_dp, -3.2712144543127324E+00_dp, 2.2264348078485641E+03_dp, & -6.6288008445597088E+03_dp, 1.0084012629385183E+04_dp, -9.4383385665132246E+03_dp, & 5.2647790264708256E+03_dp, -1.0875754774918837E+03_dp, -5.8837187049175338E+02_dp, & @@ -5724,8 +5721,8 @@ CONTAINS -1.7628434198318345E+01_dp, 3.9655688909902926E+02_dp, -3.7408946589251713E+02_dp, & 1.5787812785698458E+02_dp, -2.7089362134634474E+01_dp, 2.0614418378112468E+03_dp, & -5.6578757894510300E+03_dp, 7.1620850676558530E+03_dp, -4.4041308675995369E+03_dp, & - -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.5703600920047631E+02_dp, & + -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.5703600920047631E+02_dp, & 6.8515562434659739E+02_dp, 1.8173876061092901E+02_dp, -5.6990417291447488E+02_dp, & 3.3635689037567329E+02_dp, -7.1542971828322536E+01_dp, 4.8609029109261082E+03_dp, & -1.4519102949367327E+04_dp, 2.1140422991455973E+04_dp, -1.7456530345889521E+04_dp, & @@ -5858,8 +5855,8 @@ CONTAINS -6.5694865280062390E+02_dp, 5.9368339749825054E+02_dp, 7.7692645932202890E+02_dp, & -1.0697937873179803E+03_dp, 3.8548984201540087E+01_dp, 6.7608544747530505E+02_dp, & -4.8167622236142665E+02_dp, 1.1263022376557032E+02_dp, 4.9024755081192952E+03_dp, & - -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-4.7874743699806668E+03_dp, & + -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-4.7874743699806668E+03_dp, & -8.5329386064550408E+02_dp, 2.7526945075798449E+03_dp, 1.9553980517436300E+03_dp, & -5.9289564226732664E+03_dp, 4.4771348003328458E+03_dp, -1.0901273950898408E+03_dp, & -3.0130386512273043E+02_dp, 1.6238769196873562E+02_dp, 1.3563319365162426E+04_dp, & @@ -5992,8 +5989,8 @@ CONTAINS -3.7066724475406403E+02_dp, 4.4339421427221095E+02_dp, -2.5185768559746347E+02_dp, & 3.0387188886435422E+02_dp, -4.1221355071839258E+02_dp, 3.9500349025307065E+02_dp, & -3.1942180687176204E+02_dp, 2.4606495659517455E+02_dp, -1.5690263401286234E+02_dp, & - 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.8663851312283325E+03_dp, & + 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.8663851312283325E+03_dp, & -1.0423380612707174E+03_dp, 1.5483806206375675E+03_dp, -9.0806872083263704E+02_dp, & 9.4017350130709883E+02_dp, -1.2957349086372242E+03_dp, 1.2616460034642841E+03_dp, & -9.6943667338306091E+02_dp, 7.0087846283955878E+02_dp, -4.4162263728305550E+02_dp, & @@ -6126,8 +6123,8 @@ CONTAINS 2.6878483032699012E+02_dp, 5.8309882443897629E+02_dp, 6.7807520171925752E-05_dp, & -3.0064117576976992E+02_dp, 3.6682509804999006E+02_dp, -3.7040717157728307E+02_dp, & 1.3406424149107912E+02_dp, 6.4428398410363116E+02_dp, -2.1519786183493156E+03_dp, & - 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp/) - REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = (/-2.7780629763055545E+03_dp, & + 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp] + REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = [-2.7780629763055545E+03_dp, & 7.2394748688135314E+02_dp, 1.4141872703259592E+03_dp, 1.9924393057961005E-04_dp, & -8.8514298674834572E+02_dp, 1.0799982553752052E+03_dp, -1.0299886964497700E+03_dp, & 2.4613962885626509E+02_dp, 2.1496502911088132E+03_dp, -6.6513723885247055E+03_dp, & @@ -6154,9 +6151,9 @@ CONTAINS 4.3939694879051335E+06_dp, 2.2270474259830317E+06_dp, -1.4748142024036435E+07_dp, & 2.4772021603756029E+07_dp, -2.0427694973111704E+07_dp, -5.1425641553283399E+06_dp, & 4.1035528362137891E+07_dp, -5.8536317653180525E+07_dp, 4.1604269769282125E+07_dp, & - -1.2580153353393231E+07_dp/) + -1.2580153353393231E+07_dp] REAL(KIND=dp), DIMENSION(13, 32, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 32, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 32, 5]) INTEGER :: irange @@ -6203,7 +6200,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 34) :: fit_coef - REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = (/1.8370815219029825E+05_dp, & + REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = [1.8370815219029825E+05_dp, & -2.2571407833669311E+05_dp, 1.9425009817913763E+05_dp, -1.0472915274294355E+05_dp, & 2.6504347685948280E+04_dp, 4.7817002324082285E+04_dp, 2.5450661362359097E-02_dp, & -6.6225824542394374E+04_dp, 8.1048394804074065E+04_dp, -4.3435260565217926E+04_dp, & @@ -6287,8 +6284,8 @@ CONTAINS -5.8978754757524757E+06_dp, 7.2176798918735152E+06_dp, 3.1998615207433747E+06_dp, & -2.2851538821395889E+07_dp, 3.8978847055747673E+07_dp, -3.3766691905692071E+07_dp, & -3.6817494449235639E+06_dp, 5.8417659409558006E+07_dp, -8.7460434017794341E+07_dp, & - 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.3076079314075767E-01_dp, & + 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.3076079314075767E-01_dp, & -3.1204465976027999E-02_dp, -1.7122144125202067E-03_dp, 7.1244719472004776E-04_dp, & 9.7914036643084913E-05_dp, -1.6905608998459976E-05_dp, -7.4913349592830019E-05_dp, & 3.9524844540922514E-04_dp, -1.3207548101866621E-03_dp, 2.4893343556511901E-03_dp, & @@ -6421,8 +6418,8 @@ CONTAINS -7.2938082345320598E-01_dp, 1.1849370069427336E+00_dp, 3.0981138444088945E+01_dp, & -3.2826924199015650E+01_dp, 1.8061271201881183E+01_dp, -5.9402359654032049E+00_dp, & 1.0560336370860732E+00_dp, -1.3076665170325774E-03_dp, -9.1952845171647243E-02_dp, & - 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.2901998665259486E+00_dp, & + 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.2901998665259486E+00_dp, & -1.1234438324718303E+00_dp, 1.8249388295785653E+00_dp, 5.3052663877251987E+01_dp, & -5.6300287553126552E+01_dp, 3.1510803678504963E+01_dp, -1.0839542135686512E+01_dp, & 2.1894315183922908E+00_dp, -1.2602122478496375E-01_dp, -1.3889457312206924E-01_dp, & @@ -6555,8 +6552,8 @@ CONTAINS -2.5103650595979259E+00_dp, 4.0981205243496870E+00_dp, -1.9744886540859123E+00_dp, & 2.7900551212540414E-01_dp, 3.9609099066905094E-02_dp, 4.9480572244963817E+01_dp, & -1.0554295952164991E+02_dp, 9.7784802913758284E+01_dp, -3.3609900633466118E+01_dp, & - -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.8292295875978279E+00_dp, & + -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.8292295875978279E+00_dp, & -2.5859581635928466E+00_dp, 8.2643295812249669E+00_dp, -5.7320634779870945E+00_dp, & 1.7650956249120218E+00_dp, -1.9567508222089966E-01_dp, 7.7834138139689216E+01_dp, & -1.8267266020330240E+02_dp, 1.9349073152056008E+02_dp, -9.1481588588459843E+01_dp, & @@ -6689,8 +6686,8 @@ CONTAINS -2.8967923413102912E+00_dp, 1.3681886836307373E+00_dp, 1.3955776856915574E+00_dp, & -1.5897239290899864E-01_dp, -2.5212216600023445E+00_dp, 2.8219668706971945E+00_dp, & -1.3307700093912902E+00_dp, 2.4913514170866757E-01_dp, 3.6963550418790938E+01_dp, & - -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-6.7963494820353745E+00_dp, & + -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-6.7963494820353745E+00_dp, & -5.2037548606327730E+00_dp, 4.1015955423288375E+00_dp, 2.6719939603737344E+00_dp, & -2.0314435192987417E+00_dp, -3.5279015440942261E+00_dp, 5.3011832033957269E+00_dp, & -2.8122613024625087E+00_dp, 5.6915484145040629E-01_dp, 6.4926664043803811E+01_dp, & @@ -6823,8 +6820,8 @@ CONTAINS -8.6651521700026635E-01_dp, 4.9374292598778025E-01_dp, 3.4952603809371302E-01_dp, & -1.7396151407323862E-01_dp, -2.5934913691469813E-01_dp, 9.2007238929733004E-02_dp, & 3.3903391371774966E-01_dp, -4.2381412446029582E-01_dp, 2.1088118199107522E-01_dp, & - -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.2539604263036663E+00_dp, & + -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.2539604263036663E+00_dp, & -1.7332279212896191E+00_dp, 1.2863899425408518E+00_dp, 7.2978346101421798E-01_dp, & -5.0542068060802536E-01_dp, -5.6453129220842824E-01_dp, 2.6844891959416117E-01_dp, & 8.2065620557106000E-01_dp, -1.1421990003730462E+00_dp, 6.4148861901481036E-01_dp, & @@ -6957,8 +6954,8 @@ CONTAINS 1.8297112165331673E+04_dp, 2.0796368651156318E+00_dp, -7.1211773323306998E-02_dp, & -6.5222594833814318E-02_dp, 2.4758880150403027E-02_dp, -2.6172471480240402E-02_dp, & 4.2607134478414486E-02_dp, -4.9952200375915141E-02_dp, 5.1244059328384543E-02_dp, & - -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/1.0378429926308540E-02_dp, & + -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [1.0378429926308540E-02_dp, & -1.9521878957809889E-03_dp, 2.6944073713370376E+00_dp, -1.3634250253884062E-01_dp, & -1.2248962009310110E-01_dp, 5.1739894797576326E-02_dp, -4.9861795300424228E-02_dp, & 8.1764747263490686E-02_dp, -9.6628896510658951E-02_dp, 9.8409054684497427E-02_dp, & @@ -7091,9 +7088,9 @@ CONTAINS -6.0517025375512349E+04_dp, 5.4074356432769353E+04_dp, -3.0109150792826324E+04_dp, & 7.8344472467430223E+03_dp, 1.3254579477277694E+04_dp, 5.1532479271565908E-03_dp, & -1.3351228791461199E+04_dp, 1.6339623735533780E+04_dp, -1.2301930953556473E+04_dp, & - -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp/) + -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp] REAL(KIND=dp), DIMENSION(13, 34, 6), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07/), (/13, 34, 6/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07], [13, 34, 6]) INTEGER :: irange @@ -7145,7 +7142,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 36) :: fit_coef - REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = (/-4.2209902072425757E+02_dp, & + REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = [-4.2209902072425757E+02_dp, & 1.1367036683435998E+02_dp, 2.4004100563047302E+02_dp, 2.6442809338541683E-05_dp, & -9.2920139462935452E+01_dp, 1.1857226657184384E+02_dp, -1.3712334751086243E+02_dp, & 8.9614212066663356E+01_dp, 1.2954531399327851E+02_dp, -6.1204117014894439E+02_dp, & @@ -7258,8 +7255,8 @@ CONTAINS 2.7482124839381648E+00_dp, -1.0319720350104814E+07_dp, 1.3167559540232308E+07_dp, & 5.3141307787938649E+06_dp, -4.2806172437992170E+07_dp, 7.7700737994820118E+07_dp, & -7.6880123309893116E+07_dp, 1.7343391064140473E+07_dp, 7.7860350009209916E+07_dp, & - -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8104907156518354E-01_dp, & + -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8104907156518354E-01_dp, & -6.1817005353024562E-02_dp, -1.5365071642354823E-02_dp, 9.1489217818269322E-03_dp, & 4.9967787273344161E-03_dp, -3.5367914652488903E-03_dp, -2.2075007488833458E-03_dp, & 1.2029276142200300E-03_dp, 2.8328851353903797E-03_dp, -3.4438772536686739E-03_dp, & @@ -7392,8 +7389,8 @@ CONTAINS 1.0488104966880156E+01_dp, -1.6444555466331974E+00_dp, 1.2763045722861104E+02_dp, & -3.2766564765272250E+02_dp, 3.7973217630740623E+02_dp, -1.9781100978811261E+02_dp, & -3.0157621574998899E+01_dp, 9.3237621383503154E+01_dp, -1.4664555123007290E+01_dp, & - -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-5.0683586321199940E+01_dp, & + -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-5.0683586321199940E+01_dp, & 2.2685614985361322E+01_dp, -4.0911306259362732E+00_dp, 2.0692715444769155E+02_dp, & -5.7784708851700361E+02_dp, 7.5313473849594516E+02_dp, -4.9591356082585395E+02_dp, & 4.6934746915158954E+01_dp, 1.7278593891248715E+02_dp, -7.9461883488471031E+01_dp, & @@ -7526,8 +7523,8 @@ CONTAINS 1.7192575597177209E-01_dp, -1.9796532433429683E+00_dp, 1.9593380309152029E+00_dp, & -8.5836023264597161E-01_dp, 1.5125817632192159E-01_dp, 3.3681131542986975E+01_dp, & -3.4585438137019239E+01_dp, 6.9509291872553263E+00_dp, 9.6987345107099117E+00_dp, & - -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.0123022827718544E+00_dp, & + -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.0123022827718544E+00_dp, & -5.8064769221536761E-01_dp, -3.3561931133425400E+00_dp, 3.9944119179735149E+00_dp, & -1.9296809249289084E+00_dp, 3.6684710023030970E-01_dp, 5.8314392583364203E+01_dp, & -6.9071915064420764E+01_dp, 2.0273316780786242E+01_dp, 1.8091276263426014E+01_dp, & @@ -7660,8 +7657,8 @@ CONTAINS -1.2172815962913154E-02_dp, -4.0308427219634048E-02_dp, 7.7287143244938123E-03_dp, & 4.0019771312533585E-02_dp, -3.7854821497454338E-02_dp, 1.0769335283667015E-02_dp, & 1.9476127553671263E-03_dp, -1.2801087884499606E-03_dp, 3.6694426304025538E+00_dp, & - -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/1.3124621600522313E-01_dp, & + -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [1.3124621600522313E-01_dp, & -4.3574928379419176E-02_dp, -8.9899230702256708E-02_dp, 2.4290637640954200E-02_dp, & 9.8569915866746516E-02_dp, -1.0636170473106374E-01_dp, 4.0918764154109298E-02_dp, & -1.9272580657675622E-03_dp, -1.9052149763963443E-03_dp, 5.9890800326505680E+00_dp, & @@ -7794,8 +7791,8 @@ CONTAINS -1.9257015318780568E+03_dp, 3.2472036360073544E+03_dp, -1.9642544031850207E+03_dp, & 1.8422466462758632E+03_dp, -2.5561629910519391E+03_dp, 2.5895289445906710E+03_dp, & -2.0116564542023402E+03_dp, 1.4283611462124322E+03_dp, -8.9489172870925711E+02_dp, & - 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.4073380941871266E+04_dp, & + 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.4073380941871266E+04_dp, & -5.4884212128021491E+03_dp, 1.3338114839397269E+04_dp, -9.1704389994968824E+03_dp, & 6.9234192947715492E+03_dp, -8.9848495511906458E+03_dp, 9.4904838722939803E+03_dp, & -7.0131996973248588E+03_dp, 4.2053129160131894E+03_dp, -2.2892321189981762E+03_dp, & @@ -7928,9 +7925,9 @@ CONTAINS 4.8018190809835360E+01_dp, 1.1735957000719010E+02_dp, 1.0796734300526574E-05_dp, & -3.7912420090540877E+01_dp, 4.8378813528148328E+01_dp, -5.7435863659353501E+01_dp, & 4.0377808851989506E+01_dp, 4.5658311276489918E+01_dp, -2.3911739347016501E+02_dp, & - 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp/) + 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp] REAL(KIND=dp), DIMENSION(13, 36, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 36, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 36, 5]) INTEGER :: irange @@ -7977,7 +7974,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 38) :: fit_coef - REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = (/1.0499223216920694E+01_dp, & + REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = [1.0499223216920694E+01_dp, & 4.4951728164305678E+00_dp, -4.0844623976889828E+01_dp, 9.6469089733765301E+01_dp, & -1.4457308237433509E+02_dp, 1.4358591897299843E+02_dp, -8.6337055270254567E+01_dp, & 2.3772804326078404E+01_dp, 6.6359118115924133E+01_dp, -2.8591296818375736E-06_dp, & @@ -8032,8 +8029,8 @@ CONTAINS 2.1377543596431356E+07_dp, 7.5558560062402077E+06_dp, -6.6595246625963897E+07_dp, & 1.2300183044218574E+08_dp, -1.2663664724774376E+08_dp, 4.1031313200280927E+07_dp, & 1.0283971430652012E+08_dp, -1.9310895904024291E+08_dp, 1.5058167673706385E+08_dp, & - -4.7897275226966202E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4159553890012480E-01_dp, & + -4.7897275226966202E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4159553890012480E-01_dp, & -3.2212259532342614E-02_dp, -2.5211569112270739E-03_dp, 1.0259263161798598E-03_dp, & 1.7009451604343799E-04_dp, -7.4233588848268952E-05_dp, -1.4091849072407304E-05_dp, & 8.9792205912272354E-06_dp, -6.1068721080120308E-07_dp, 2.3673956901460579E-06_dp, & @@ -8166,8 +8163,8 @@ CONTAINS -9.8650715039269197E-04_dp, 8.4812423349403076E-04_dp, 1.9235334619586016E+01_dp, & -2.1430578544580889E+01_dp, 1.0935348023770239E+01_dp, -2.5703290931021043E+00_dp, & -9.3684439339661404E-02_dp, 1.9608483863631485E-01_dp, -1.2873315513389102E-02_dp, & - -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.1899012855183456E-04_dp, & + -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.1899012855183456E-04_dp, & -1.3697632531141069E-03_dp, 1.2268039489488590E-03_dp, 2.6982367118180953E+01_dp, & -3.2203467268313922E+01_dp, 1.8094671738936693E+01_dp, -5.1291575498824864E+00_dp, & 2.2721945369117036E-01_dp, 3.0848319451415068E-01_dp, -5.4944705448018556E-02_dp, & @@ -8300,8 +8297,8 @@ CONTAINS 3.2103644959620231E-02_dp, -1.4486824002301485E-01_dp, 1.2355203927413878E-01_dp, & -4.8092052541477776E-02_dp, 7.5259001655546970E-03_dp, 4.4383894095260246E+00_dp, & -3.5679718788094252E+00_dp, 5.1476908985660208E-01_dp, 8.0172648142794001E-01_dp, & - -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4079316176694362E-01_dp, & + -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4079316176694362E-01_dp, & 1.0204817722398823E-02_dp, -2.5165636141352937E-01_dp, 2.5091425850523480E-01_dp, & -1.0907652615992168E-01_dp, 1.8995561214566335E-02_dp, 6.6017064494743369E+00_dp, & -6.3396206574849705E+00_dp, 1.4645915581906761E+00_dp, 1.3567138102239846E+00_dp, & @@ -8434,8 +8431,8 @@ CONTAINS 4.7301818737714882E+02_dp, 1.3863635256023798E+02_dp, -2.1631236718932931E+02_dp, & -9.4803921196274686E+01_dp, 2.5426811844807858E+02_dp, -1.6576110763951490E+02_dp, & 4.7407189814529652E+01_dp, -4.5099294020295337E+00_dp, 2.9586882462973167E+03_dp, & - -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-9.1855299569510419E+02_dp, & + -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-9.1855299569510419E+02_dp, & 1.5086598025400613E+03_dp, -1.6982251398122094E+02_dp, -5.5006675710728985E+02_dp, & 8.6766882152744344E+01_dp, 4.7256010495026828E+02_dp, -4.6889366551390941E+02_dp, & 1.9581559031410015E+02_dp, -3.2716661828879559E+01_dp, 6.2548032409521911E+03_dp, & @@ -8568,8 +8565,8 @@ CONTAINS -5.9070868285783193E+00_dp, 7.0462234223485760E+00_dp, 2.3163307108458544E+00_dp, & -3.1353286429629565E+00_dp, -1.8613396596490337E+00_dp, 1.7553943424387961E+00_dp, & 3.1455571650317942E+00_dp, -5.5222826187397756E+00_dp, 3.6478129213769028E+00_dp, & - -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.3207068963149325E+01_dp, & + -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.3207068963149325E+01_dp, & -1.0554104925448858E+01_dp, 1.6886407464491334E+01_dp, 3.8180534827516577E+00_dp, & -7.9351781128404237E+00_dp, -3.3784899123822600E+00_dp, 4.6319521704833901E+00_dp, & 6.7239240450100590E+00_dp, -1.3642372104076109E+01_dp, 9.8589344031369794E+00_dp, & @@ -8702,8 +8699,8 @@ CONTAINS -2.0360724244160395E-04_dp, 7.8600093766184087E-01_dp, -2.7552722482330382E-02_dp, & -2.4320818015224920E-02_dp, 9.3274629486534248E-03_dp, -9.2079352354389778E-03_dp, & 1.5452692636155842E-02_dp, -1.8450575101340298E-02_dp, 1.9063757888167280E-02_dp, & - -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/4.0992188628857576E-03_dp, & + -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [4.0992188628857576E-03_dp, & -7.7827564716362676E-04_dp, 1.5427835617899610E+00_dp, -6.9505394993586406E-02_dp, & -6.0594885888198051E-02_dp, 2.4860739271249380E-02_dp, -2.3168221093078572E-02_dp, & 3.9027511015698728E-02_dp, -4.6867833756562442E-02_dp, 4.8230445510777237E-02_dp, & @@ -8836,8 +8833,8 @@ CONTAINS 5.4224742270029606E+02_dp, -3.5283793388597093E+02_dp, 1.4803941533425319E+02_dp, & -2.8871200173717554E+01_dp, 5.6772385530114016E+03_dp, -2.9062895360890998E+03_dp, & -1.7148517487548181E+03_dp, 2.2947989851698503E+03_dp, -1.3525758366401831E+03_dp, & - 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-1.8635835707916260E+03_dp, & + 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-1.8635835707916260E+03_dp, & 1.4615094004676805E+03_dp, -9.4860776301801513E+02_dp, 4.0324630910185732E+02_dp, & -7.9802696400978931E+01_dp, 1.4580340019039370E+04_dp, -8.9648221759975659E+03_dp, & -4.7160531127075310E+03_dp, 7.7970756952852253E+03_dp, -4.7953125668139064E+03_dp, & @@ -8970,9 +8967,9 @@ CONTAINS 1.6548760224475922E+00_dp, -1.7934154017551453E+01_dp, 4.3051248399276048E+01_dp, & -6.4961623842017133E+01_dp, 6.4774151275958900E+01_dp, -3.9049982184732009E+01_dp, & 1.0772159604979572E+01_dp, 3.5239797671962883E+01_dp, -1.2791831843911305E-06_dp, & - -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp/) + -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp] REAL(KIND=dp), DIMENSION(13, 38, 6), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 38, 6/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 38, 6]) INTEGER :: irange @@ -9024,7 +9021,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 40) :: fit_coef - REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = (/3.4482542694423209E+03_dp, & + REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = [3.4482542694423209E+03_dp, & 9.3380638606834109E+03_dp, -3.6141948437832449E+04_dp, 7.3811576243227406E+04_dp, & -1.0360614380245237E+05_dp, 9.9273882530972987E+04_dp, -5.8503038150581720E+04_dp, & 1.5941507970166829E+04_dp, 1.9245609411100908E+04_dp, 1.5758311389454111E-03_dp, & @@ -9131,8 +9128,8 @@ CONTAINS 3.4369174208174527E+07_dp, 1.0603207649981629E+07_dp, -1.0297545596222048E+08_dp, & 1.9337680822524059E+08_dp, -2.0606965563558266E+08_dp, 8.3351497204227954E+07_dp, & 1.3400532965008634E+08_dp, -2.7949474181137478E+08_dp, 2.2551932538988832E+08_dp, & - -7.3358489823807165E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4818427186393188E-01_dp, & + -7.3358489823807165E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4818427186393188E-01_dp, & -3.9684125490741781E-02_dp, -4.5544691512272280E-03_dp, 2.2868531356116861E-03_dp, & 5.4988095348367525E-04_dp, -3.2090841260734175E-04_dp, -9.2010045248866118E-05_dp, & 6.1214638366653809E-05_dp, 2.2665438652455234E-05_dp, -1.8900573386763588E-05_dp, & @@ -9265,8 +9262,8 @@ CONTAINS -5.9740661993351847E-03_dp, 1.4691884865455198E-03_dp, 1.7073926981017319E+01_dp, & -2.1963630226832553E+01_dp, 1.2134829552891802E+01_dp, -2.2528424944623944E+00_dp, & -9.3240764730384440E-01_dp, 4.6660358949448766E-01_dp, 1.0216844176487623E-01_dp, & - -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/5.9915911031709962E-03_dp, & + -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [5.9915911031709962E-03_dp, & -8.6423694074923528E-03_dp, 2.4291300518560965E-03_dp, 2.4071366084770816E+01_dp, & -3.3716515170389293E+01_dp, 2.0906788438349480E+01_dp, -5.2492585742829574E+00_dp, & -1.0597221453010373E+00_dp, 9.1826115756590143E-01_dp, 5.3116568030487622E-02_dp, & @@ -9399,8 +9396,8 @@ CONTAINS 1.2466570600707088E-02_dp, -1.3874197741980808E-02_dp, 4.1907856070478042E-03_dp, & 7.5271368574731106E-04_dp, -5.1647877466666774E-04_dp, 1.7444005611942730E+00_dp, & -5.6824316669549102E-01_dp, -9.5567270387908632E-02_dp, 9.5953975937291464E-02_dp, & - 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4012464467116794E-02_dp, & + 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4012464467116794E-02_dp, & 1.7870937744543961E-02_dp, -2.8284778305657239E-02_dp, 1.4614940139686226E-02_dp, & -2.7014027690474133E-03_dp, -7.8952988099918739E-05_dp, 2.2522270551584125E+00_dp, & -9.9237513069804251E-01_dp, -7.1665511461607434E-02_dp, 1.9968203248776958E-01_dp, & @@ -9533,8 +9530,8 @@ CONTAINS -1.7263628579210469E+01_dp, 1.2547672408466081E+01_dp, 8.4591865266308197E+00_dp, & -5.6249151706448863E+00_dp, -1.1592672327907211E+01_dp, 1.6508808139297699E+01_dp, & -8.5771693846067460E+00_dp, 1.7125060439946929E+00_dp, 2.3966601282404417E+02_dp, & - -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-5.7499561390798192E+01_dp, & + -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-5.7499561390798192E+01_dp, & -2.8667295698939792E+01_dp, 3.3623712254987076E+01_dp, 1.4613232172192909E+01_dp, & -2.2425748408516260E+01_dp, -1.0625183610714041E+01_dp, 2.7811282349984850E+01_dp, & -1.6721270864181005E+01_dp, 3.6190172602275243E+00_dp, 4.3864077011236401E+02_dp, & @@ -9667,8 +9664,8 @@ CONTAINS -7.3049415971812165E-02_dp, 1.6928103093679515E-02_dp, 1.8417725387954376E-02_dp, & -1.9453592218161570E-03_dp, -1.1634328023640639E-02_dp, 3.4714019819061617E-03_dp, & 5.3490931351907831E-03_dp, -3.1907950343243647E-03_dp, -1.4616713023815479E-03_dp, & - 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-3.2389785098025670E-01_dp, & + 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-3.2389785098025670E-01_dp, & -1.5588421416935677E-01_dp, 4.6469218783312088E-02_dp, 4.1557942308222309E-02_dp, & -7.5142092188104671E-03_dp, -2.6806031107589168E-02_dp, 9.2275566818059377E-03_dp, & 1.3149892067901462E-02_dp, -9.4462212865469193E-03_dp, -1.9880182010796601E-03_dp, & @@ -9801,8 +9798,8 @@ CONTAINS 1.1110268324191310E+01_dp, 2.6853251507125306E+03_dp, -2.6690269182691513E+03_dp, & 7.2463711925762794E+01_dp, 1.2014230806845137E+03_dp, -2.9322356189139873E+02_dp, & -4.8871486180307096E+02_dp, 8.0189444854946785E+01_dp, 3.5253998447998373E+02_dp, & - -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/-2.2712994716763473E+02_dp, & + -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [-2.2712994716763473E+02_dp, & 4.0385181038065113E+01_dp, 6.0197819306524152E+03_dp, -6.9664015206915119E+03_dp, & 8.8000828312450119E+02_dp, 3.2181044508507798E+03_dp, -1.3451011011345620E+03_dp, & -1.2427951210535916E+03_dp, 5.4994829125785282E+02_dp, 9.7855377199584927E+02_dp, & @@ -9935,8 +9932,8 @@ CONTAINS 1.6768202331832444E-01_dp, -1.0515504828494937E-01_dp, 4.2563447502959498E-02_dp, & -8.2219895159869709E-03_dp, 9.5923398264069970E+00_dp, -9.1351432511338171E-01_dp, & -7.2002060302993121E-01_dp, 3.4478262562537942E-01_dp, -2.6236445928893765E-01_dp, & - 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-4.3224032563729953E-01_dp, & + 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-4.3224032563729953E-01_dp, & 3.5758483946236974E-01_dp, -2.2431923396808751E-01_dp, 9.0777959192790053E-02_dp, & -1.7518061809443625E-02_dp, 1.6725498665042689E+01_dp, -1.9435939058523524E+00_dp, & -1.5082483802542699E+00_dp, 7.7123067496772879E-01_dp, -5.6050187357065773E-01_dp, & @@ -10069,9 +10066,9 @@ CONTAINS 2.5970516090366850E+03_dp, -1.1583854023864891E+04_dp, 2.4553873694398699E+04_dp, & -3.5160886963347439E+04_dp, 3.4138635891960170E+04_dp, -2.0309554368209294E+04_dp, & 5.5733463618645619E+03_dp, 7.3092031064017010E+03_dp, 4.9005183646288716E-04_dp, & - -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp/) + -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp] REAL(KIND=dp), DIMENSION(13, 40, 6), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 40, 6/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 40, 6]) INTEGER :: irange @@ -10166,7 +10163,7 @@ CONTAINS E_ratio = 1.0_dp END IF aw(:) = aw(:)/E_ratio - END SUBROUTINE + END SUBROUTINE rescale_grid ! ************************************************************************************************** !> \brief ... @@ -10184,7 +10181,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 799.0_dp) THEN E_ratio = 799.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13642311899920728_dp, & 0.4200545572769177_dp, & 0.7370807753440111_dp, & @@ -10236,9 +10233,9 @@ CONTAINS 175.19453971323657_dp, & 301.19411259128674_dp, & 645.6383267719649_dp, & - 2472.504957810595_dp/) + 2472.504957810595_dp] ELSE IF (E_range < 995.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13925292153649474_dp, & 0.4292451559612877_dp, & 0.7548554587233549_dp, & @@ -10290,9 +10287,9 @@ CONTAINS 211.68822580031673_dp, & 364.5832859080767_dp, & 780.7919711700442_dp, & - 2983.4784258039044_dp/) + 2983.4784258039044_dp] ELSE IF (E_range < 1293.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14255313239112444_dp, & 0.44000221057671707_dp, & 0.7757923584694003_dp, & @@ -10344,9 +10341,9 @@ CONTAINS 265.33605383413214_dp, & 458.1910477032067_dp, & 980.4158381921823_dp, & - 3736.258588894085_dp/) + 3736.258588894085_dp] ELSE IF (E_range < 1738.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1461752355773306_dp, & 0.45185762356828396_dp, & 0.7990360544025357_dp, & @@ -10398,9 +10395,9 @@ CONTAINS 342.31559687568875_dp, & 593.3221880856304_dp, & 1268.7961696472178_dp, & - 4820.528614472729_dp/) + 4820.528614472729_dp] ELSE IF (E_range < 2238.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1491837006061548_dp, & 0.46174475862674996_dp, & 0.8185592742668346_dp, & @@ -10452,9 +10449,9 @@ CONTAINS 425.4335136047249_dp, & 740.2128400786926_dp, & 1582.657563073928_dp, & - 5997.255668095278_dp/) + 5997.255668095278_dp] ELSE IF (E_range < 3009.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15260234927102537_dp, & 0.47302539641929003_dp, & 0.840991102837249_dp, & @@ -10506,9 +10503,9 @@ CONTAINS 548.3643432689413_dp, & 959.1555990081102_dp, & 2051.35284281865_dp, & - 7749.544195896773_dp/) + 7749.544195896773_dp] ELSE IF (E_range < 4377.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15677016271388225_dp, & 0.4868453590049744_dp, & 0.8687054372436632_dp, & @@ -10560,9 +10557,9 @@ CONTAINS 755.1838770980437_dp, & 1331.5355795873638_dp, & 2851.124163900499_dp, & - 10729.678598478598_dp/) + 10729.678598478598_dp] ELSE IF (E_range < 6256.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16057542542593983_dp, & 0.49952962028824754_dp, & 0.8943731123892699_dp, & @@ -10614,9 +10611,9 @@ CONTAINS 1022.6891506041642_dp, & 1819.6861630933722_dp, & 3904.600906393468_dp, & - 14642.034530501202_dp/) + 14642.034530501202_dp] ELSE IF (E_range < 9034.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16432089011213946_dp, & 0.5120783448939726_dp, & 0.9199886972681118_dp, & @@ -10668,9 +10665,9 @@ CONTAINS 1393.996082618058_dp, & 2507.6502273684464_dp, & 5398.730047404666_dp, & - 20174.243482162154_dp/) + 20174.243482162154_dp] ELSE IF (E_range < 15564.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16955168876185606_dp, & 0.5297128492681893_dp, & 0.9563682595025127_dp, & @@ -10722,9 +10719,9 @@ CONTAINS 2193.7537015644107_dp, & 4023.287609783773_dp, & 8726.293698066565_dp, & - 32456.229019326278_dp/) + 32456.229019326278_dp] ELSE IF (E_range < 19500.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17161078656390408_dp, & 0.5366905364814994_dp, & 0.97088881076514_dp, & @@ -10776,9 +10773,9 @@ CONTAINS 2641.8070030495096_dp, & 4889.503800534578_dp, & 10648.322208945656_dp, & - 39537.49857015622_dp/) + 39537.49857015622_dp] ELSE IF (E_range < 22300.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1728061198835349_dp, & 0.5407506981101403_dp, & 0.9793714038026303_dp, & @@ -10830,9 +10827,9 @@ CONTAINS 2948.8741403686568_dp, & 5489.390378606207_dp, & 11987.379922744534_dp, & - 44468.08958434164_dp/) + 44468.08958434164_dp] ELSE IF (E_range < 24783.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1737308948597355_dp, & 0.5438966877521114_dp, & 0.9859610380912929_dp, & @@ -10884,9 +10881,9 @@ CONTAINS 3214.1964330189876_dp, & 6011.5393853613305_dp, & 13158.00196550311_dp, & - 48777.36298097777_dp/) + 48777.36298097777_dp] ELSE IF (E_range < 41198.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17799130240706984_dp, & 0.558445410809649_dp, & 1.0166297309491044_dp, & @@ -10938,9 +10935,9 @@ CONTAINS 4842.950527196566_dp, & 9285.588160319077_dp, & 20597.325965171356_dp, & - 76161.8596274348_dp/) + 76161.8596274348_dp] ELSE IF (E_range < 94407.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18427327646299554_dp, & 0.5800678142111884_dp, & 1.062813174396542_dp, & @@ -10992,9 +10989,9 @@ CONTAINS 9266.732583950343_dp, & 18647.213606093355_dp, & 42656.46566405554_dp, & - 157660.6216097217_dp/) + 157660.6216097217_dp] ELSE IF (E_range < 189080.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1889166187549335_dp, & 0.5961850834729495_dp, & 1.097718788260886_dp, & @@ -11046,9 +11043,9 @@ CONTAINS 15593.849284273198_dp, & 32917.0364973997_dp, & 78051.06376348506_dp, & - 289942.76429117593_dp/) + 289942.76429117593_dp] ELSE IF (E_range < 457444.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.194043824675455_dp, & 0.6141201650984125_dp, & 1.137056339966442_dp, & @@ -11100,9 +11097,9 @@ CONTAINS 29125.998944110084_dp, & 65928.95446339808_dp, & 166172.86831676983_dp, & - 628359.6031461136_dp/) + 628359.6031461136_dp] ELSE IF (E_range < 2101965.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.20097761439605452_dp, & 0.6386142361636943_dp, & 1.1916436123207983_dp, & @@ -11154,9 +11151,9 @@ CONTAINS 75639.29476513214_dp, & 196582.0757874882_dp, & 575257.5915715584_dp, & - 2362446.5347060743_dp/) + 2362446.5347060743_dp] ELSE IF (E_range < 14140999.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.20658002404396444_dp, & 0.6586140986839257_dp, & 1.2369737792708104_dp, & @@ -11208,9 +11205,9 @@ CONTAINS 186203.45469776812_dp, & 576894.7309753906_dp, & 2152261.8479348915_dp, & - 11566361.80487531_dp/) + 11566361.80487531_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.20878089337233605_dp, & 0.6665236543193817_dp, & 1.2550931614146674_dp, & @@ -11262,9 +11259,9 @@ CONTAINS 277390.3096379278_dp, & 946568.3924295901_dp, & 4140822.150621181_dp, & - 30376446.323901277_dp/) + 30376446.323901277_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_26 ! ************************************************************************************************** !> \brief ... @@ -11282,7 +11279,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 1545.0_dp) THEN E_ratio = 1545.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13575757270404953_dp, & 0.4178973639556045_dp, & 0.7329236428021971_dp, & @@ -11338,9 +11335,9 @@ CONTAINS 333.52874619054023_dp, & 573.9031161499247_dp, & 1229.5973040920514_dp, & - 4703.444164101694_dp/) + 4703.444164101694_dp] ELSE IF (E_range < 2002.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13875490228933057_dp, & 0.4276255171652803_dp, & 0.7517156037290086_dp, & @@ -11396,9 +11393,9 @@ CONTAINS 417.7474719630637_dp, & 720.4456660885186_dp, & 1542.1360738637661_dp, & - 5884.200372654236_dp/) + 5884.200372654236_dp] ELSE IF (E_range < 2600.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14170133198228974_dp, & 0.4372217263238123_dp, & 0.7703667410153948_dp, & @@ -11454,9 +11451,9 @@ CONTAINS 524.1575321727823_dp, & 906.5045080905089_dp, & 1939.0883159241562_dp, & - 7379.912745615771_dp/) + 7379.912745615771_dp] ELSE IF (E_range < 3300.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1443213439813841_dp, & 0.4457831750819166_dp, & 0.7871040955754438_dp, & @@ -11512,9 +11509,9 @@ CONTAINS 644.5187891323013_dp, & 1118.0760747835973_dp, & 2390.794104288915_dp, & - 9077.664025334678_dp/) + 9077.664025334678_dp] ELSE IF (E_range < 4000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14638817647917096_dp, & 0.4525562304919969_dp, & 0.8004113661058508_dp, & @@ -11570,9 +11567,9 @@ CONTAINS 761.3056079394062_dp, & 1324.411398249371_dp, & 2831.738972704671_dp, & - 10731.431828374814_dp/) + 10731.431828374814_dp] ELSE IF (E_range < 5000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14873276811274175_dp, & 0.4602604435552678_dp, & 0.8156202251610892_dp, & @@ -11628,9 +11625,9 @@ CONTAINS 923.1971063861915_dp, & 1612.0060664213056_dp, & 3447.1144071775916_dp, & - 13034.665823606138_dp/) + 13034.665823606138_dp] ELSE IF (E_range < 5800.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1502608626762777_dp, & 0.46529381929136415_dp, & 0.8255984287192656_dp, & @@ -11686,9 +11683,9 @@ CONTAINS 1049.2452864243335_dp, & 1837.0994387864066_dp, & 3929.4241467171732_dp, & - 14836.654624922767_dp/) + 14836.654624922767_dp] ELSE IF (E_range < 7000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15216067096721872_dp, & 0.471565223326128_dp, & 0.8380780093696487_dp, & @@ -11744,9 +11741,9 @@ CONTAINS 1233.5478315642981_dp, & 2167.935258865102_dp, & 4639.411026254049_dp, & - 17485.041970829057_dp/) + 17485.041970829057_dp] ELSE IF (E_range < 8500.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1540799216139811_dp, & 0.47791627634651673_dp, & 0.850769563354445_dp, & @@ -11802,9 +11799,9 @@ CONTAINS 1457.1994566202313_dp, & 2571.939694554795_dp, & 5508.2172091289185_dp, & - 20720.162172438253_dp/) + 20720.162172438253_dp] ELSE IF (E_range < 11000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15656226451877622_dp, & 0.4861541997731515_dp, & 0.8673131850431656_dp, & @@ -11860,9 +11857,9 @@ CONTAINS 1816.6489638049509_dp, & 3226.5521973584873_dp, & 6920.118346610322_dp, & - 25967.01374573565_dp/) + 25967.01374573565_dp] ELSE IF (E_range < 14000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15881564616129193_dp, & 0.4936556598653273_dp, & 0.8824588841815081_dp, & @@ -11918,9 +11915,9 @@ CONTAINS 2230.6304097502575_dp, & 3987.780431784136_dp, & 8568.294988757902_dp, & - 32079.26783423429_dp/) + 32079.26783423429_dp] ELSE IF (E_range < 18000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1610939781339949_dp, & 0.5012631407780889_dp, & 0.8978984268667602_dp, & @@ -11976,9 +11973,9 @@ CONTAINS 2759.7196504068343_dp, & 4970.842422998521_dp, & 10706.437123051388_dp, & - 39993.678157447954_dp/) + 39993.678157447954_dp] ELSE IF (E_range < 22000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16286202517738316_dp, & 0.5071829401058993_dp, & 0.9099691167949224_dp, & @@ -12034,9 +12031,9 @@ CONTAINS 3268.0690080523195_dp, & 5925.0502577809875_dp, & 12791.74491637296_dp, & - 47700.6553314684_dp/) + 47700.6553314684_dp] ELSE IF (E_range < 30000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16550588765942553_dp, & 0.516062009336416_dp, & 0.9281674926129342_dp, & @@ -12092,9 +12089,9 @@ CONTAINS 4236.78509184323_dp, & 7766.730019457065_dp, & 16842.450828736164_dp, & - 62648.76273159001_dp/) + 62648.76273159001_dp] ELSE IF (E_range < 40000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1678624984386396_dp, & 0.5240039277065677_dp, & 0.9445413343768262_dp, & @@ -12150,9 +12147,9 @@ CONTAINS 5379.192173747507_dp, & 9973.306180469173_dp, & 21737.4521360814_dp, & - 80688.08263620315_dp/) + 80688.08263620315_dp] ELSE IF (E_range < 55000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17036496307430077_dp, & 0.5324663182632273_dp, & 0.9620895318113227_dp, & @@ -12208,9 +12205,9 @@ CONTAINS 6988.303443289154_dp, & 13136.528535241805_dp, & 28826.90535778617_dp, & - 106792.5668680263_dp/) + 106792.5668680263_dp] ELSE IF (E_range < 75000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17269556592412857_dp, & 0.5403748964029321_dp, & 0.9785852679690707_dp, & @@ -12266,9 +12263,9 @@ CONTAINS 8991.001468037319_dp, & 17151.64888313862_dp, & 37936.68288424044_dp, & - 140330.3757792011_dp/) + 140330.3757792011_dp] ELSE IF (E_range < 100000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17476493191141415_dp, & 0.5474193940515534_dp, & 0.9933573948794411_dp, & @@ -12324,9 +12321,9 @@ CONTAINS 11326.739601304256_dp, & 21929.575378095506_dp, & 48923.087093047834_dp, & - 180801.94440922138_dp/) + 180801.94440922138_dp] ELSE IF (E_range < 140000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17707349703529857_dp, & 0.5553034658173043_dp, & 1.0099791730991756_dp, & @@ -12382,9 +12379,9 @@ CONTAINS 14783.538737749648_dp, & 29163.479733223845_dp, & 65827.4645722146_dp, & - 243179.26518144744_dp/) + 243179.26518144744_dp] ELSE IF (E_range < 200000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17939121623291196_dp, & 0.5632460962554191_dp, & 1.0268207360191903_dp, & @@ -12440,9 +12437,9 @@ CONTAINS 19511.673781213012_dp, & 39328.72129742758_dp, & 90071.79118231079_dp, & - 332938.41349157074_dp/) + 332938.41349157074_dp] ELSE IF (E_range < 280000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18145787532761345_dp, & 0.5703516980411364_dp, & 1.041969987100468_dp, & @@ -12498,9 +12495,9 @@ CONTAINS 25223.35236302233_dp, & 51966.7592745666_dp, & 120920.32428947231_dp, & - 447736.17541344964_dp/) + 447736.17541344964_dp] ELSE IF (E_range < 400000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18352365749998711_dp, & 0.5774767415391759_dp, & 1.0572402465072317_dp, & @@ -12556,9 +12553,9 @@ CONTAINS 32921.61554906603_dp, & 69533.14758216766_dp, & 164947.39394785516_dp, & - 612800.2731138045_dp/) + 612800.2731138045_dp] ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1865127174002091_dp, & 0.5878264119237888_dp, & 1.0795642254870847_dp, & @@ -12614,9 +12611,9 @@ CONTAINS 49336.106221828624_dp, & 108694.3328979675_dp, & 267237.7291173849_dp, & - 1002021.1700926761_dp/) + 1002021.1700926761_dp] ELSE IF (E_range < 1200000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18910898992309827_dp, & 0.5968553778314455_dp, & 1.099179600396227_dp, & @@ -12672,9 +12669,9 @@ CONTAINS 71590.44785506214_dp, & 164831.2803483035_dp, & 422312.83970923733_dp, & - 1607194.846517409_dp/) + 1607194.846517409_dp] ELSE IF (E_range < 2000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19132297837375925_dp, & 0.6045842212401715_dp, & 1.116075239909931_dp, & @@ -12730,9 +12727,9 @@ CONTAINS 100098.51304747425_dp, & 240936.64519318528_dp, & 645993.0255202315_dp, & - 2511145.760363479_dp/) + 2511145.760363479_dp] ELSE IF (E_range < 4500000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19436594608582472_dp, & 0.6152519388154075_dp, & 1.1395565637382394_dp, & @@ -12788,9 +12785,9 @@ CONTAINS 163720.9776403595_dp, & 424479.54068993696_dp, & 1238540.16298379_dp, & - 5075528.538071685_dp/) + 5075528.538071685_dp] ELSE IF (E_range < 10000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19682681061058516_dp, & 0.6239175967168831_dp, & 1.1587697829037367_dp, & @@ -12846,9 +12843,9 @@ CONTAINS 251532.47511127745_dp, & 702946.2892638468_dp, & 2257925.6950304266_dp, & - 10050972.42119658_dp/) + 10050972.42119658_dp] ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.20028753559878754_dp, & 0.636163845466183_dp, & 1.1861370761903154_dp, & @@ -12904,9 +12901,9 @@ CONTAINS 488713.1004068534_dp, & 1569108.161138_dp, & 6194788.779558858_dp, & - 36612022.104547605_dp/) + 36612022.104547605_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.20148359962188625_dp, & 0.6404126846191118_dp, & 1.1956914499421463_dp, & @@ -12962,9 +12959,9 @@ CONTAINS 627349.5338890508_dp, & 2140772.611660053_dp, & 9364952.860952146_dp, & - 68700022.28914484_dp/) + 68700022.28914484_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_28 ! ************************************************************************************************** !> \brief ... @@ -12983,7 +12980,7 @@ CONTAINS IF (E_range < 2906.0_dp) THEN E_ratio = 2906.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13472077973006066_dp, & 0.41454012407362284_dp, & 0.7264650127115554_dp, & @@ -13043,9 +13040,9 @@ CONTAINS 619.9912456625073_dp, & 1067.5959324975324_dp, & 2286.544806677275_dp, & - 8738.901002766614_dp/) + 8738.901002766614_dp] ELSE IF (E_range < 3236.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13585569926755156_dp, & 0.41821529920891193_dp, & 0.7335359382994969_dp, & @@ -13105,9 +13102,9 @@ CONTAINS 681.1401603164769_dp, & 1173.9561106510982_dp, & 2513.427330670278_dp, & - 9596.45252078042_dp/) + 9596.45252078042_dp] ELSE IF (E_range < 3810.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1375558839742156_dp, & 0.4237299246561157_dp, & 0.7441765936480988_dp, & @@ -13167,9 +13164,9 @@ CONTAINS 785.6426382482606_dp, & 1356.1465778665718_dp, & 2902.1064912290262_dp, & - 11063.595563099649_dp/) + 11063.595563099649_dp] ELSE IF (E_range < 4405.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13904406912216055_dp, & 0.4285658262322887_dp, & 0.7535381269110286_dp, & @@ -13229,9 +13226,9 @@ CONTAINS 891.8325474154066_dp, & 1541.8004917177743_dp, & 3298.2637895129933_dp, & - 12556.72637834854_dp/) + 12556.72637834854_dp] ELSE IF (E_range < 5400.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1410960680209205_dp, & 0.43524771510986004_dp, & 0.7665207024486466_dp, & @@ -13291,9 +13288,9 @@ CONTAINS 1065.3146704916662_dp, & 1846.16967438266_dp, & 3948.0236905716197_dp, & - 15001.510222225108_dp/) + 15001.510222225108_dp] ELSE IF (E_range < 6800.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1433674220737173_dp, & 0.4426628898148459_dp, & 0.7809932553639084_dp, & @@ -13353,9 +13350,9 @@ CONTAINS 1302.3421015152915_dp, & 2264.016465253404_dp, & 4840.7455216590715_dp, & - 18353.395351716823_dp/) + 18353.395351716823_dp] ELSE IF (E_range < 8400.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14540131106958792_dp, & 0.4493201231807535_dp, & 0.7940459513320671_dp, & @@ -13415,9 +13412,9 @@ CONTAINS 1565.1330028308446_dp, & 2729.7495636084445_dp, & 5836.893913938098_dp, & - 22085.748007810864_dp/) + 22085.748007810864_dp] ELSE IF (E_range < 10000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14704498509396693_dp, & 0.4547122051327194_dp, & 0.8046596707087634_dp, & @@ -13477,9 +13474,9 @@ CONTAINS 1820.9007070932764_dp, & 3185.3327939434785_dp, & 6812.567149441103_dp, & - 25734.79348292465_dp/) + 25734.79348292465_dp] ELSE IF (E_range < 12000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14873028953425532_dp, & 0.46025228447257244_dp, & 0.815604068464183_dp, & @@ -13539,9 +13536,9 @@ CONTAINS 2132.484724545273_dp, & 3743.164994620193_dp, & 8008.935958082978_dp, & - 30201.87390773344_dp/) + 30201.87390773344_dp] ELSE IF (E_range < 15000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15074658869167354_dp, & 0.4668958035836203_dp, & 0.8287813045866178_dp, & @@ -13601,9 +13598,9 @@ CONTAINS 2585.9493214732233_dp, & 4560.104639212192_dp, & 9764.47140618184_dp, & - 36744.78826999934_dp/) + 36744.78826999934_dp] ELSE IF (E_range < 20000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15327074211168326_dp, & 0.47523666558201105_dp, & 0.8454081293698346_dp, & @@ -13663,9 +13660,9 @@ CONTAINS 3312.4890760215126_dp, & 5880.358930845362_dp, & 12610.246229383727_dp, & - 47327.426186591925_dp/) + 47327.426186591925_dp] ELSE IF (E_range < 28000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15611582449200168_dp, & 0.484670676531795_dp, & 0.864327133672447_dp, & @@ -13725,9 +13722,9 @@ CONTAINS 4418.177298699454_dp, & 7913.127380453787_dp, & 17012.044780129974_dp, & - 63654.92138377425_dp/) + 63654.92138377425_dp] ELSE IF (E_range < 38000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1585986414808211_dp, & 0.49293227874864953_dp, & 0.8809949627642996_dp, & @@ -13787,9 +13784,9 @@ CONTAINS 5728.411572233089_dp, & 10353.785071731596_dp, & 22327.676016416055_dp, & - 83326.1396670659_dp/) + 83326.1396670659_dp] ELSE IF (E_range < 50000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16074983925508995_dp, & 0.5001125329781305_dp, & 0.895558007331798_dp, & @@ -13849,9 +13846,9 @@ CONTAINS 7222.917612404246_dp, & 13174.2778180717_dp, & 28509.267725054422_dp, & - 106160.2639173599_dp/) + 106160.2639173599_dp] ELSE IF (E_range < 64000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16262039381403579_dp, & 0.5063730793021797_dp, & 0.9083149017898943_dp, & @@ -13911,9 +13908,9 @@ CONTAINS 8885.07671917959_dp, & 16351.40165928286_dp, & 35518.56312434257_dp, & - 132016.67889946306_dp/) + 132016.67889946306_dp] ELSE IF (E_range < 84000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16461121992013572_dp, & 0.5130537467027886_dp, & 0.9219891409850267_dp, & @@ -13973,9 +13970,9 @@ CONTAINS 11143.129516033901_dp, & 20727.354533996564_dp, & 45246.467731381585_dp, & - 167864.82966862986_dp/) + 167864.82966862986_dp] ELSE IF (E_range < 110000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16651351865477473_dp, & 0.519454577907408_dp, & 0.9351507515667731_dp, & @@ -14035,9 +14032,9 @@ CONTAINS 13921.767968244894_dp, & 26195.561124088643_dp, & 57512.80156760765_dp, & - 213037.54770361463_dp/) + 213037.54770361463_dp] ELSE IF (E_range < 160000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1690396225959909_dp, & 0.527980783630836_dp, & 0.9527749551685267_dp, & @@ -14097,9 +14094,9 @@ CONTAINS 18902.03087469423_dp, & 36195.04534310194_dp, & 80228.85952678222_dp, & - 296685.58400527935_dp/) + 296685.58400527935_dp] ELSE IF (E_range < 220000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17108080746256005_dp, & 0.5348926066785868_dp, & 0.9671403722271738_dp, & @@ -14159,9 +14156,9 @@ CONTAINS 24425.382905474227_dp, & 47540.939727448866_dp, & 106401.9838008185_dp, & - 393145.5653859997_dp/) + 393145.5653859997_dp] ELSE IF (E_range < 370000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.174208015078396_dp, & 0.5455214527091232_dp, & 0.9893700986809595_dp, & @@ -14221,9 +14218,9 @@ CONTAINS 36827.67063798521_dp, & 73825.92204301585_dp, & 168436.45444117606_dp, & - 622444.873239739_dp/) + 622444.873239739_dp] ELSE IF (E_range < 520000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1761202582043389_dp, & 0.5520447609872519_dp, & 1.0030974507555772_dp, & @@ -14283,9 +14280,9 @@ CONTAINS 47901.44750228873_dp, & 98085.01445426073_dp, & 227192.3617986822_dp, & - 840731.2172617969_dp/) + 840731.2172617969_dp] ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1777047921517639_dp, & 0.5574641492548221_dp, & 1.0145511230139452_dp, & @@ -14345,9 +14342,9 @@ CONTAINS 60011.99599547493_dp, & 125336.8664775516_dp, & 294698.3519483209_dp, & - 1092989.8333233916_dp/) + 1092989.8333233916_dp] ELSE IF (E_range < 1100000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1799647702096782_dp, & 0.5652158330702483_dp, & 1.0310122635781176_dp, & @@ -14407,9 +14404,9 @@ CONTAINS 83848.098471279_dp, & 180849.87459593892_dp, & 436512.7424947387_dp, & - 1628215.5545881148_dp/) + 1628215.5545881148_dp] ELSE IF (E_range < 1800000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1822263529525982_dp, & 0.5729996377421059_dp, & 1.047635792810745_dp, & @@ -14469,9 +14466,9 @@ CONTAINS 119209.6009779448_dp, & 267043.87988619285_dp, & 666555.4805450162_dp, & - 2511681.1233505663_dp/) + 2511681.1233505663_dp] ELSE IF (E_range < 3300000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1847328901237733_dp, & 0.5816579181920506_dp, & 1.06623831659397_dp, & @@ -14531,9 +14528,9 @@ CONTAINS 180141.95260617262_dp, & 424305.6328571203_dp, & 1112162.6633453001_dp, & - 4275158.808925236_dp/) + 4275158.808925236_dp] ELSE IF (E_range < 6000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18691650786522696_dp, & 0.5892282516421157_dp, & 1.082601142199495_dp, & @@ -14593,9 +14590,9 @@ CONTAINS 264080.7768830504_dp, & 655640.4058250692_dp, & 1818602.1997626221_dp, & - 7205611.5064693205_dp/) + 7205611.5064693205_dp] ELSE IF (E_range < 18000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19022370155321527_dp, & 0.600743360402157_dp, & 1.1076668599949147_dp, & @@ -14655,9 +14652,9 @@ CONTAINS 494979.5222323457_dp, & 1359946.1830275727_dp, & 4269995.133188314_dp, & - 18594665.56920044_dp/) + 18594665.56920044_dp] ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19253210390672987_dp, & 0.6088167991143922_dp, & 1.1253694421581641_dp, & @@ -14717,9 +14714,9 @@ CONTAINS 801312.2270425739_dp, & 2415145.5599759216_dp, & 8639654.807896439_dp, & - 43666635.56753933_dp/) + 43666635.56753933_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.1949107095730563_dp, & 0.6171672239307736_dp, & 1.143792172436484_dp, & @@ -14779,9 +14776,9 @@ CONTAINS 1380639.0831843547_dp, & 4711303.6808049455_dp, & 20609904.76278654_dp, & - 151191206.84136662_dp/) + 151191206.84136662_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_30 ! ************************************************************************************************** !> \brief ... @@ -14799,7 +14796,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 4862.0_dp) THEN E_ratio = 4862.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13254275519610229_dp, & 0.4075002434334006_dp, & 0.7129653611128071_dp, & @@ -14863,9 +14860,9 @@ CONTAINS 1039.6543728256195_dp, & 1789.9748349736915_dp, & 3833.9681364720745_dp, & - 14655.44632366239_dp/) + 14655.44632366239_dp] ELSE IF (E_range < 5846.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1343248849882633_dp, & 0.4132592119099152_dp, & 0.7240043390799359_dp, & @@ -14929,9 +14926,9 @@ CONTAINS 1222.611932252175_dp, & 2108.162233431274_dp, & 4512.831122628449_dp, & - 17222.120678400817_dp/) + 17222.120678400817_dp] ELSE IF (E_range < 6665.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13557338601660668_dp, & 0.41730065260389615_dp, & 0.7317746815552322_dp, & @@ -14995,9 +14992,9 @@ CONTAINS 1371.947991018934_dp, & 2368.536327804507_dp, & 5068.399861166353_dp, & - 19319.551508880766_dp/) + 19319.551508880766_dp] ELSE IF (E_range < 7800.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1370499857872464_dp, & 0.422087838650514_dp, & 0.7410040914005517_dp, & @@ -15061,9 +15058,9 @@ CONTAINS 1575.1576866889702_dp, & 2723.745097867967_dp, & 5826.475195617796_dp, & - 22177.608473258828_dp/) + 22177.608473258828_dp] ELSE IF (E_range < 10044.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1393751435556022_dp, & 0.4296428076126454_dp, & 0.7556269118458908_dp, & @@ -15127,9 +15124,9 @@ CONTAINS 1966.3786822155184_dp, & 3410.3262356194664_dp, & 7292.46886903304_dp, & - 27693.855354838164_dp/) + 27693.855354838164_dp] ELSE IF (E_range < 14058.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14237486453944107_dp, & 0.4394200534952092_dp, & 0.7746555330683098_dp, & @@ -15193,9 +15190,9 @@ CONTAINS 2639.3168711629464_dp, & 4598.936377351543_dp, & 9833.306219117254_dp, & - 37228.01191754706_dp/) + 37228.01191754706_dp] ELSE IF (E_range < 19114.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14502370796551703_dp, & 0.4480829010539378_dp, & 0.7916157981286331_dp, & @@ -15259,9 +15256,9 @@ CONTAINS 3450.91828637881_dp, & 6043.794023233803_dp, & 12927.644737686549_dp, & - 48805.08862191054_dp/) + 48805.08862191054_dp] ELSE IF (E_range < 25870.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14754727473790832_dp, & 0.4563621690490255_dp, & 0.8079150128057052_dp, & @@ -15325,9 +15322,9 @@ CONTAINS 4489.970449108518_dp, & 7909.344598672393_dp, & 16932.78473977757_dp, & - 63749.23270457554_dp/) + 63749.23270457554_dp] ELSE IF (E_range < 35180.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15002348519433922_dp, & 0.46451130342750646_dp, & 0.824045021042684_dp, & @@ -15391,9 +15388,9 @@ CONTAINS 5859.209649832797_dp, & 10391.307380953114_dp, & 22278.529118569048_dp, & - 83643.6346001724_dp/) + 83643.6346001724_dp] ELSE IF (E_range < 58986.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15399032986872938_dp, & 0.4776194738561411_dp, & 0.8501753043803365_dp, & @@ -15457,9 +15454,9 @@ CONTAINS 9137.412009720016_dp, & 16424.470778988587_dp, & 35351.12874442453_dp, & - 132131.62635064372_dp/) + 132131.62635064372_dp] ELSE IF (E_range < 85052.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15665201491118563_dp, & 0.48645255086696204_dp, & 0.8679140908633145_dp, & @@ -15523,9 +15520,9 @@ CONTAINS 12481.117979830125_dp, & 22687.396569080272_dp, & 49029.27213151443_dp, & - 182714.99577064996_dp/) + 182714.99577064996_dp] ELSE IF (E_range < 126612.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15940855323823325_dp, & 0.4956331404107984_dp, & 0.8864643437510178_dp, & @@ -15589,9 +15586,9 @@ CONTAINS 17463.261532301312_dp, & 32186.387908159864_dp, & 69962.03966745277_dp, & - 259964.04274551442_dp/) + 259964.04274551442_dp] ELSE IF (E_range < 247709.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16373958436697705_dp, & 0.5101264978608379_dp, & 0.9159896069529507_dp, & @@ -15655,9 +15652,9 @@ CONTAINS 30505.194880449075_dp, & 57794.75930208428_dp, & 127350.9867284555_dp, & - 471374.61882211326_dp/) + 471374.61882211326_dp] ELSE IF (E_range < 452410.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16729345587752817_dp, & 0.5220837915443625_dp, & 0.9405741148525995_dp, & @@ -15721,9 +15718,9 @@ CONTAINS 49765.1843652489_dp, & 97101.2613405646_dp, & 217655.43736295513_dp, & - 804161.4023302288_dp/) + 804161.4023302288_dp] ELSE IF (E_range < 1104308.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17199827765823103_dp, & 0.5380059294727404_dp, & 0.9736341997615289_dp, & @@ -15787,9 +15784,9 @@ CONTAINS 100319.89810256775_dp, & 206207.35016280194_dp, & 478990.19443877833_dp, & - 1773158.149536881_dp/) + 1773158.149536881_dp] ELSE IF (E_range < 2582180.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17588045499160682_dp, & 0.5512257021498627_dp, & 1.0013703118630188_dp, & @@ -15853,9 +15850,9 @@ CONTAINS 189213.13598878586_dp, & 412506.46573426365_dp, & 1004859.506854019_dp, & - 3757500.169762731_dp/) + 3757500.169762731_dp] ELSE IF (E_range < 10786426.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18118431919794764_dp, & 0.569409896731795_dp, & 1.0399575954447753_dp, & @@ -15919,9 +15916,9 @@ CONTAINS 501508.5608275271_dp, & 1228961.4319415095_dp, & 3359678.97519788_dp, & - 13198823.17240385_dp/) + 13198823.17240385_dp] ELSE IF (E_range < 72565710.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1860758083606257_dp, & 0.5863105731285033_dp, & 1.0762838189916888_dp, & @@ -15985,9 +15982,9 @@ CONTAINS 1439654.5954696422_dp, & 4195690.360297783_dp, & 14287820.480068853_dp, & - 67797329.79665162_dp/) + 67797329.79665162_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.18894944364096963_dp, & 0.5962994473518639_dp, & 1.0979679811546372_dp, & @@ -16051,9 +16048,9 @@ CONTAINS 2964362.2649549907_dp, & 10115616.277159294_dp, & 44251495.17814687_dp, & - 324622278.5292175_dp/) + 324622278.5292175_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_32 ! ************************************************************************************************** !> \brief ... @@ -16071,7 +16068,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 9649.0_dp) THEN E_ratio = 9649.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13207515772844727_dp, & 0.405991108403864_dp, & 0.7100791180957539_dp, & @@ -16139,9 +16136,9 @@ CONTAINS 2025.283801158086_dp, & 3491.3059333297665_dp, & 7474.317631875756_dp, & - 28531.55532533201_dp/) + 28531.55532533201_dp] ELSE IF (E_range < 15161.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13599210879419024_dp, & 0.41865733842571035_dp, & 0.734387462880487_dp, & @@ -16209,9 +16206,9 @@ CONTAINS 3017.958277485201_dp, & 5225.5076295652025_dp, & 11175.8295539236_dp, & - 42493.69287150706_dp/) + 42493.69287150706_dp] ELSE IF (E_range < 29986.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14157456993085618_dp, & 0.43680814305293825_dp, & 0.7695603918544728_dp, & @@ -16279,9 +16276,9 @@ CONTAINS 5497.180237430633_dp, & 9607.611108068526_dp, & 20546.39934902344_dp, & - 77652.80170951472_dp/) + 77652.80170951472_dp] ELSE IF (E_range < 49196.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14537972365704172_dp, & 0.44924937732846576_dp, & 0.7939069438582139_dp, & @@ -16349,9 +16346,9 @@ CONTAINS 8473.557800314775_dp, & 14944.543756287507_dp, & 32001.381350595566_dp, & - 120417.37064242488_dp/) + 120417.37064242488_dp] ELSE IF (E_range < 109833.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15111478683237578_dp, & 0.46811081455805653_dp, & 0.8311975658154092_dp, & @@ -16419,9 +16416,9 @@ CONTAINS 16981.74160635827_dp, & 30536.056841551963_dp, & 65732.37502124789_dp, & - 245660.71368655932_dp/) + 245660.71368655932_dp] ELSE IF (E_range < 276208.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15704353232796245_dp, & 0.4877544479660704_dp, & 0.8705376156017336_dp, & @@ -16489,9 +16486,9 @@ CONTAINS 37197.937321555175_dp, & 68943.1032010462_dp, & 150241.71258102785_dp, & - 557720.3208697784_dp/) + 557720.3208697784_dp] ELSE IF (E_range < 852991.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16336922513552726_dp, & 0.5088837963863347_dp, & 0.9134464251208241_dp, & @@ -16559,9 +16556,9 @@ CONTAINS 94285.04834791286_dp, & 183730.02847568074_dp, & 411506.64532360405_dp, & - 1520426.766419325_dp/) + 1520426.766419325_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.1835103101234003_dp, & 0.5774305061474206_dp, & 1.057140472868453_dp, & @@ -16629,8 +16626,8 @@ CONTAINS 6223266.011027118_dp, & 21236461.045184538_dp, & 92901077.9747871_dp, & - 681507114.6255051_dp/) + 681507114.6255051_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_34 END MODULE minimax_rpa diff --git a/src/mixed_cdft_methods.F b/src/mixed_cdft_methods.F index 74f7a80279..d5e1d7c4cc 100644 --- a/src/mixed_cdft_methods.F +++ b/src/mixed_cdft_methods.F @@ -122,6 +122,21 @@ MODULE mixed_cdft_methods CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mixed_cdft_methods' LOGICAL, PARAMETER, PRIVATE :: debug_this_module = .FALSE. + TYPE buffers_idx_irr + INTEGER :: imap(6) = 0 + INTEGER, DIMENSION(:), & + POINTER :: iv => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :) :: r3 => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :, :) :: r4 => null() + END TYPE buffers_idx_irr + + TYPE buffers_bi + LOGICAL, POINTER, DIMENSION(:) :: bv => NULL() + INTEGER, POINTER, DIMENSION(:) :: iv => NULL() + END TYPE buffers_bi + PUBLIC :: mixed_cdft_init, & mixed_cdft_build_weight, & mixed_cdft_calculate_coupling @@ -180,14 +195,16 @@ CONTAINS mixed_env%do_mixed_cdft = .TRUE. IF (mixed_env%do_mixed_cdft) THEN ! Sanity check - IF (nforce_eval < 2) & + IF (nforce_eval < 2) THEN CALL cp_abort(__LOCATION__, & "Mixed CDFT calculation requires at least 2 force_evals.") + END IF mapping_section => section_vals_get_subs_vals(mixed_section, "MAPPING") CALL section_vals_get(mapping_section, explicit=explicit) ! The sub_force_envs must share the same geometrical structure - IF (explicit) & + IF (explicit) THEN CPABORT("Please disable section &MAPPING for mixed CDFT calculations") + END IF CALL section_vals_val_get(mixed_section, "MIXED_CDFT%COUPLING", i_val=et_freq) IF (et_freq < 0) THEN mixed_env%do_mixed_et = .FALSE. @@ -244,9 +261,10 @@ CONTAINS IF (is_parallel) THEN ! Treat states in parallel, build weight function and gradients in parallel before SCF process mixed_cdft%run_type = mixed_cdft_parallel - IF (.NOT. nforce_eval == 2) & + IF (.NOT. nforce_eval == 2) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT calculation supports only 2 force_evals.") + END IF ELSE ! Treat states in parallel, but each states builds its own weight function and gradients mixed_cdft%run_type = mixed_cdft_parallel_nobuild @@ -299,8 +317,9 @@ CONTAINS END IF ! Inversion method CALL section_vals_val_get(mixed_section, "MIXED_CDFT%EPS_SVD", r_val=mixed_cdft%eps_svd) - IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) & + IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) THEN CPABORT("Illegal value for EPS_SVD. Value must be between 0.0 and 1.0.") + END IF ! MD related settings CALL force_env_get(force_env, root_section=root_section) md_section => section_vals_get_subs_vals(root_section, "MOTION%MD") @@ -446,6 +465,7 @@ CONTAINS INTEGER, DIMENSION(2, 3) :: bo INTEGER, DIMENSION(:), POINTER :: lb, sendbuffer_i, ub REAL(KIND=dp) :: t1, t2 + TYPE(buffers_idx_irr), DIMENSION(:), POINTER :: recvbuffer TYPE(cdft_control_type), POINTER :: cdft_control, cdft_control_target TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys_mix @@ -460,17 +480,6 @@ CONTAINS TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: force_env_section, print_section - TYPE buffers - INTEGER :: imap(6) - INTEGER, DIMENSION(:), & - POINTER :: iv => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :) :: r3 => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :, :) :: r4 => null() - END TYPE buffers - TYPE(buffers), DIMENSION(:), POINTER :: recvbuffer - NULLIFY (subsys_mix, force_env_qs, particles_mix, force_env_section, print_section, & mixed_env, mixed_cdft, pw_env, auxbas_pw_pool, mixed_auxbas_pw_pool, & qs_env, dft_control, sendbuffer_i, lb, ub, req_total, recvbuffer, & @@ -609,8 +618,9 @@ CONTAINS IF (mixed_cdft%dlb_control%recv_work_repl(1) .OR. mixed_cdft%dlb_control%recv_work_repl(2)) THEN DO j = 1, 2 recv_offset = 0 - IF (mixed_cdft%dlb_control%recv_work_repl(j)) & + IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN recv_offset = SUM(mixed_cdft%dlb_control%recv_info(j)%target_list(2, :)) + END IF IF (mixed_cdft%is_pencil) THEN recvbuffer(j)%imap(1) = recvbuffer(j)%imap(1) + recv_offset ELSE @@ -812,15 +822,17 @@ CONTAINS IF (ANY(mixed_cdft%dlb_control%recv_work_repl)) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%recv_work_repl) IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN - IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) THEN DEALLOCATE (mixed_cdft%dlb_control%recv_info(j)%target_list) + END IF DEALLOCATE (mixed_cdft%dlb_control%recvbuff(j)%buffs) END IF END DO DEALLOCATE (mixed_cdft%dlb_control%recv_info, mixed_cdft%dlb_control%recvbuff) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) THEN DEALLOCATE (mixed_cdft%dlb_control%target_list) + END IF DEALLOCATE (mixed_cdft%dlb_control%recv_work_repl) END IF DEALLOCATE (recvbuffer) @@ -982,8 +994,9 @@ CONTAINS END IF ! Atomic weight functions needed for CDFT charges IF (cdft_control_source%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control_target%charge)) & + IF (.NOT. ASSOCIATED(cdft_control_target%charge)) THEN ALLOCATE (cdft_control_target%charge(cdft_control_target%natoms)) + END IF DO iatom = 1, cdft_control_target%natoms CALL auxbas_pw_pool_target%create_pw(cdft_control_target%charge(iatom)) CALL pw_copy(cdft_control_source%charge(iatom), cdft_control_target%charge(iatom)) @@ -1232,12 +1245,14 @@ CONTAINS CALL cp_fm_get_info(mixed_mo_coeff(1, ispin), ncol_global=check_mo(1), nrow_global=check_ao(1)) DO iforce_eval = 2, nforce_eval CALL cp_fm_get_info(mixed_mo_coeff(iforce_eval, ispin), ncol_global=check_mo(2), nrow_global=check_ao(2)) - IF (check_ao(1) /= check_ao(2)) & + IF (check_ao(1) /= check_ao(2)) THEN CALL cp_abort(__LOCATION__, & "The number of atomic orbitals must be the same in every CDFT state.") - IF (check_mo(1) /= check_mo(2)) & + END IF + IF (check_mo(1) /= check_mo(2)) THEN CALL cp_abort(__LOCATION__, & "The number of molecular orbitals must be the same in every CDFT state.") + END IF END DO END DO ! Allocate work @@ -1266,13 +1281,15 @@ CONTAINS ALLOCATE (homo(nforce_eval, nspins)) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL section_vals_val_get(mixed_cdft_section, "EPS_OCCUPIED", r_val=eps_occupied) - IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) & + IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Keyword EPS_OCCUPIED only accepts values between 0.0 and 1.0") - IF (mixed_cdft%eps_svd == 0.0_dp) & + END IF + IF (mixed_cdft%eps_svd == 0.0_dp) THEN CALL cp_warn(__LOCATION__, & "The usage of SVD based matrix inversions with fractionally occupied "// & "orbitals is strongly recommended to screen nearly orthogonal states.") + END IF CALL section_vals_val_get(mixed_cdft_section, "SCALE_WITH_OCCUPATION_NUMBERS", l_val=should_scale) END IF ! Start the actual calculation @@ -1304,8 +1321,9 @@ CONTAINS nelectron_mismatch = .FALSE. nelectron_tot = SUM(mixed_cdft%occupations(1, ispin)%array(1:nmo)) DO istate = 2, nforce_eval - IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) & + IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) THEN nelectron_mismatch = .TRUE. + END IF END DO IF (ANY(homo(:, ispin) /= nmo)) THEN IF (ispin == 1) THEN @@ -1368,9 +1386,10 @@ CONTAINS name="MO_COEFF_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_" & //TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX") CALL cp_fm_to_fm(tmp2, mixed_mo_coeff(iforce_eval, ispin)) - IF (should_scale) & + IF (should_scale) THEN CALL cp_fm_column_scale(mixed_mo_coeff(iforce_eval, ispin), & mixed_cdft%occupations(iforce_eval, ispin)%array(1:nmo)) + END IF DEALLOCATE (mixed_cdft%occupations(iforce_eval, ispin)%array) END DO END IF @@ -1384,12 +1403,13 @@ CONTAINS CALL parallel_gemm('T', 'N', nmo, nmo, nao, 1.0_dp, & mixed_mo_coeff(jstate, ispin), & tmp2, 0.0_dp, mo_overlap(ipermutation)) - IF (print_mo) & + IF (print_mo) THEN CALL cp_fm_write_formatted(mo_overlap(ipermutation), mounit, & "# MO overlap matrix (step "//TRIM(ADJUSTL(cp_to_string(mixed_cdft%sim_step)))// & "): CDFT states "//TRIM(ADJUSTL(cp_to_string(istate)))//" and "// & TRIM(ADJUSTL(cp_to_string(jstate)))//" (spin "// & TRIM(ADJUSTL(cp_to_string(ispin)))//")") + END IF END DO END DO ! calculate the MO-representations of the restraint matrices of all CDFT states @@ -1489,9 +1509,10 @@ CONTAINS END SELECT END DO ! Compute density matrix difference P = P_j - P_i - IF (mixed_cdft%calculate_metric) & + IF (mixed_cdft%calculate_metric) THEN CALL dbcsr_add(density_matrix_diff(ipermutation, ispin)%matrix, & density_matrix(jstate, ispin)%matrix, -1.0_dp, 1.0_dp) + END IF ! CALL force_env%para_env%sum(a(ispin, :, ipermutation)) CALL force_env%para_env%sum(b(ispin, :, ipermutation)) @@ -1518,12 +1539,14 @@ CONTAINS DEALLOCATE (homo) DEALLOCATE (mixed_cdft%occupations) END IF - IF (print_mo) & + IF (print_mo) THEN CALL cp_print_key_finished_output(mounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) - IF (print_mo_eigval) & + END IF + IF (print_mo_eigval) THEN CALL cp_print_key_finished_output(moeigvalunit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) + END IF ! solve eigenstates for the projector matrix ALLOCATE (Wda(nvar, npermutations)) ALLOCATE (Sda(npermutations)) @@ -1649,9 +1672,10 @@ CONTAINS ! Compute coupling also with the wavefunction overlap method, see Migliore2009 ! Requires the unconstrained KS ground state wavefunction as input IF (mixed_cdft%wfn_overlap_method) THEN - IF (.NOT. uniform_occupation) & + IF (.NOT. uniform_occupation) THEN CALL cp_abort(__LOCATION__, & "Wavefunction overlap method supports only uniformly occupied MOs.") + END IF CALL mixed_cdft_wfn_overlap_method(force_env, mixed_cdft, ncol_mo, nrow_mo) END IF ! Release remaining work @@ -1958,9 +1982,10 @@ CONTAINS END DO DEALLOCATE (H_block, S_block, eigenvalues, blocks) END DO ! recursion - IF (iounit > 0) & + IF (iounit > 0) THEN WRITE (iounit, '(T3,A)') & - '------------------------------------------------------------------------------' + '------------------------------------------------------------------------------' + END IF CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -2001,8 +2026,9 @@ CONTAINS ALLOCATE (evals(ncol_mo(ispin))) DO ipermutation = 1, npermutations ! Take into account doubly occupied orbitals without LSD - IF (nspins == 1) & + IF (nspins == 1) THEN CALL dbcsr_scale(density_matrix_diff(ipermutation, 1)%matrix, alpha_scalar=0.5_dp) + END IF ! Diagonalize difference density matrix CALL cp_dbcsr_syevd(density_matrix_diff(ipermutation, ispin)%matrix, e_vectors, evals, & para_env=force_env%para_env, blacs_env=mixed_cdft%blacs_env) @@ -2093,31 +2119,35 @@ CONTAINS ALLOCATE (mo_set(ispin)%occupation_numbers(nmo)) END DO ! Read wfn file (note we assume that the basis set is the same) - IF (force_env%mixed_env%do_mixed_qmmm_cdft) & + IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN ! This really shouldnt be a problem? CALL cp_abort(__LOCATION__, & "QMMM + wavefunction overlap method not supported.") + END IF CALL force_env_get(force_env=force_env, subsys=subsys_mix) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL cp_subsys_get(subsys_mix, atomic_kind_set=atomic_kind_set, particle_set=particle_set) CPASSERT(ASSOCIATED(mixed_cdft%qs_kind_set)) - IF (force_env%para_env%is_source()) & + IF (force_env%para_env%is_source()) THEN CALL wfn_restart_file_name(file_name, exist, mixed_cdft_section, logger) + END IF CALL force_env%para_env%bcast(exist) CALL force_env%para_env%bcast(file_name) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CALL cp_abort(__LOCATION__, & "User requested to restart the wavefunction from the file named: "// & TRIM(file_name)//". This file does not exist. Please check the existence of"// & " the file or change properly the value of the keyword WFN_RESTART_FILE_NAME in"// & " section FORCE_EVAL\MIXED\MIXED_CDFT.") + END IF CALL read_mo_set_from_restart(mo_array=mo_set, qs_kind_set=mixed_cdft%qs_kind_set, particle_set=particle_set, & para_env=force_env%para_env, id_nr=0, multiplicity=mixed_cdft%multiplicity, & dft_section=mixed_cdft_section, natom_mismatch=natom_mismatch, & cdft=.TRUE.) - IF (natom_mismatch) & + IF (natom_mismatch) THEN CALL cp_abort(__LOCATION__, & "Restart wfn file has a wrong number of atoms") + END IF ! Orthonormalize wfn DO ispin = 1, nspins IF (mixed_cdft%has_unit_metric) THEN @@ -2350,10 +2380,11 @@ CONTAINS CASE (becke_cutoff_global) cdft_control%becke_control%cutoffs(:) = cdft_control%becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) THEN CALL cp_abort(__LOCATION__, & "Size of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does "// & "not match number of atomic kinds in the input coordinate file.") + END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -2379,20 +2410,23 @@ CONTAINS is_constraint = .FALSE. END IF in_memory = calculate_forces .AND. cdft_control%becke_control%in_memory - IF (in_memory .NEQV. calculate_forces) & + IF (in_memory .NEQV. calculate_forces) THEN CALL cp_abort(__LOCATION__, & "The flag BECKE_CONSTRAINT\IN_MEMORY must be activated "// & "for the calculation of mixed CDFT forces") + END IF IF (in_memory .OR. mixed_cdft%first_iteration) ALLOCATE (coefficients(natom)) DO i = 1, cdft_control%natoms catom(i) = cdft_control%atoms(i) IF (cdft_control%save_pot .OR. & cdft_control%becke_control%cavity_confine .OR. & cdft_control%becke_control%should_skip .OR. & - mixed_cdft%first_iteration) & + mixed_cdft%first_iteration) THEN is_constraint(catom(i)) = .TRUE. - IF (in_memory .OR. mixed_cdft%first_iteration) & + END IF + IF (in_memory .OR. mixed_cdft%first_iteration) THEN coefficients(catom(i)) = cdft_control%group(1)%coeff(i) + END IF END DO CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_pw_pool=auxbas_pw_pool) bo = auxbas_pw_pool%pw_grid%bounds_local @@ -2424,7 +2458,7 @@ CONTAINS pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + R12(iatom, jatom) = NORM2(dist_vec) R12(jatom, iatom) = R12(iatom, jatom) IF (build) THEN CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & @@ -2521,8 +2555,9 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=cdft_control%becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) & + IF (ASSOCIATED(radii_list)) THEN DEALLOCATE (radii_list) + END IF END IF NULLIFY (rs_cavity) CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_rs_grid=rs_cavity, & @@ -2622,9 +2657,10 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (force_env%para_env%is_source() .AND. unit_nr < 1) & + IF (force_env%para_env%is_source() .AND. unit_nr < 1) THEN CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") + END IF CALL cp_pw_to_cube(cdft_control%becke_control%cavity, & unit_nr, "CAVITY", particles=particles, & stride=stride, mpi_io=mpi_io) @@ -2633,17 +2669,20 @@ CONTAINS END IF END IF bo_conf = bo - IF (cdft_control%becke_control%cavity_confine) & + IF (cdft_control%becke_control%cavity_confine) THEN bo_conf(:, 3) = cdft_control%becke_control%confine_bounds + END IF ! Load balance - IF (mixed_cdft%dlb) & + IF (mixed_cdft%dlb) THEN CALL mixed_becke_constraint_dlb(force_env, mixed_cdft, my_work, & my_work_size, natom, bo, bo_conf) + END IF ! The bounds have been finalized => time to allocate storage for working matrices offset_dlb = 0 IF (mixed_cdft%dlb) THEN - IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) & + IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) THEN offset_dlb = SUM(mixed_cdft%dlb_control%target_list(2, :)) + END IF END IF IF (cdft_control%becke_control%cavity_confine) THEN ! Get rid of the zero part of the confinement cavity (cr3d -> real(:,:,:)) @@ -2733,6 +2772,7 @@ CONTAINS INTEGER, PARAMETER :: should_deallocate = 7000, & uninitialized = -7000 + CHARACTER(len=2) :: dummy INTEGER :: actually_sent, exhausted_work, handle, i, ind, iounit, ispecial, j, max_targets, & more_work, my_pos, my_special_work, my_target, no_overloaded, no_underloaded, nsend, & nsend_limit, nsend_max, offset, offset_proc, offset_special, send_total, tags(2) @@ -2744,19 +2784,13 @@ CONTAINS REAL(kind=dp) :: average_work, load_scale, & very_overloaded, work_factor REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: cavity + TYPE(buffers_bi), DIMENSION(:), POINTER :: recvbuffer, sbuff TYPE(cdft_control_type), POINTER :: cdft_control TYPE(cp_logger_type), POINTER :: logger TYPE(mp_request_type), DIMENSION(4) :: req TYPE(mp_request_type), DIMENSION(:), POINTER :: req_recv, req_total TYPE(section_vals_type), POINTER :: force_env_section, print_section - TYPE buffers - LOGICAL, POINTER, DIMENSION(:) :: bv - INTEGER, POINTER, DIMENSION(:) :: iv - END TYPE buffers - TYPE(buffers), POINTER, DIMENSION(:) :: recvbuffer, sbuff - CHARACTER(len=2) :: dummy - logger => cp_get_default_logger() CALL timeset(routineN, handle) mixed_cdft%dlb_control%recv_work = .FALSE. @@ -2821,8 +2855,9 @@ CONTAINS ! We store the unsorted expected work to refine the estimate on subsequent calls to this routine mixed_cdft%dlb_control%expected_work = expected_work ! Take into account the prediction error of the last step - IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN expected_work = expected_work - mixed_cdft%dlb_control%prediction_error + END IF ! average_work = REAL(SUM(expected_work), dp)/REAL(force_env%para_env%num_pe, dp) ALLOCATE (work_index(force_env%para_env%num_pe), & @@ -2924,8 +2959,9 @@ CONTAINS ! Prevent over redistribution: leave at least (1-work_factor)*nsend_limit slices to my_pos IF (nsend > NINT(work_factor*nsend_limit - send_total)) THEN nsend = NINT(work_factor*nsend_limit - send_total) - IF (debug_this_module) & + IF (debug_this_module) THEN should_warn(force_env%para_env%mepos + 1) = 1 + END IF END IF mixed_cdft%dlb_control%target_list(1, i) = work_index(my_target) - 1 ! This is the actual processor rank IF (mixed_cdft%is_special) THEN @@ -2968,9 +3004,10 @@ CONTAINS EXIT END IF i = i + 1 - IF (i > max_targets) & + IF (i > max_targets) THEN CALL cp_abort(__LOCATION__, & "Load balancing error: increase max_targets") + END IF END DO IF (.NOT. mixed_cdft%is_special) THEN CALL reallocate(mixed_cdft%dlb_control%target_list, 1, 3, 1, i) @@ -2993,11 +3030,12 @@ CONTAINS CALL force_env%para_env%sum(targets) IF (debug_this_module) THEN CALL force_env%para_env%sum(should_warn) - IF (ANY(should_warn == 1)) & + IF (ANY(should_warn == 1)) THEN CALL cp_warn(__LOCATION__, & "MIXED_CDFT DLB: Attempted to redistribute more array"// & " slices than actually available. Leaving a fraction of the total"// & " slices on the overloaded processor. Perhaps you have set LOAD_SCALE too high?") + END IF DEALLOCATE (should_warn) END IF ! check that there is one-to-one mapping between over- and underloaded processors @@ -3236,11 +3274,12 @@ CONTAINS CALL force_env%para_env%irecv(msgout=recvbuffer(i)%bv, & source=mixed_cdft%source_list(i), & request=req_total(i), tag=1) - IF (mixed_cdft%is_special) & + IF (mixed_cdft%is_special) THEN CALL force_env%para_env%irecv(msgout=recvbuffer(i)%iv, & source=mixed_cdft%source_list(i), & request=req_total(i + SIZE(mixed_cdft%source_list)), & tag=2) + END IF END DO DO i = 1, my_special_work DO j = 1, SIZE(mixed_cdft%dest_list) @@ -3258,8 +3297,9 @@ CONTAINS IF (touched(j)) THEN nsend = 0 DO ispecial = 1, SIZE(mixed_cdft%dlb_control%target_list, 2) - IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) & + IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) THEN nsend = nsend + 1 + END IF END DO sbuff(j)%iv(3) = nsend nsend_proc(j) = nsend @@ -3271,10 +3311,11 @@ CONTAINS CALL force_env%para_env%isend(msgin=sbuff(j)%bv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind), tag=1) - IF (mixed_cdft%is_special) & + IF (mixed_cdft%is_special) THEN CALL force_env%para_env%isend(msgin=sbuff(j)%iv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind + 2*SIZE(mixed_cdft%dest_list)), tag=2) + END IF END DO END DO CALL mp_waitall(req_total) @@ -3349,8 +3390,9 @@ CONTAINS IF (mixed_cdft%dlb_control%send_work) THEN ind = COUNT(mixed_cdft%dlb_control%recv_work_repl) + 1 DO i = 1, 2 - IF (i == 2) & + IF (i == 2) THEN mixed_cdft%dlb_control%target_list(3, :) = mixed_cdft%dlb_control%target_list(3, :) + 3*max_targets + END IF CALL force_env%para_env%isend(msgin=mixed_cdft%dlb_control%target_list, & dest=mixed_cdft%dest_list(i), & request=req_total(ind)) @@ -3846,8 +3888,9 @@ CONTAINS END DO END IF ! Poll to prevent starvation - IF (ASSOCIATED(req_recv)) & + IF (ASSOCIATED(req_recv)) THEN completed_recv = mp_testall(req_recv) + END IF ! DO i = LBOUND(weight, 3), UBOUND(weight, 3) IF (cdft_control%becke_control%cavity_confine) THEN @@ -3885,7 +3928,7 @@ CONTAINS IF (distances(iatom) == 0.0_dp) THEN r = position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) distance_vecs(:, iatom) = dist_vec distances(iatom) = dist1 ELSE @@ -3898,7 +3941,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -3914,7 +3957,7 @@ CONTAINS IF (distances(jatom) == 0.0_dp) THEN r1 = position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) distance_vecs(:, jatom) = dist_vec distances(jatom) = dist2 ELSE @@ -3927,7 +3970,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) END IF IF (in_memory) THEN IF (store_vectors) THEN @@ -3990,27 +4033,30 @@ CONTAINS IF (in_memory) THEN dP_i_dRi(:, iatom) = cell_functions(iatom)*dP_i_dRi(:, iatom) d_sum_Pm_dR(:, iatom) = d_sum_Pm_dR(:, iatom) + dP_i_dRi(:, iatom) - IF (is_constraint(iatom)) & + IF (is_constraint(iatom)) THEN d_sum_const_dR(:, iatom) = d_sum_const_dR(:, iatom) + dP_i_dRi(:, iatom)* & coefficients(iatom) + END IF DO jatom = 1, natom IF (jatom /= iatom) THEN IF (jatom < iatom) THEN IF (.NOT. skip_me(jatom)) THEN dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) & + IF (is_constraint(iatom)) THEN d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + & dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) + END IF CYCLE END IF END IF dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) & + IF (is_constraint(iatom)) THEN d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) + END IF END IF END DO END IF @@ -4050,8 +4096,9 @@ CONTAINS END IF END DO END IF - IF (ABS(sum_cell_f_all) > 0.000001) & + IF (ABS(sum_cell_f_all) > 0.000001) THEN weight(k, j, i) = sum_cell_f_constr/sum_cell_f_all + END IF END DO ! i END DO ! j END DO ! k @@ -4114,20 +4161,26 @@ CONTAINS END DO CALL mp_waitall(req_total) DEALLOCATE (req_total) - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%gradients) + END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) + END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4136,20 +4189,26 @@ CONTAINS IF (should_communicate) THEN CALL mp_waitall(req_send) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%gradients) + END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) + END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4162,8 +4221,9 @@ CONTAINS IF (mixed_cdft%dlb) THEN CALL force_env%para_env%sum(work) CALL force_env%para_env%sum(work_dlb) - IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & + IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN ALLOCATE (mixed_cdft%dlb_control%prediction_error(force_env%para_env%num_pe)) + END IF mixed_cdft%dlb_control%prediction_error = mixed_cdft%dlb_control%expected_work - work IF (debug_this_module .AND. iounit > 0) THEN DO i = 1, SIZE(work, 1) @@ -4174,8 +4234,9 @@ CONTAINS DEALLOCATE (work, work_dlb, mixed_cdft%dlb_control%expected_work) END IF NULLIFY (gradients, weight, cavity) - IF (ALLOCATED(coefficients)) & + IF (ALLOCATED(coefficients)) THEN DEALLOCATE (coefficients) + END IF IF (in_memory) THEN DEALLOCATE (ds_dR_j) DEALLOCATE (ds_dR_i) @@ -4189,25 +4250,30 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) & + IF (ALLOCATED(is_constraint)) THEN DEALLOCATE (is_constraint) + END IF DEALLOCATE (catom) DEALLOCATE (R12) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) - IF (ALLOCATED(completed)) & + IF (ALLOCATED(completed)) THEN DEALLOCATE (completed) - IF (ASSOCIATED(nsent)) & + END IF + IF (ASSOCIATED(nsent)) THEN DEALLOCATE (nsent) + END IF IF (store_vectors) THEN DEALLOCATE (distances) DEALLOCATE (distance_vecs) DEALLOCATE (position_vecs) END IF - IF (ASSOCIATED(req_send)) & + IF (ASSOCIATED(req_send)) THEN DEALLOCATE (req_send) - IF (ASSOCIATED(req_recv)) & + END IF + IF (ASSOCIATED(req_recv)) THEN DEALLOCATE (req_recv) + END IF CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/mixed_cdft_types.F b/src/mixed_cdft_types.F index 5a05d67a39..1fa57726d9 100644 --- a/src/mixed_cdft_types.F +++ b/src/mixed_cdft_types.F @@ -310,41 +310,55 @@ CONTAINS INTEGER :: i, j CALL pw_env_release(cdft_control%pw_env) - IF (ASSOCIATED(cdft_control%dest_list)) & + IF (ASSOCIATED(cdft_control%dest_list)) THEN DEALLOCATE (cdft_control%dest_list) - IF (ASSOCIATED(cdft_control%dest_list_save)) & + END IF + IF (ASSOCIATED(cdft_control%dest_list_save)) THEN DEALLOCATE (cdft_control%dest_list_save) - IF (ASSOCIATED(cdft_control%dest_list_bo)) & + END IF + IF (ASSOCIATED(cdft_control%dest_list_bo)) THEN DEALLOCATE (cdft_control%dest_list_bo) - IF (ASSOCIATED(cdft_control%dest_bo_save)) & + END IF + IF (ASSOCIATED(cdft_control%dest_bo_save)) THEN DEALLOCATE (cdft_control%dest_bo_save) - IF (ASSOCIATED(cdft_control%source_list)) & + END IF + IF (ASSOCIATED(cdft_control%source_list)) THEN DEALLOCATE (cdft_control%source_list) - IF (ASSOCIATED(cdft_control%source_list_save)) & + END IF + IF (ASSOCIATED(cdft_control%source_list_save)) THEN DEALLOCATE (cdft_control%source_list_save) - IF (ASSOCIATED(cdft_control%source_list_bo)) & + END IF + IF (ASSOCIATED(cdft_control%source_list_bo)) THEN DEALLOCATE (cdft_control%source_list_bo) - IF (ASSOCIATED(cdft_control%source_bo_save)) & + END IF + IF (ASSOCIATED(cdft_control%source_bo_save)) THEN DEALLOCATE (cdft_control%source_bo_save) - IF (ASSOCIATED(cdft_control%recv_bo)) & + END IF + IF (ASSOCIATED(cdft_control%recv_bo)) THEN DEALLOCATE (cdft_control%recv_bo) - IF (ASSOCIATED(cdft_control%weight)) & + END IF + IF (ASSOCIATED(cdft_control%weight)) THEN DEALLOCATE (cdft_control%weight) - IF (ASSOCIATED(cdft_control%cavity)) & + END IF + IF (ASSOCIATED(cdft_control%cavity)) THEN DEALLOCATE (cdft_control%cavity) - IF (ALLOCATED(cdft_control%constraint_type)) & + END IF + IF (ALLOCATED(cdft_control%constraint_type)) THEN DEALLOCATE (cdft_control%constraint_type) + END IF IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations, 1) DO j = 1, SIZE(cdft_control%occupations, 2) - IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) & + IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) THEN DEALLOCATE (cdft_control%occupations(i, j)%array) + END IF END DO END DO DEALLOCATE (cdft_control%occupations) END IF - IF (ASSOCIATED(cdft_control%dlb_control)) & + IF (ASSOCIATED(cdft_control%dlb_control)) THEN CALL mixed_cdft_dlb_release(cdft_control%dlb_control) + END IF IF (ASSOCIATED(cdft_control%sendbuff)) THEN DO i = 1, SIZE(cdft_control%sendbuff) CALL mixed_cdft_buffers_release(cdft_control%sendbuff(i)) @@ -355,10 +369,12 @@ CONTAINS CALL cdft_control_release(cdft_control%cdft_control) DEALLOCATE (cdft_control%cdft_control) END IF - IF (ASSOCIATED(cdft_control%blacs_env)) & + IF (ASSOCIATED(cdft_control%blacs_env)) THEN CALL cp_blacs_env_release(cdft_control%blacs_env) - IF (ASSOCIATED(cdft_control%qs_kind_set)) & + END IF + IF (ASSOCIATED(cdft_control%qs_kind_set)) THEN CALL deallocate_qs_kind_set(cdft_control%qs_kind_set) + END IF IF (ASSOCIATED(cdft_control%sub_logger)) THEN DO i = 1, SIZE(cdft_control%sub_logger) CALL cp_logger_release(cdft_control%sub_logger(i)%p) @@ -381,8 +397,9 @@ CONTAINS INTEGER :: i - IF (ASSOCIATED(dlb_control%recv_work_repl)) & + IF (ASSOCIATED(dlb_control%recv_work_repl)) THEN DEALLOCATE (dlb_control%recv_work_repl) + END IF IF (ASSOCIATED(dlb_control%sendbuff)) THEN DO i = 1, SIZE(dlb_control%sendbuff) CALL mixed_cdft_buffers_release(dlb_control%sendbuff(i)) @@ -397,27 +414,36 @@ CONTAINS END IF IF (ASSOCIATED(dlb_control%recv_info)) THEN DO i = 1, SIZE(dlb_control%recv_info) - IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) & + IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) THEN DEALLOCATE (dlb_control%recv_info(i)%matrix_info) - IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) & + END IF + IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) THEN DEALLOCATE (dlb_control%recv_info(i)%target_list) + END IF END DO DEALLOCATE (dlb_control%recv_info) END IF - IF (ASSOCIATED(dlb_control%bo)) & + IF (ASSOCIATED(dlb_control%bo)) THEN DEALLOCATE (dlb_control%bo) - IF (ASSOCIATED(dlb_control%expected_work)) & + END IF + IF (ASSOCIATED(dlb_control%expected_work)) THEN DEALLOCATE (dlb_control%expected_work) - IF (ASSOCIATED(dlb_control%prediction_error)) & + END IF + IF (ASSOCIATED(dlb_control%prediction_error)) THEN DEALLOCATE (dlb_control%prediction_error) - IF (ASSOCIATED(dlb_control%target_list)) & + END IF + IF (ASSOCIATED(dlb_control%target_list)) THEN DEALLOCATE (dlb_control%target_list) - IF (ASSOCIATED(dlb_control%cavity)) & + END IF + IF (ASSOCIATED(dlb_control%cavity)) THEN DEALLOCATE (dlb_control%cavity) - IF (ASSOCIATED(dlb_control%weight)) & + END IF + IF (ASSOCIATED(dlb_control%weight)) THEN DEALLOCATE (dlb_control%weight) - IF (ASSOCIATED(dlb_control%gradients)) & + END IF + IF (ASSOCIATED(dlb_control%gradients)) THEN DEALLOCATE (dlb_control%gradients) + END IF DEALLOCATE (dlb_control) END SUBROUTINE mixed_cdft_dlb_release @@ -430,12 +456,15 @@ CONTAINS SUBROUTINE mixed_cdft_buffers_release(buffer) TYPE(buffers) :: buffer - IF (ASSOCIATED(buffer%cavity)) & + IF (ASSOCIATED(buffer%cavity)) THEN DEALLOCATE (buffer%cavity) - IF (ASSOCIATED(buffer%weight)) & + END IF + IF (ASSOCIATED(buffer%weight)) THEN DEALLOCATE (buffer%weight) - IF (ASSOCIATED(buffer%gradients)) & + END IF + IF (ASSOCIATED(buffer%gradients)) THEN DEALLOCATE (buffer%gradients) + END IF END SUBROUTINE mixed_cdft_buffers_release diff --git a/src/mixed_cdft_utils.F b/src/mixed_cdft_utils.F index 89fcedfe23..cba3f032cf 100644 --- a/src/mixed_cdft_utils.F +++ b/src/mixed_cdft_utils.F @@ -209,10 +209,11 @@ CONTAINS CALL force_env_get(force_env_qs, qs_env=qs_env) END IF CALL get_qs_env(qs_env, pw_env=pw_env, dft_control=dft_control) - IF (.NOT. dft_control%qs_control%cdft) & + IF (.NOT. dft_control%qs_control%cdft) THEN CALL cp_abort(__LOCATION__, & "A mixed CDFT simulation with multiple force_evals was requested, "// & "but CDFT constraints were not active in the QS section of all force_evals!") + END IF cdft_control => dft_control%qs_control%cdft_control CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) settings%bo = auxbas_pw_pool%pw_grid%bounds_local @@ -227,13 +228,15 @@ CONTAINS settings%rs_dims(:, iforce_eval) = auxbas_pw_pool%pw_grid%para%group%num_pe_cart IF (auxbas_pw_pool%pw_grid%grid_span == HALFSPACE) settings%odd(iforce_eval) = 1 ! Becke constraint atoms/coeffs - IF (cdft_control%natoms > SIZE(settings%atoms, 1)) & + IF (cdft_control%natoms > SIZE(settings%atoms, 1)) THEN CALL cp_abort(__LOCATION__, & "More CDFT constraint atoms than defined in mixed section. "// & "Use default values for MIXED\MAPPING.") + END IF settings%atoms(1:cdft_control%natoms, iforce_eval) = cdft_control%atoms - IF (mixed_cdft%run_type == mixed_cdft_parallel) & + IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN settings%coeffs(1:cdft_control%natoms, iforce_eval) = cdft_control%group(1)%coeff + END IF ! Integer type settings IF (cdft_control%type == outer_scf_becke_constraint) THEN settings%si(1, iforce_eval) = cdft_control%becke_control%cutoff_type @@ -274,41 +277,46 @@ CONTAINS IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN nkinds = SIZE(cdft_control%becke_control%cutoffs_tmp) - IF (nkinds > settings%max_nkinds) & + IF (nkinds > settings%max_nkinds) THEN CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ELEMENT_CUTOFF. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") + END IF settings%cutoffs(1:nkinds, iforce_eval) = cdft_control%becke_control%cutoffs_tmp(:) END IF IF (cdft_control%becke_control%adjust) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF nkinds = SIZE(cdft_control%becke_control%radii_tmp) - IF (nkinds > settings%max_nkinds) & + IF (nkinds > settings%max_nkinds) THEN CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ATOMIC_RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") + END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%becke_control%radii_tmp(:) END IF END IF IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN IF (ASSOCIATED(cdft_control%hirshfeld_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT&RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF nkinds = SIZE(cdft_control%hirshfeld_control%radii) - IF (nkinds > settings%max_nkinds) & + IF (nkinds > settings%max_nkinds) THEN CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in HIRSHFELD_CONSTRAINT&RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") + END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%hirshfeld_control%radii(:) END IF END IF @@ -333,15 +341,17 @@ CONTAINS is_match = is_match .AND. (settings%rs_dims(2, 1) == settings%rs_dims(2, iforce_eval)) is_match = is_match .AND. (settings%odd(1) == settings%odd(iforce_eval)) END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &MGRID settings of the CDFT force_evals.") + END IF IF (settings%spherical(1) == 1) settings%is_spherical = .TRUE. IF (settings%odd(1) == 1) settings%is_odd = .TRUE. ! Make sure CDFT settings are consistent CALL force_env%para_env%sum(settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) & + IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN CALL force_env%para_env%sum(settings%coeffs) + END IF settings%ncdft = 0 DO i = 1, SIZE(settings%atoms, 1) DO iforce_eval = 2, nforce_eval @@ -352,12 +362,13 @@ CONTAINS END DO IF (settings%atoms(i, 1) /= 0) settings%ncdft = settings%ncdft + 1 END DO - IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) & + IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT section of the CDFT force_evals. "// & "Parallel mode mixed CDFT requires identical constraint definitions in both CDFT states. "// & "Switch to serial mode or disable keyword PARALLEL_BUILD if you "// & "want to use nonidentical constraint definitions.") + END IF CALL force_env%para_env%sum(settings%si) CALL force_env%para_env%sum(settings%sr) DO i = 1, SIZE(settings%sb, 1) @@ -377,13 +388,15 @@ CONTAINS IF (settings%sr(i, 1) /= settings%sr(i, iforce_eval)) is_match = .FALSE. END DO END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT settings of the CDFT force_evals.") + END IF ! Some CDFT features are currently disabled for mixed calculations: check that these features were not requested - IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) & + IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT load balancing requires Gaussian cavity confinement.") + END IF ! Check for identical constraints in case of run type serial/parallel_nobuild IF (mixed_cdft%run_type /= mixed_cdft_parallel) THEN ! Get array sizes @@ -409,8 +422,9 @@ CONTAINS ! Sum up array sizes and check consistency CALL force_env%para_env%sum(array_sizes) IF (ANY(array_sizes(:, :, 1) /= array_sizes(1, 1, 1)) .OR. & - ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) & + ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) THEN mixed_cdft%identical_constraints = .FALSE. + END IF ! Check constraint definitions IF (mixed_cdft%identical_constraints) THEN ! Prepare temporary storage @@ -454,14 +468,17 @@ CONTAINS END DO DO iforce_eval = 2, nforce_eval DO iatom = 1, SIZE(atoms(1, i)%array) - IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) & + IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) THEN mixed_cdft%identical_constraints = .FALSE. - IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) & + END IF + IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) THEN mixed_cdft%identical_constraints = .FALSE. + END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO - IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) & + IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) THEN mixed_cdft%identical_constraints = .FALSE. + END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO IF (.NOT. mixed_cdft%identical_constraints) EXIT @@ -509,12 +526,15 @@ CONTAINS END DO IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (.NOT. cdft_control%atomic_charges) DEALLOCATE (cdft_control%atoms) - IF (cdft_control%becke_control%cavity_confine) & + IF (cdft_control%becke_control%cavity_confine) THEN CALL release_hirshfeld_type(cdft_control%becke_control%cavity_env) - IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) & + END IF + IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN DEALLOCATE (cdft_control%becke_control%cutoffs_tmp) - IF (cdft_control%becke_control%adjust) & + END IF + IF (cdft_control%becke_control%adjust) THEN DEALLOCATE (cdft_control%becke_control%radii_tmp) + END IF END IF END IF END DO @@ -549,16 +569,19 @@ CONTAINS settings%radius = settings%sr(5, 1) ! Transfer settings only needed if the constraint should be built in parallel IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN - IF (settings%sb(6, 1)) & + IF (settings%sb(6, 1)) THEN CALL cp_abort(__LOCATION__, & "Calculation of atomic Becke charges not supported with parallel mode mixed CDFT") - IF (mixed_cdft%nconstraint /= 1) & + END IF + IF (mixed_cdft%nconstraint /= 1) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not yet support multiple constraints.") + END IF - IF (settings%si(5, 1) /= outer_scf_becke_constraint) & + IF (settings%si(5, 1) /= outer_scf_becke_constraint) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not support Hirshfeld constraints.") + END IF ALLOCATE (mixed_cdft%cdft_control) CALL cdft_control_create(mixed_cdft%cdft_control) @@ -593,10 +616,11 @@ CONTAINS IF (settings%cutoffs(i, 1) /= settings%cutoffs(i, 2)) is_match = .FALSE. IF (settings%cutoffs(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ELEMENT_CUTOFF settings of the two force_evals.") + END IF ALLOCATE (cdft_control%becke_control%cutoffs_tmp(nkinds)) cdft_control%becke_control%cutoffs_tmp = settings%cutoffs(1:nkinds, 1) END IF @@ -607,10 +631,11 @@ CONTAINS IF (settings%radii(i, 1) /= settings%radii(i, 2)) is_match = .FALSE. IF (settings%radii(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ATOMIC_RADII settings of the two force_evals.") + END IF ALLOCATE (cdft_control%becke_control%radii(nkinds)) cdft_control%becke_control%radii = settings%radii(1:nkinds, 1) END IF @@ -706,8 +731,9 @@ CONTAINS mixed_cdft%is_special = .FALSE. ! Flag to control the last mapping ! With xc smoothing, the grid is always (ncpu/2,1) distributed ! and correct behavior cannot be guaranteed for ncpu/2 > nx, so we abort... - IF (ncpu/2 > settings%npts(1, 1)) & + IF (ncpu/2 > settings%npts(1, 1)) THEN CPABORT("ncpu/2 => nx: decrease ncpu or disable xc_smoothing") + END IF ! ALLOCATE (mixed_rs_dims(2)) IF (settings%rs_dims(2, 1) /= 1) mixed_cdft%is_pencil = .TRUE. @@ -740,11 +766,12 @@ CONTAINS ELSE IF (.NOT. pw_grid%para%group%num_pe_cart(2) == 1) is_match = .FALSE. END IF - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Unable to create a suitable grid distribution "// & "for mixed CDFT calculations. Try decreasing the total number "// & "of processors or disabling xc_smoothing.") + END IF DEALLOCATE (mixed_rs_dims) ! Create the pool bo_mixed = pw_grid%bounds_local @@ -1010,8 +1037,9 @@ CONTAINS DEALLOCATE (settings%rs_dims) DEALLOCATE (settings%odd) DEALLOCATE (settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) & + IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN DEALLOCATE (settings%coeffs) + END IF DEALLOCATE (settings%cutoffs) DEALLOCATE (settings%radii) DEALLOCATE (settings%si) @@ -1088,15 +1116,17 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) CPASSERT(ASSOCIATED(dft_control)) nspins = dft_control%nspins - IF (force_env_qs%para_env%is_source()) & + IF (force_env_qs%para_env%is_source()) THEN has_occupation_numbers(iforce_eval) = ALLOCATED(dft_control%qs_control%cdft_control%occupations) + END IF END DO CALL force_env%para_env%sum(has_occupation_numbers(1)) DO iforce_eval = 2, nforce_eval CALL force_env%para_env%sum(has_occupation_numbers(iforce_eval)) - IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) & + IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) THEN CALL cp_abort(__LOCATION__, & "Mixing of uniform and non-uniform occupations is not allowed.") + END IF END DO uniform_occupation = .NOT. has_occupation_numbers(1) DEALLOCATE (has_occupation_numbers) @@ -1154,8 +1184,9 @@ CONTAINS ! Valgrind 3.12/gfortran 4.8.4 oddly complains here (unconditional jump) ! if mixed_cdft%calculate_metric = .FALSE. and the need to null the array ! is queried with IF (mixed_cdft%calculate_metric) & - IF (.NOT. uniform_occupation) & + IF (.NOT. uniform_occupation) THEN NULLIFY (occno_tmp(iforce_eval, ispin)%array) + END IF END DO IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! From this point onward, we access data local to the sub_force_envs @@ -1228,8 +1259,9 @@ CONTAINS ! Occupation numbers IF (.NOT. uniform_occupation) THEN DO ispin = 1, nspins - IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) & + IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) THEN CPABORT("Array dimensions dont match.") + END IF IF (force_env_qs%para_env%is_source()) THEN ALLOCATE (occno_tmp(iforce_eval, ispin)%array(ncol_mo(ispin))) occno_tmp(iforce_eval, ispin)%array = dft_control%qs_control%cdft_control%occupations(ispin)%array @@ -1248,8 +1280,9 @@ CONTAINS ! We use this method for the serial case (mixed_cdft%run_type == mixed_cdft_serial) as well to move the arrays to the ! correct blacs_env, which is impossible using a simple copy of the arrays ALLOCATE (mixed_wmat_tmp(nforce_eval, nvar)) - IF (mixed_cdft%calculate_metric) & + IF (mixed_cdft%calculate_metric) THEN ALLOCATE (mixed_matrix_p_tmp(nforce_eval, nspins)) + END IF DO iforce_eval = 1, nforce_eval ! MO coefficients DO ispin = 1, nspins @@ -1381,8 +1414,9 @@ CONTAINS WRITE (iounit, '(T3,A,I3,A,I3,A)') '###### CDFT states I =', istate, ' and J = ', jstate, ' ######' WRITE (iounit, '(T3,A)') REPEAT('#', 44) DO ivar = 1, nvar - IF (ivar > 1) & + IF (ivar > 1) THEN WRITE (iounit, '(A)') '' + END IF WRITE (iounit, '(T3,A,T60,(3X,I18))') 'Atomic group:', ivar WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Strength of constraint I:', mixed_cdft%results%strength(ivar, istate) @@ -1491,8 +1525,9 @@ CONTAINS INTEGER :: kcol, kpermutation, krow, npermutations npermutations = n*(n - 1)/2 ! Size of upper triangular part - IF (ipermutation > npermutations) & + IF (ipermutation > npermutations) THEN CPABORT("Permutation index out of bounds") + END IF kpermutation = 0 DO krow = 1, n DO kcol = krow + 1, n @@ -1610,18 +1645,20 @@ CONTAINS block_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%BLOCK_DIAGONALIZE") CALL section_vals_get(block_section, explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CALL cp_abort(__LOCATION__, & "Block diagonalization of CDFT Hamiltonian was requested, but the "// & "corresponding input section is missing!") + END IF CALL section_vals_val_get(block_section, "BLOCK", n_rep_val=nblk) ALLOCATE (blocks(nblk)) DO i = 1, nblk NULLIFY (blocks(i)%array) CALL section_vals_val_get(block_section, "BLOCK", i_rep_val=i, i_vals=tmplist) - IF (SIZE(tmplist) < 1) & + IF (SIZE(tmplist) < 1) THEN CPABORT("Each BLOCK must contain at least 1 state.") + END IF ALLOCATE (blocks(i)%array(SIZE(tmplist))) blocks(i)%array(:) = tmplist(:) END DO @@ -1630,8 +1667,9 @@ CONTAINS ! Check that the requested states exist DO i = 1, nblk DO j = 1, SIZE(blocks(i)%array) - IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) & + IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) THEN CPABORT("Requested state does not exist.") + END IF END DO END DO ! Check for duplicates @@ -1663,9 +1701,10 @@ CONTAINS ELSE nrecursion = nblk/2 END IF - IF (nrecursion /= 1 .AND. .NOT. ignore_excited) & + IF (nrecursion /= 1 .AND. .NOT. ignore_excited) THEN CALL cp_abort(__LOCATION__, & "Keyword IGNORE_EXCITED must be active for recursive diagonalization.") + END IF END IF END SUBROUTINE mixed_cdft_read_block_diag @@ -1709,10 +1748,11 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_block(i)%array >= 0.0_dp)) & + IF (ANY(H_block(i)%array >= 0.0_dp)) THEN CALL cp_abort(__LOCATION__, & "At least one of the interaction energies within block "//TRIM(ADJUSTL(cp_to_string(i)))// & " is repulsive.") + END IF END DO END SUBROUTINE mixed_cdft_get_blocks @@ -1847,10 +1887,11 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_offdiag >= 0.0_dp)) & + IF (ANY(H_offdiag >= 0.0_dp)) THEN CALL cp_abort(__LOCATION__, & "At least one of the interaction energies between blocks "//TRIM(ADJUSTL(cp_to_string(i)))// & " and "//TRIM(ADJUSTL(cp_to_string(j)))//" is repulsive.") + END IF ! Now transform: C_i^T * H * C_j H_offdiag(:, :) = MATMUL(H_offdiag, H_block(j)%array) H_offdiag(:, :) = MATMUL(TRANSPOSE(H_block(i)%array), H_offdiag) diff --git a/src/mixed_environment_types.F b/src/mixed_environment_types.F index 0cb02288c5..267d51da65 100644 --- a/src/mixed_environment_types.F +++ b/src/mixed_environment_types.F @@ -321,10 +321,12 @@ CONTAINS IF (ASSOCIATED(mixed_env%group_distribution)) THEN DEALLOCATE (mixed_env%group_distribution) END IF - IF (ASSOCIATED(mixed_env%cdft_control)) & + IF (ASSOCIATED(mixed_env%cdft_control)) THEN CALL mixed_cdft_type_release(mixed_env%cdft_control) - IF (ASSOCIATED(mixed_env%strength)) & + END IF + IF (ASSOCIATED(mixed_env%strength)) THEN DEALLOCATE (mixed_env%strength) + END IF END SUBROUTINE mixed_env_release diff --git a/src/mode_selective.F b/src/mode_selective.F index 753dfb8bae..ce371bdc26 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -330,8 +330,9 @@ CONTAINS END IF END IF END IF - IF (ms_vib%select_id == 0) & + IF (ms_vib%select_id == 0) THEN CPABORT("no frequency, range or involved atoms specified ") + END IF ionode = para_env%is_source() SELECT CASE (guess) CASE (ms_guess_atomic) @@ -374,7 +375,7 @@ CONTAINS ms_vib%b_vec(jj, i) = ABS(globenv%gaussian_rng_stream%next()) END DO END DO - norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + norm = NORM2(ms_vib%b_vec(:, i)) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO @@ -386,7 +387,7 @@ CONTAINS ms_vib%b_vec(:, j) = & ms_vib%b_vec(:, j) - DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, i))*ms_vib%b_vec(:, i) ms_vib%b_vec(:, j) = & - ms_vib%b_vec(:, j)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, j))) + ms_vib%b_vec(:, j)/NORM2(ms_vib%b_vec(:, j)) END IF END DO END DO @@ -424,8 +425,8 @@ CONTAINS CALL para_env%bcast(ms_vib%b_vec) CALL para_env%bcast(ms_vib%delta_vec) DO i = 1, nrep - ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) - ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) + ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) + ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) END DO CALL timestop(handle) @@ -517,7 +518,7 @@ CONTAINS CALL sort(tmp, ncoord, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = ms_vib%hes_bfgs(:, tmplist(i)) - norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + norm = NORM2(ms_vib%b_vec(:, i)) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, SIZE(ms_vib%b_vec, 1) @@ -597,7 +598,7 @@ CONTAINS END IF IF (ionode) THEN statint = 0 - READ (UNIT=hesunit, IOSTAT=stat) ms_vib%b_mat + READ (UNIT=hesunit) ms_vib%b_mat READ (UNIT=hesunit, IOSTAT=stat) ms_vib%s_mat IF (calc_intens) READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & @@ -630,7 +631,7 @@ CONTAINS DO j = 1, ms_vib%mat_size ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i) + approx_H(j, ind(i))*ms_vib%b_mat(:, j) END DO - ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/NORM2(ms_vib%b_vec(:, i)) END DO DEALLOCATE (ms_vib%s_mat) @@ -700,8 +701,8 @@ CONTAINS unit_number=iw) END IF info = "" - READ (iw, *, IOSTAT=stat) info - READ (iw, *, IOSTAT=stat) info + READ (iw, *) info + READ (iw, *) info istat = 0 nvibs = 0 reading_vib = .FALSE. @@ -784,7 +785,7 @@ CONTAINS CALL sort(tmp, nvibs, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = modes(:, tmplist(i))*mass(:) - norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + norm = NORM2(ms_vib%b_vec(:, i)) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, nrep @@ -920,8 +921,8 @@ CONTAINS END DO DO i = 1, nrep - ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) - ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) + ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) + ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) END DO converged = .FALSE. IF (MAXVAL(criteria(1, :)) <= ms_vib%eps(1) .AND. MAXVAL(criteria(2, :)) & @@ -946,14 +947,14 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) + tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) END DO IF (calc_intens) THEN DO i = 1, ms_vib%mat_size DO j = 1, ms_vib%mat_size tmp_s(:, i) = tmp_s(:, i) + ms_vib%dip_deriv(:, j)*approx_H(j, i) END DO - IF (calc_intens) intensities(i) = SQRT(DOT_PRODUCT(tmp_s(:, i), tmp_s(:, i))) + IF (calc_intens) intensities(i) = NORM2(tmp_s(:, i)) END DO END IF IF (calc_intens) THEN @@ -1041,7 +1042,7 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) + tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) END DO tmp = 0._dp DO i = 1, ms_vib%mat_size @@ -1078,12 +1079,12 @@ CONTAINS IF (PRESENT(criteria)) THEN DO i = 1, nrep criteria(1, i) = MAXVAL((residuum(:, i))) - criteria(2, i) = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) + criteria(2, i) = NORM2(residuum(:, i)) END DO END IF DO i = 1, nrep - norm = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) + norm = NORM2(residuum(:, i)) residuum(:, i) = residuum(:, i)/norm END DO @@ -1091,13 +1092,13 @@ CONTAINS DO j = 1, nrep DO i = 1, ms_vib%mat_size residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), ms_vib%b_mat(:, i))*ms_vib%b_mat(:, i) - residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) + residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) END DO IF (nrep > 1) THEN DO i = 1, nrep IF (i /= j) THEN residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), residuum(:, i))*residuum(:, i) - residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) + residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) END IF END DO END IF @@ -1139,7 +1140,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), OPTIONAL :: intensities TYPE(cp_logger_type), POINTER :: logger - INTEGER :: i, j, msunit, stat + INTEGER :: i, j, msunit REAL(KIND=dp) :: crit_a, crit_b, fint, gintval REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: residuum TYPE(section_vals_type), POINTER :: ms_vib_section @@ -1172,7 +1173,7 @@ CONTAINS residuum(:) = residuum(:) - DOT_PRODUCT(residuum(:), ms_vib%b_mat(:, j))*ms_vib%b_mat(:, j) END DO crit_a = MAXVAL(residuum(:)) - crit_b = SQRT(DOT_PRODUCT(residuum, residuum)) + crit_b = NORM2(residuum) IF (PRESENT(intensities)) THEN gintval = fint*intensities(i)**2 IF (crit_a <= ms_vib%eps(1) .AND. crit_b <= ms_vib%eps(2)) THEN @@ -1200,10 +1201,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv + WRITE (UNIT=msunit) ms_vib%mat_size + WRITE (UNIT=msunit) ms_vib%b_mat + WRITE (UNIT=msunit) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & @@ -1217,10 +1218,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv + WRITE (UNIT=msunit) ms_vib%mat_size + WRITE (UNIT=msunit) ms_vib%b_mat + WRITE (UNIT=msunit) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & diff --git a/src/mol_force.F b/src/mol_force.F index fecd8c1f7a..8788183cdc 100644 --- a/src/mol_force.F +++ b/src/mol_force.F @@ -53,17 +53,17 @@ CONTAINS SELECT CASE (id_type) CASE (do_ff_quartic) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 energy = (f12*k(1) + (f13*k(2) + f14*k(3)*disp)*disp)*disp*disp fscalar = ((k(1) + (k(2) + k(3)*disp)*disp)*disp)/dij CASE (do_ff_morse) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 energy = k(1)*((1 - EXP(-k(2)*disp))**2 - 1) fscalar = 2*k(1)*k(2)*EXP(-k(2)*disp)*(1 - EXP(-k(2)*disp))/dij CASE (do_ff_cubic) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 energy = k(1)*disp**2*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) fscalar = (2.0_dp*k(1)*disp*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) + & @@ -76,7 +76,7 @@ CONTAINS energy = f14*k(1)*disp*disp fscalar = k(1)*disp CASE (do_ff_charmm, do_ff_amber) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -86,7 +86,7 @@ CONTAINS fscalar = 2.0_dp*k(1)*disp/dij END IF CASE (do_ff_harmonic, do_ff_g87) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -96,7 +96,7 @@ CONTAINS fscalar = k(1)*disp/dij END IF CASE (do_ff_fues) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = r0/dij energy = f12*k(1)*r0*r0*(1.0_dp + disp*(disp - 2.0_dp)) fscalar = k(1)*r0*disp*disp*(1.0_dp - disp)/dij @@ -507,7 +507,7 @@ CONTAINS b = DOT_PRODUCT(t41, t41) - D !inverse norm of t41 - is41 = 1.0_dp/SQRT(DOT_PRODUCT(t41, t41)) + is41 = 1.0_dp/NORM2(t41) cosphi = SQRT(b)*is41 IF (cosphi > 1.0_dp) cosphi = 1.0_dp diff --git a/src/molecular_dipoles.F b/src/molecular_dipoles.F index 90a768e113..eb53cae2bb 100644 --- a/src/molecular_dipoles.F +++ b/src/molecular_dipoles.F @@ -76,7 +76,7 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dipole_set REAL(KIND=dp), DIMENSION(3) :: ci, gvec, rcc REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point - REAL(KIND=dp), DIMENSION(:, :), POINTER :: center(:, :) + REAL(KIND=dp), DIMENSION(:, :), POINTER :: center TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(cell_type), POINTER :: cell TYPE(cp_logger_type), POINTER :: logger @@ -84,7 +84,7 @@ CONTAINS TYPE(distribution_1d_type), POINTER :: local_molecules TYPE(molecule_kind_type), POINTER :: molecule_kind TYPE(mp_para_env_type), POINTER :: para_env - TYPE(particle_type), POINTER :: particle_set(:) + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set logger => cp_get_default_logger() @@ -224,7 +224,7 @@ CONTAINS dipole_set(:, :) = dipole_set(:, :)*debye ! Debye DO I = 1, SIZE(dipole_set, 2) WRITE (UNIT=iounit, FMT='(T8,I6,T21,5F12.6)') I, charge_set(I), dipole_set(1:3, I), & - SQRT(DOT_PRODUCT(dipole_set(1:3, I), dipole_set(1:3, I))) + NORM2(dipole_set(1:3, I)) END DO WRITE (UNIT=iounit, FMT="(T2,A,T61,E20.12)") ' DIPOLE : CheckSum =', SUM(dipole_set) END IF diff --git a/src/molsym.F b/src/molsym.F index 466f6762b2..3d44715eae 100644 --- a/src/molsym.F +++ b/src/molsym.F @@ -1210,10 +1210,12 @@ CONTAINS IF (.NOT. sym%linear) THEN DO icn = 2, sym%ncn DO isec = 1, sym%nsec(icn) - IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) & + IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) THEN CALL addses(icn, sym%sec(:, isec, icn), sym) - IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) & + END IF + IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) THEN CALL addses(2*icn, sym%sec(:, isec, icn), sym) + END IF END DO END DO END IF diff --git a/src/motion/bfgs_optimizer.F b/src/motion/bfgs_optimizer.F index ef6ae345ea..54e89bffa8 100644 --- a/src/motion/bfgs_optimizer.F +++ b/src/motion/bfgs_optimizer.F @@ -194,13 +194,14 @@ CONTAINS ndf = SIZE(x0) nfree = gopt_env%nfree - IF (ndf > 3000) & + IF (ndf > 3000) THEN CALL cp_warn(__LOCATION__, & "The dimension of the Hessian matrix ("// & TRIM(ADJUSTL(cp_to_string(ndf)))//") is greater than 3000. "// & "The diagonalisation of the full Hessian matrix needed for BFGS "// & "is computationally expensive. You should consider to use the linear "// & "scaling variant L-BFGS instead.") + END IF ! Initialize hessian (hes = unitary matrix or model hessian ) CALL cp_blacs_env_create(blacs_env, para_env, globenv%blacs_grid_layout, & @@ -239,8 +240,10 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) - IF (output_unit > 0) WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, using unity as model Hessian." + IF (output_unit > 0) THEN + WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, using unity as model Hessian." + END IF ELSE DO its = 1, SIZE(eigval) IF (eigval(its) < 0.1_dp) eigval(its) = 0.1_dp @@ -373,8 +376,10 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN - IF (output_unit > 0) WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, resetting Hessian to unity." + IF (output_unit > 0) THEN + WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, resetting Hessian to unity." + END IF CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) CALL cp_fm_to_fm(hess_mat, hess_tmp) CALL choose_eigv_solver(hess_tmp, eigvec_mat, eigval) @@ -1087,7 +1092,7 @@ CONTAINS !pbc for a distance vector r_ij(j, i, :) = pbc(particles%els(i)%r, particles%els(j)%r, cell) r_ij(i, j, :) = -r_ij(j, i, :) - d_ij(j, i) = SQRT(DOT_PRODUCT(r_ij(j, i, :), r_ij(j, i, :))) + d_ij(j, i) = NORM2(r_ij(j, i, :)) d_ij(i, j) = d_ij(j, i) rho_ij(j, i) = EXP(alpha(jat_row, iat_row)*(r0(jat_row, iat_row)**2 - d_ij(j, i)**2)) rho_ij(i, j) = rho_ij(j, i) @@ -1104,25 +1109,28 @@ CONTAINS iat_row = (jglobal + 2)/3 IF (iat_row > natom) CYCLE IF (iat_row /= iat_col) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) & + IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) + END IF ELSE local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) END IF IF (iat_col /= iat_row) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) & + IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN local_data(j, i) = local_data(j, i) - & dist_second_deriv(r_ij(iat_col, iat_row, :), & iind, jind, d_ij(iat_row, iat_col), rho_ij(iat_row, iat_col)) + END IF ELSE DO k = 1, natom IF (k == iat_col) CYCLE - IF (d_ij(iat_row, k) < 6.0_dp) & + IF (d_ij(iat_row, k) < 6.0_dp) THEN local_data(j, i) = local_data(j, i) + & dist_second_deriv(r_ij(iat_col, k, :), & iind, jind, d_ij(iat_row, k), rho_ij(iat_row, k)) + END IF END DO END IF IF (fixed(jind, iat_row) < 0.5_dp .OR. fixed(iind, iat_col) < 0.5_dp) THEN diff --git a/src/motion/cell_opt_utils.F b/src/motion/cell_opt_utils.F index ed25d9fb70..48b29fb216 100644 --- a/src/motion/cell_opt_utils.F +++ b/src/motion/cell_opt_utils.F @@ -184,8 +184,9 @@ CONTAINS pres_ext = 0.0_dp CALL section_vals_val_get(geo_section, "EXTERNAL_PRESSURE", r_vals=pvals) check = (SIZE(pvals) == 1) .OR. (SIZE(pvals) == 9) - IF (.NOT. check) & + IF (.NOT. check) THEN CPABORT("EXTERNAL_PRESSURE can have 1 or 9 components only!") + END IF IF (SIZE(pvals) == 9) THEN ind = 0 @@ -425,7 +426,8 @@ CONTAINS gamma = angle(cell%hmat(:, 1), cell%hmat(:, 2)) cosg = COS(gamma) sing = SIN(gamma) - ! Here, g is the average derivative of the cell vector length ab_length, and deriv_gamma is the derivative of the angle gamma + ! Here, g is the average derivative of the cell vector length ab_length, + ! and deriv_gamma is the derivative of the angle gamma g = 0.5_dp*(gradient(1) + cosg*gradient(2) + sing*gradient(3)) deriv_gamma = (gradient(3)*cosg - gradient(2)*sing)/b_length gradient(1) = g diff --git a/src/motion/cg_utils.F b/src/motion/cg_utils.F index a2beb77590..017c5041f2 100644 --- a/src/motion/cg_utils.F +++ b/src/motion/cg_utils.F @@ -163,7 +163,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: gradient2, ls_norm CALL timeset(routineN, handle) - norm_ls_vec = SQRT(DOT_PRODUCT(ls_vec, ls_vec)) + norm_ls_vec = NORM2(ls_vec) my_use_only_grad = .FALSE. IF (PRESENT(use_only_grad)) my_use_only_grad = use_only_grad IF (norm_ls_vec /= 0.0_dp) THEN @@ -260,7 +260,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: tls_norm CALL timeset(routineN, handle) - norm_tls_vec = SQRT(DOT_PRODUCT(tls_vec, tls_vec)) + norm_tls_vec = NORM2(tls_vec) IF (norm_tls_vec /= 0.0_dp) THEN ALLOCATE (tls_norm(SIZE(tls_vec))) @@ -379,7 +379,7 @@ CONTAINS dimer_env%rot%g0 work = -2.0_dp*(work - dimer_env%rot%g0) work = work - DOT_PRODUCT(work, dimer_env%nvec)*dimer_env%nvec - opt_energy = SQRT(DOT_PRODUCT(work, work)) + opt_energy = NORM2(work) DEALLOCATE (work) END IF dimer_env%rot%angle2 = angle @@ -434,7 +434,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) + xicom = xicom/NORM2(xicom) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -520,7 +520,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) + xicom = xicom/NORM2(xicom) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -866,9 +866,10 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(/,T2,A)") REPEAT("*", 79) WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,I7,T78,A)") & "***", "BRENT - NUMBER OF ENERGY EVALUATIONS : ", loc_iter, "***" - IF (iter == itmax + 1) & + IF (iter == itmax + 1) THEN WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,T78,A)") & - "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" + "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" + END IF WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", 79) END IF CPASSERT(iter /= itmax + 1) @@ -1079,7 +1080,7 @@ CONTAINS g = h h = -xi*dimer_env%cg_rot%norm_theta + gam*dimer_env%cg_rot%norm_h*dimer_env%cg_rot%nvec_old h = h - DOT_PRODUCT(h, dimer_env%nvec)*dimer_env%nvec - norm_h = SQRT(DOT_PRODUCT(h, h)) + norm_h = NORM2(h) IF (norm_h < EPSILON(0.0_dp)) THEN h = 0.0_dp ELSE diff --git a/src/motion/cp_lbfgs.F b/src/motion/cp_lbfgs.F index 8d245095e5..99ff16249c 100644 --- a/src/motion/cp_lbfgs.F +++ b/src/motion/cp_lbfgs.F @@ -1460,8 +1460,9 @@ CONTAINS dtm = -f1/f2 tsum = zero nseg = 1 - IF (iprint >= 99) & + IF (iprint >= 99) THEN WRITE (wunit, 1011) nbreak + END IF nleft = nbreak iter = 1 @@ -3429,24 +3430,30 @@ CONTAINS ! algorithm enters the second stage. ftest = finit + stp*gtest - IF (stage == 1 .AND. f <= ftest .AND. g >= zero) & + IF (stage == 1 .AND. f <= ftest .AND. g >= zero) THEN stage = 2 + END IF ! Test for warnings. - IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) & + IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) THEN task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' - IF (brackt .AND. stmax - stmin <= xtol*stmax) & + END IF + IF (brackt .AND. stmax - stmin <= xtol*stmax) THEN task = 'WARNING: XTOL TEST SATISFIED' - IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) & + END IF + IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) THEN task = 'WARNING: STP = STPMAX' - IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) & + END IF + IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) THEN task = 'WARNING: STP = STPMIN' + END IF ! Test for convergence. - IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) & + IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) THEN task = 'CONVERGENCE' + END IF ! Test for termination. diff --git a/src/motion/cp_lbfgs_geo.F b/src/motion/cp_lbfgs_geo.F index ef4abb4441..83701fccc3 100644 --- a/src/motion/cp_lbfgs_geo.F +++ b/src/motion/cp_lbfgs_geo.F @@ -114,8 +114,9 @@ CONTAINS END IF ! Stop if not implemented - IF (gopt_env%type_id == default_ts_method_id) & + IF (gopt_env%type_id == default_ts_method_id) THEN CPABORT("BFGS method not yet working with DIMER") + END IF ALLOCATE (optimizer) CALL cp_opt_gopt_create(optimizer, para_env=para_env, obj_funct=gopt_env, & diff --git a/src/motion/cp_lbfgs_optimizer_gopt.F b/src/motion/cp_lbfgs_optimizer_gopt.F index 92fcd24488..decb8d6681 100644 --- a/src/motion/cp_lbfgs_optimizer_gopt.F +++ b/src/motion/cp_lbfgs_optimizer_gopt.F @@ -234,10 +234,12 @@ CONTAINS optimizer%gradient = 0.0_dp optimizer%dsave = 0.0_dp optimizer%work_array = 0.0_dp - IF (PRESENT(wanted_relative_f_delta)) & + IF (PRESENT(wanted_relative_f_delta)) THEN optimizer%wanted_relative_f_delta = wanted_relative_f_delta - IF (PRESENT(wanted_projected_gradient)) & + END IF + IF (PRESENT(wanted_projected_gradient)) THEN optimizer%wanted_projected_gradient = wanted_projected_gradient + END IF optimizer%kind_of_bound = 0 IF (PRESENT(kind_of_bound)) optimizer%kind_of_bound = kind_of_bound IF (PRESENT(lower_bound)) optimizer%lower_bound = lower_bound @@ -375,10 +377,12 @@ CONTAINS IF (PRESENT(obj_funct)) obj_funct = optimizer%obj_funct IF (PRESENT(m)) m = optimizer%m IF (PRESENT(max_f_per_iter)) max_f_per_iter = optimizer%max_f_per_iter - IF (PRESENT(wanted_projected_gradient)) & + IF (PRESENT(wanted_projected_gradient)) THEN wanted_projected_gradient = optimizer%wanted_projected_gradient - IF (PRESENT(wanted_relative_f_delta)) & + END IF + IF (PRESENT(wanted_relative_f_delta)) THEN wanted_relative_f_delta = optimizer%wanted_relative_f_delta + END IF IF (PRESENT(print_every)) print_every = optimizer%print_every IF (PRESENT(x)) x => optimizer%x IF (PRESENT(n_var)) n_var = SIZE(x) @@ -389,15 +393,17 @@ CONTAINS IF (PRESENT(last_f)) last_f = optimizer%last_f IF (PRESENT(f)) f = optimizer%f IF (PRESENT(at_end)) at_end = optimizer%status > 3 - IF (PRESENT(actual_projected_gradient)) & + IF (PRESENT(actual_projected_gradient)) THEN actual_projected_gradient = optimizer%projected_gradient + END IF IF (optimizer%master == optimizer%para_env%mepos) THEN IF (optimizer%isave(30) > 1 .AND. (optimizer%task(1:5) == "NEW_X" .OR. & optimizer%task(1:4) == "STOP" .AND. optimizer%task(7:9) == "CPU")) THEN ! nr iterations >1 .and. dsave contains the wanted data IF (PRESENT(last_f)) last_f = optimizer%dsave(2) - IF (PRESENT(actual_projected_gradient)) & + IF (PRESENT(actual_projected_gradient)) THEN actual_projected_gradient = optimizer%dsave(13) + END IF ELSE CPASSERT(.NOT. PRESENT(last_f)) CPASSERT(.NOT. PRESENT(actual_projected_gradient)) @@ -698,8 +704,7 @@ CONTAINS DEALLOCATE (xold) IF (PRESENT(f)) f = optimizer%f IF (PRESENT(last_f)) last_f = optimizer%last_f - IF (PRESENT(projected_gradient)) & - projected_gradient = optimizer%projected_gradient + IF (PRESENT(projected_gradient)) projected_gradient = optimizer%projected_gradient IF (PRESENT(n_iter)) n_iter = optimizer%n_iter CALL timestop(handle) @@ -735,8 +740,7 @@ CONTAINS IF (PRESENT(n_iter)) n_iter = NINT(results(1)) IF (PRESENT(f)) f = results(2) IF (PRESENT(last_f)) last_f = results(3) - IF (PRESENT(projected_gradient)) & - projected_gradient = results(4) + IF (PRESENT(projected_gradient)) projected_gradient = results(4) END SUBROUTINE cp_opt_gopt_bcast_res diff --git a/src/motion/dimer_methods.F b/src/motion/dimer_methods.F index c3b1e2c5cf..63b2ca9eba 100644 --- a/src/motion/dimer_methods.F +++ b/src/motion/dimer_methods.F @@ -197,10 +197,10 @@ CONTAINS END IF IF (debug_this_module .AND. (iw > 0)) THEN WRITE (iw, *) "final gradient:", gradient - WRITE (iw, '(A,F20.10)') "norm gradient:", SQRT(DOT_PRODUCT(gradient, gradient)) + WRITE (iw, '(A,F20.10)') "norm gradient:", NORM2(gradient) END IF IF (.NOT. gopt_env%do_line_search) THEN - f = SQRT(DOT_PRODUCT(gradient, gradient)) + f = NORM2(gradient) ELSE f = -DOT_PRODUCT(gradient, dimer_env%tsl%tls_vec) END IF @@ -237,7 +237,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) natoms = particles%n_els - norm_gradient_old = SQRT(DOT_PRODUCT(gradient, gradient)) + norm_gradient_old = NORM2(gradient) IF (norm_gradient_old > 0.0_dp) THEN IF (natoms > 1) THEN CALL rot_ana(particles%els, mat, dof, print_section, keep_rotations=.FALSE., & diff --git a/src/motion/dimer_types.F b/src/motion/dimer_types.F index 840a3acc4a..608a867801 100644 --- a/src/motion/dimer_types.F +++ b/src/motion/dimer_types.F @@ -193,8 +193,9 @@ CONTAINS CALL dimer_fixed_atom_control(dimer_env%nvec, subsys, unit_nr) ! Normalize dimer vector norm = SQRT(SUM(dimer_env%nvec**2)) - IF (norm <= EPSILON(0.0_dp)) & + IF (norm <= EPSILON(0.0_dp)) THEN CPABORT("The norm of the dimer vector is 0! Calculation cannot proceed further.") + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, "(T2,A,T9,A,T69,F12.6)") & "DIMER|", "Norm of dimer vector to be normalized by rescaling", norm @@ -414,8 +415,9 @@ CONTAINS CALL globenv%gaussian_rng_stream%fill(dimer_env%nvec) CASE (dimer_init_molden) CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CPABORT("INITIALIZATION_METHOD MOLDEN requires VIB_MOLDEN_NAME") + END IF CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", c_val=molden_name) IF (unit > 0) THEN WRITE (unit, "(/,T2,A,T9,A)") & @@ -441,11 +443,12 @@ CONTAINS CALL parser_get_next_line(parser, 1) READ (UNIT=parser%input_line, FMT=*, IOSTAT=ierr) & array_r(3*j - 2), array_r(3*j - 1), array_r(3*j) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CALL cp_abort(__LOCATION__, & "Error while reading MOLDEN file: cannot parse the line "// & TRIM(ADJUSTL(cp_to_string(j)))//" of <"//vib_name//"> "// & "for components of the normal mode") + END IF END DO dimer_env%nvec(:) = dimer_env%nvec(:) + array_r(:)*vib_wt_list(i) END DO Vib_modes diff --git a/src/motion/dimer_utils.F b/src/motion/dimer_utils.F index d5006aa274..9ecc75dfa1 100644 --- a/src/motion/dimer_utils.F +++ b/src/motion/dimer_utils.F @@ -120,7 +120,7 @@ CONTAINS REAL(KIND=dp), INTENT(OUT) :: norm gradient = gradient - DOT_PRODUCT(gradient, dimer_env%nvec)*dimer_env%nvec - norm = SQRT(DOT_PRODUCT(gradient, gradient)) + norm = NORM2(gradient) IF (norm < EPSILON(0.0_dp)) THEN ! This means that NVEC is totally aligned with minimum curvature mode gradient = 0.0_dp diff --git a/src/motion/dumpdcd.F b/src/motion/dumpdcd.F index 8117ddef9f..9db62af431 100644 --- a/src/motion/dumpdcd.F +++ b/src/motion/dumpdcd.F @@ -31,7 +31,8 @@ PROGRAM dumpdcd ! The output in DCD format is in binary format. ! The input coordinates should be in Angstrom. Velocities and forces are expected to be in atomic units. -! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding +! variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -618,9 +619,9 @@ PROGRAM dumpdcd gamma_dcd = gamma END IF ! Overwrite cell information from DCD header - a = SQRT(DOT_PRODUCT(hmat(1:3, 1), hmat(1:3, 1))) - b = SQRT(DOT_PRODUCT(hmat(1:3, 2), hmat(1:3, 2))) - c = SQRT(DOT_PRODUCT(hmat(1:3, 3), hmat(1:3, 3))) + a = NORM2(hmat(1:3, 1)) + b = NORM2(hmat(1:3, 2)) + c = NORM2(hmat(1:3, 3)) ! Lattice vectors from DCD headers of VEL files are atomic units, but the CP2K cell file is in Angstrom IF (unit_string == "[a.u.]") THEN a = a/angstrom @@ -1014,8 +1015,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = SQRT(DOT_PRODUCT(a, a)) - length_of_b = SQRT(DOT_PRODUCT(b, b)) + length_of_a = NORM2(a) + length_of_b = NORM2(b) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion/free_energy_methods.F b/src/motion/free_energy_methods.F index dc4f234ead..1af3620815 100644 --- a/src/motion/free_energy_methods.F +++ b/src/motion/free_energy_methods.F @@ -136,10 +136,11 @@ CONTAINS CASE (do_fe_ac) CALL initf(2) ! Alchemical Changes - IF (.NOT. ASSOCIATED(force_env%mixed_env)) & + IF (.NOT. ASSOCIATED(force_env%mixed_env)) THEN CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' Free Energy calculations require the definition of a mixed env!') + END IF my_par => force_env%mixed_env%par my_val => force_env%mixed_env%val dx = force_env%mixed_env%dx diff --git a/src/motion/geo_opt.F b/src/motion/geo_opt.F index af142047e5..0a1aec4be0 100644 --- a/src/motion/geo_opt.F +++ b/src/motion/geo_opt.F @@ -103,8 +103,9 @@ CONTAINS ! Reset counter for next iteration, unless rm_restart_info==.FALSE. my_rm_restart_info = .TRUE. IF (PRESENT(rm_restart_info)) my_rm_restart_info = rm_restart_info - IF (my_rm_restart_info) & + IF (my_rm_restart_info) THEN CALL section_vals_val_set(geo_section, "STEP_START_VAL", i_val=0) + END IF DEALLOCATE (x0) CALL gopt_f_release(gopt_env) diff --git a/src/motion/glbopt_callback.F b/src/motion/glbopt_callback.F index 5c65c43d7c..a42d2bfc12 100644 --- a/src/motion/glbopt_callback.F +++ b/src/motion/glbopt_callback.F @@ -69,18 +69,21 @@ CONTAINS ! check if we passed a minimum passed_minimum = .TRUE. DO i = 1, mdctrl_data%bump_steps_upwards - IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) & + IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) THEN passed_minimum = .FALSE. + END IF END DO DO i = mdctrl_data%bump_steps_upwards + 1, mdctrl_data%bump_steps_upwards + mdctrl_data%bump_steps_downwards - IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) & + IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) THEN passed_minimum = .FALSE. + END IF END DO ! count the passed bumps and stop md_run when md_bumps_max is reached. - IF (passed_minimum) & + IF (passed_minimum) THEN mdctrl_data%md_bump_counter = mdctrl_data%md_bump_counter + 1 + END IF IF (mdctrl_data%md_bump_counter >= mdctrl_data%md_bumps_max) THEN should_stop = .TRUE. diff --git a/src/motion/gopt_f77_methods.F b/src/motion/gopt_f77_methods.F index 8d5b6727fd..e7483d533b 100644 --- a/src/motion/gopt_f77_methods.F +++ b/src/motion/gopt_f77_methods.F @@ -171,12 +171,13 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & CALL unpack_subsys_particles(subsys=subsys, r=x) CASE (default_cell_method_id) ! Check for VIRIAL - IF (.NOT. virial%pv_availability) & + IF (.NOT. virial%pv_availability) THEN CALL cp_abort(__LOCATION__, & "For a cell optimization task with CELL_OPT/TYPE "// & "DIRECT_CELL_OPT, the FORCE_EVAL/STRESS_TENSOR "// & "keyword MUST be defined in the input file for the "// & "evaluation of the stress tensor, but none is found!") + END IF IF (gopt_env%cell_env%keep_volume) THEN nparticle = force_env_get_nparticle(gopt_env%force_env) idg = 3*nparticle @@ -228,8 +229,9 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & ! some callers expect pres_int to be available on all ranks. Also, here master is not necessarily a single rank. ! Assume at least master==0 CALL para_env%bcast(gopt_env%cell_env%pres_int, 0) - IF (gopt_env%cell_env%constraint_id /= fix_none) & + IF (gopt_env%cell_env%constraint_id /= fix_none) THEN CALL para_env%bcast(gopt_env%cell_env%pres_constr, 0) + END IF END IF END BLOCK CASE (default_shellcore_method_id) diff --git a/src/motion/gopt_f_methods.F b/src/motion/gopt_f_methods.F index 65682a68ca..bf385d8762 100644 --- a/src/motion/gopt_f_methods.F +++ b/src/motion/gopt_f_methods.F @@ -112,10 +112,12 @@ CONTAINS CASE (default_minimization_method_id, default_ts_method_id) CALL force_env_get(gopt_env%force_env, subsys=subsys) ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) & + IF (gopt_env%force_env%in_use == use_qmmm) THEN CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - IF (gopt_env%force_env%in_use == use_qmmmx) & + END IF + IF (gopt_env%force_env%in_use == use_qmmmx) THEN CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) + END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -124,10 +126,12 @@ CONTAINS ! Store reference cell gopt_env%h_ref = cell%hmat ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) & + IF (gopt_env%force_env%in_use == use_qmmm) THEN CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - IF (gopt_env%force_env%in_use == use_qmmmx) & + END IF + IF (gopt_env%force_env%in_use == use_qmmmx) THEN CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) + END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle + 6)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -670,7 +674,7 @@ CONTAINS IF (PRESENT(pres_diff_constr) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff_constr) < ABS(pres_tol) - ELSEIF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN + ELSE IF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff) < ABS(pres_tol) END IF @@ -896,8 +900,9 @@ CONTAINS CALL write_structure_data(particle_set, cell, motion_section) CALL write_restart(force_env=force_env, root_section=root_section) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,T20,' Reevaluating energy at the minimum')") + END IF CALL cp_eval_at(gopt_env, x0, f=etot, master=master, final_evaluation=.TRUE., & para_env=para_env) diff --git a/src/motion/helium_common.F b/src/motion/helium_common.F index d979d518fd..f37fda09d0 100644 --- a/src/motion/helium_common.F +++ b/src/motion/helium_common.F @@ -94,21 +94,21 @@ CONTAINS rx = r(1)*cell_size_inv IF (rx > 0.5_dp) THEN rx = rx - REAL(INT(rx + 0.5_dp), dp) - ELSEIF (rx < -0.5_dp) THEN + ELSE IF (rx < -0.5_dp) THEN rx = rx - REAL(INT(rx - 0.5_dp), dp) END IF ry = r(2)*cell_size_inv IF (ry > 0.5_dp) THEN ry = ry - REAL(INT(ry + 0.5_dp), dp) - ELSEIF (ry < -0.5_dp) THEN + ELSE IF (ry < -0.5_dp) THEN ry = ry - REAL(INT(ry - 0.5_dp), dp) END IF rz = r(3)*cell_size_inv IF (rz > 0.5_dp) THEN rz = rz - REAL(INT(rz + 0.5_dp), dp) - ELSEIF (rz < -0.5_dp) THEN + ELSE IF (rz < -0.5_dp) THEN rz = rz - REAL(INT(rz - 0.5_dp), dp) END IF diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index d987d46f6f..2544940b5e 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -765,7 +765,7 @@ CONTAINS DO i_com = 1, helium%nnp%n_committee !loop over committee members ! Predict energy CALL nnp_predict(helium%nnp%arc(ind), helium%nnp, i_com) - helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) ! + helium%nnp%atom_energies(ind) + helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) !Gradients IF (PRESENT(force)) THEN @@ -1068,7 +1068,7 @@ CONTAINS p = np db = db - 1 END DO - ELSEIF (delta_bead < 0) THEN + ELSE IF (delta_bead < 0) THEN bead = ref_bead p = part db = delta_bead diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index 3733c09a9d..252ada46cc 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -661,7 +661,7 @@ CONTAINS IF (x >= 0.01_dp) EXIT END DO z = -LOG(0.01_dp) - y = LOG(x)/z + 1.0_dp; + y = LOG(x)/z + 1.0_dp cyclen = INT(helium%maxcycle*y) + 1 IF (cyclen /= helium%m_value) EXIT END DO diff --git a/src/motion/helium_types.F b/src/motion/helium_types.F index 835b11bcec..aeed271a61 100644 --- a/src/motion/helium_types.F +++ b/src/motion/helium_types.F @@ -121,7 +121,8 @@ MODULE helium_types REAL(KIND=dp), DIMENSION(3) :: origin = 0.0_dp!< origin of the cell (first voxel position) REAL(KIND=dp) :: droplet_radius = 0.0_dp !< radius of the droplet - REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of periodic cell (if periodic) or COM of helium + REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of + ! periodic cell (if periodic) or COM of helium INTEGER :: sampling_method = helium_sampling_ceperley ! worm sampling parameters @@ -151,7 +152,8 @@ MODULE helium_types LOGICAL :: worm_is_closed = .FALSE.!before isector=1 -> open; isector=0 -> closed INTEGER :: iter_norot = 0!< number of iterations to try for a given imaginary time slice rotation (num inner MC loop iters) - INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) (num outer MC loop iters) + INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) + ! (num outer MC loop iters) ! INTEGER :: maxcycle = 0!< maximum cyclic permutation change to attempt INTEGER :: m_dist_type = 0!< distribution from which the cycle length m is sampled @@ -186,7 +188,8 @@ MODULE helium_types INTEGER(KIND=int_8) :: accepts = 0_int_8!< number of accepted new configurations ! REAL(KIND=dp), DIMENSION(:, :), POINTER :: tmatrix => NULL()!< ? permutation probability related - REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related [use might change/new ones added/etc] + REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related + ! [use might change/new ones added/etc] REAL(KIND=dp) :: pweight = 0.0_dp!< ? permutation probability related REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix => NULL() INTEGER, DIMENSION(:, :), POINTER :: nmatrix => NULL() @@ -208,7 +211,8 @@ MODULE helium_types TYPE(helium_vector_type) :: prarea2 = helium_vector_type()!< projected area squared TYPE(helium_vector_type) :: mominer = helium_vector_type()!< moment of inertia INTEGER :: averages_iweight = 0!< weight for restarted averages - LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages have been restarted + LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages + ! have been restarted REAL(KIND=dp) :: link_action = 0.0_dp, inter_action = 0.0_dp, pair_action = 0.0_dp @@ -266,8 +270,10 @@ MODULE helium_types INTEGER :: solute_beads = 0!< number of solute beads (pint_env%p) INTEGER :: get_helium_forces = 0!< parameter to determine whether the average or last MC force should be taken to MD CHARACTER(LEN=2), DIMENSION(:), POINTER :: solute_element => NULL()!< element names of solute atoms (pint_env%ndim/3) - TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) (should be removed at some point) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent on the solute DIM(p,ndim) + TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) + ! (should be removed at some point) + REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent + ! on the solute DIM(p,ndim) REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_inst => NULL()!< instantaneous forces exerted by He on the solute (p,ndim) CHARACTER(LEN=2), DIMENSION(:), POINTER :: ename => NULL() INTEGER :: enum = 0 diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index f2db450a6f..13a66afdc8 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -231,7 +231,7 @@ CONTAINS IF (PRESENT(md_env)) THEN CALL get_md_env(md_env=md_env, force_env=my_force_env) - ELSEIF (PRESENT(force_env)) THEN + ELSE IF (PRESENT(force_env)) THEN my_force_env => force_env END IF @@ -551,9 +551,9 @@ CONTAINS ELSE IF (ASSOCIATED(force_env)) THEN para_env => force_env%para_env - ELSEIF (PRESENT(pint_env)) THEN + ELSE IF (PRESENT(pint_env)) THEN para_env => pint_env%logger%para_env - ELSEIF (PRESENT(helium_env)) THEN + ELSE IF (PRESENT(helium_env)) THEN ! Only needed in case that pure helium is simulated ! In this case write_restart is called only by processors ! with associated helium_env @@ -995,7 +995,7 @@ CONTAINS CALL section_vals_val_set(pint_section, "NOSE%VELOCITY%_DEFAULT_KEYWORD_", & r_vals_ptr=r_vals) - ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (tmpsec) tmpsec => section_vals_get_subs_vals(pint_section, "GLE") @@ -1326,8 +1326,9 @@ CONTAINS WRITE (stmp, *) reqlen err_str = TRIM(ADJUSTL(err_str))// & TRIM(ADJUSTL(stmp))//"'." - IF (msgLEN /= reqlen) & + IF (msgLEN /= reqlen) THEN CPABORT(err_str) + END IF ! allocate the buffer to be saved and fill it with forces ! forces should be the same on all processors, but we don't check that here @@ -1458,9 +1459,10 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(work_section%values, 2) == 1) EXIT @@ -1938,9 +1940,10 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT CALL section_vals_add_values(coord_section) @@ -2065,9 +2068,10 @@ CONTAINS CPASSERT(ss_section%ref_count > 0) section => ss_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(ss_section%values, 2) == 1) EXIT CALL section_vals_add_values(ss_section) @@ -2135,9 +2139,10 @@ CONTAINS CPASSERT(ds_section%ref_count > 0) section => ds_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(ds_section%values, 2) == 1) EXIT CALL section_vals_add_values(ds_section) @@ -2204,9 +2209,10 @@ CONTAINS CPASSERT(ww_section%ref_count > 0) section => ww_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(ww_section%values, 2) == 1) EXIT CALL section_vals_add_values(ww_section) @@ -2270,9 +2276,10 @@ CONTAINS CPASSERT(invdt_section%ref_count > 0) section => invdt_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(invdt_section%values, 2) == 1) EXIT CALL section_vals_add_values(invdt_section) diff --git a/src/motion/integrator.F b/src/motion/integrator.F index 96de427a30..a8bd19ad1f 100644 --- a/src/motion/integrator.F +++ b/src/motion/integrator.F @@ -195,8 +195,9 @@ CONTAINS nshell=nshell, & particles=particles, & virial=virial) - IF (nshell /= 0) & + IF (nshell /= 0) THEN CPABORT("Langevin dynamics is not yet implemented for core-shell models") + END IF nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1651,10 +1652,11 @@ CONTAINS ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the Trajectory frames in the TRAJECTORY file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") + END IF END IF ! Read cell parameters from cell file if requested and if not yet available @@ -1664,10 +1666,11 @@ CONTAINS CPASSERT(trj_itimes == cell_itimes) ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the cell info frames in the CELL file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") + END IF END IF END IF @@ -2527,9 +2530,10 @@ CONTAINS core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial - IF (simpar%constraint) & + IF (simpar%constraint) THEN CALL pv_constraint(gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, virial, para_env) + END IF CALL virial_evaluate(atomic_kind_set, particle_set, & local_particles, virial, para_env) diff --git a/src/motion/integrator_utils.F b/src/motion/integrator_utils.F index eb6f960915..0e567938f2 100644 --- a/src/motion/integrator_utils.F +++ b/src/motion/integrator_utils.F @@ -969,8 +969,8 @@ CONTAINS npt(:, :)%f = (1.0_dp + (3.0_dp*infree))*kin + fdotr - & 3.0_dp*simpar%p_ext*box%deth - ELSEIF (simpar%ensemble == npt_f_ensemble .OR. & - simpar%ensemble == npe_f_ensemble) THEN + ELSE IF (simpar%ensemble == npt_f_ensemble .OR. & + simpar%ensemble == npe_f_ensemble) THEN npt(:, :)%f = virial%pv_virial(:, :) + & pv_kin(:, :) + virial%pv_constraint(:, :) - & unit(:, :)*simpar%p_ext*box%deth + & @@ -980,8 +980,8 @@ CONTAINS trace = trace/3.0_dp npt(:, :)%f = trace*unit(:, :) END IF - ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. & - simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. & + simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v = box%deth vi = 1._dp/v v0 = simpar%v0 diff --git a/src/motion/mc/mc_control.F b/src/motion/mc/mc_control.F index 7a9ca26164..e55faf23dd 100644 --- a/src/motion/mc/mc_control.F +++ b/src/motion/mc/mc_control.F @@ -372,8 +372,9 @@ CONTAINS CALL destroy_force_env(f_env_id, ierr, .FALSE.) IF (ierr /= 0) CPABORT("mc_create_force_env: destroy_force_env failed") - IF (PRESENT(globenv_new)) & + IF (PRESENT(globenv_new)) THEN CALL force_env_get(force_env, globenv=globenv_new) + END IF END SUBROUTINE mc_create_force_env @@ -408,9 +409,10 @@ CONTAINS TYPE(mc_input_file_type), POINTER :: mc_input_file LOGICAL, INTENT(IN) :: ionode - IF (ionode) & + IF (ionode) THEN CALL mc_make_dat_file_new(r(:, :), atom_symbols, nunits_tot, & box_length(:), 'bias_temp.dat', nchains(:), mc_input_file) + END IF CALL mc_create_force_env(bias_env, input_declaration, para_env, 'bias_temp.dat') diff --git a/src/motion/mc/mc_coordinates.F b/src/motion/mc/mc_coordinates.F index d675054f4d..68c12b10bf 100644 --- a/src/motion/mc/mc_coordinates.F +++ b/src/motion/mc/mc_coordinates.F @@ -516,7 +516,7 @@ CONTAINS IF (exponent > exp_max_val) THEN boltz_weights(imove) = max_val - ELSEIF (exponent < exp_min_val) THEN + ELSE IF (exponent < exp_min_val) THEN boltz_weights(imove) = min_val ELSE boltz_weights(imove) = EXP(exponent) @@ -587,8 +587,9 @@ CONTAINS END IF ! make sure a configuration was chosen - IF (choosen == 0) & + IF (choosen == 0) THEN CPABORT('CBMC swap move failed to select config') + END IF ! if this is an old configuration, we always choose the first one IF (lremove) choosen = 1 @@ -761,7 +762,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSEIF (PRESENT(box)) THEN + ELSE IF (PRESENT(box)) THEN ! any molecule in box...need to find molecule type and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(:, box)), KIND=dp)) @@ -779,7 +780,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSEIF (PRESENT(molecule_type_old)) THEN + ELSE IF (PRESENT(molecule_type_old)) THEN ! any molecule of type molecule_type_old...need to find box number and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(molecule_type_old, :)), KIND=dp)) diff --git a/src/motion/mc/mc_ensembles.F b/src/motion/mc/mc_ensembles.F index 87c18a4743..1b9c1650ca 100644 --- a/src/motion/mc/mc_ensembles.F +++ b/src/motion/mc/mc_ensembles.F @@ -426,8 +426,9 @@ CONTAINS ! if we're doing a discrete volume move, we need to set up the array ! that keeps track of which direction we can move in IF (ldiscrete) THEN - IF (nboxes /= 1) & + IF (nboxes /= 1) THEN CPABORT('ldiscrete=.true. ONLY for systems with 1 box') + END IF CALL create_discrete_array(abc(:, 1), discrete_array(:, :), & discrete_step) END IF @@ -549,7 +550,7 @@ CONTAINS END DO END IF - ELSEIF (rand < pmswap) THEN + ELSE IF (rand < pmswap) THEN ! try a swap move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN @@ -569,7 +570,7 @@ CONTAINS mol_type=mol_type, nchain_total=nchain_total, nunits=nunits, & atom_names=atom_names, mass=mass) - ELSEIF (rand < pmhmc) THEN + ELSE IF (rand < pmhmc) THEN ! try hybrid Monte Carlo IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting a hybrid Monte Carlo move" @@ -595,7 +596,7 @@ CONTAINS energy_check(box_number), r_old(:, :, box_number), & rng_stream) - ELSEIF (rand < pmavbmc) THEN + ELSE IF (rand < pmavbmc) THEN ! try an AVBMC move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting an AVBMC1 move" @@ -626,8 +627,9 @@ CONTAINS EXIT END IF END DO - IF (molecule_type_swap == 0) & + IF (molecule_type_swap == 0) THEN CPABORT('Did not choose a molecule type to swap...check AVBMC input') + END IF ! now pick a molecule, automatically rejecting the move if the ! box is empty or only has one molecule @@ -749,8 +751,8 @@ CONTAINS ! figure out what kind of move we're doing IF (rand < conf_prob(1, molecule_type)) THEN move_type = 'bond' - ELSEIF (rand < (conf_prob(1, molecule_type) + & - conf_prob(2, molecule_type))) THEN + ELSE IF (rand < (conf_prob(1, molecule_type) + & + conf_prob(2, molecule_type))) THEN move_type = 'angle' ELSE move_type = 'dihedral' @@ -766,7 +768,7 @@ CONTAINS move_type, lreject, rng_stream) IF (lreject) EXIT END IF - ELSEIF (rand < pmtrans) THEN + ELSE IF (rand < pmtrans) THEN ! translate a whole molecule in the system ! pick a molecule type IF (ionode) rand = rng_stream%next() @@ -783,10 +785,11 @@ CONTAINS 'Did not choose a molecule type to translate...PMTRANS_MOL should not be all 0.0') ! now pick a molecule of that type - IF (ionode) & + IF (ionode) THEN CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) + END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -798,7 +801,7 @@ CONTAINS start_atom, box_number, bias_energy(box_number), & molecule_type, lreject, rng_stream) IF (lreject) EXIT - ELSEIF (rand < pmcltrans) THEN + ELSE IF (rand < pmcltrans) THEN ! translate a whole cluster in the system ! first, pick a box to do it for IF (ionode) rand = rng_stream%next() @@ -835,10 +838,11 @@ CONTAINS __LOCATION__, & 'Did not choose a molecule type to rotate...PMROT_MOL should not be all 0.0') - IF (ionode) & + IF (ionode) THEN CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) + END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -1271,9 +1275,10 @@ CONTAINS CPABORT('The box needs to be cubic for a virial calculation (it is easiest).') END IF IF (virial_cutoffs(nintegral_divisions) > abc(1)/2.0E0_dp) THEN - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, *) "Box length ", abc(1)*angstrom, " virial cutoff ", & - virial_cutoffs(nintegral_divisions)*angstrom + virial_cutoffs(nintegral_divisions)*angstrom + END IF CPABORT('You need a bigger box to deal with this virial cutoff (see above).') END IF @@ -1371,7 +1376,7 @@ CONTAINS IF (exponent > exp_max_val) THEN exponent = exp_max_val - ELSEIF (exponent < exp_min_val) THEN + ELSE IF (exponent < exp_min_val) THEN exponent = exp_min_val END IF mayer(itemp, ibin) = mayer(itemp, ibin) + EXP(exponent) - 1.0_dp @@ -1382,8 +1387,9 @@ CONTAINS END DO ! write out some info that keeps track of where we are IF (iw > 0) THEN - IF (MOD(ivirial, iprint) == 0) & + IF (MOD(ivirial, iprint) == 0) THEN WRITE (iw, '(A,I6,A,I6)') ' Done with config ', ivirial, ' out of ', nvirial + END IF END IF END DO diff --git a/src/motion/mc/mc_ge_moves.F b/src/motion/mc/mc_ge_moves.F index fad365147d..09393baaea 100644 --- a/src/motion/mc/mc_ge_moves.F +++ b/src/motion/mc/mc_ge_moves.F @@ -242,8 +242,9 @@ CONTAINS end_mol = start_mol + SUM(nchains(:, ibox)) - 1 CALL check_for_overlap(bias_env(ibox)%force_env, & nchains(:, ibox), nunits(:), loverlap, mol_type(start_mol:end_mol)) - IF (loverlap) & + IF (loverlap) THEN CPABORT('Quickstep move found an overlap in the old config') + END IF END IF bias_energy_old(ibox) = last_bias_energy(ibox) END DO @@ -254,7 +255,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= -1.0E-8) THEN w = 1.0_dp - ELSEIF (energies <= -500.0_dp) THEN + ELSE IF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -272,7 +273,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= 0.0_dp) THEN w = 1.0_dp - ELSEIF (energies <= -500.0_dp) THEN + ELSE IF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -367,9 +368,10 @@ CONTAINS DO iparticle = 1, nunits_tot(ibox) particles(ibox)%list%els(iparticle)%r(1:3) = & r_old(1:3, iparticle, ibox) - IF (lbias .AND. box_flag(ibox) == 1) & + IF (lbias .AND. box_flag(ibox) == 1) THEN particles_bias(ibox)%list%els(iparticle)%r(1:3) = & - r_old(1:3, iparticle, ibox) + r_old(1:3, iparticle, ibox) + END IF END DO END DO @@ -386,9 +388,10 @@ CONTAINS DO ibox = 1, nboxes CALL cp_subsys_set(subsys(ibox)%subsys, & particles=particles(ibox)%list) - IF (lbias .AND. box_flag(ibox) == 1) & + IF (lbias .AND. box_flag(ibox) == 1) THEN CALL cp_subsys_set(subsys_bias(ibox)%subsys, & particles=particles_bias(ibox)%list) + END IF END DO ! deallocate some stuff @@ -991,7 +994,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSEIF (del_quickstep_energy < exp_min_val) THEN + ELSE IF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = min_val ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -1245,11 +1248,13 @@ CONTAINS ! add to one box, subtract from the other IF (old_cell_length(1, 1)*old_cell_length(2, 1)* & - old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) & + old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN CPABORT('GE_volume moves are trying to make box 1 smaller than 3') + END IF IF (old_cell_length(1, 2)*old_cell_length(2, 2)* & - old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) & + old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN CPABORT('GE_volume moves are trying to make box 2 smaller than 3') + END IF DO iside = 1, 3 new_cell_length(iside, 1) = (old_cell_length(1, 1)**3 + & diff --git a/src/motion/mc/mc_move_control.F b/src/motion/mc/mc_move_control.F index eeb70485d6..7e5d6426bb 100644 --- a/src/motion/mc/mc_move_control.F +++ b/src/motion/mc/mc_move_control.F @@ -401,8 +401,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_bond%successes == 0) THEN rmbond(molecule_type) = rmbond(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_bond%successes == & - move_updates%bias_bond%attempts) THEN + ELSE IF (move_updates%bias_bond%successes == & + move_updates%bias_bond%attempts) THEN rmbond(molecule_type) = rmbond(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -429,8 +429,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_angle%successes == 0) THEN rmangle(molecule_type) = rmangle(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_angle%successes == & - move_updates%bias_angle%attempts) THEN + ELSE IF (move_updates%bias_angle%successes == & + move_updates%bias_angle%attempts) THEN rmangle(molecule_type) = rmangle(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -459,8 +459,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_dihedral%successes == 0) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_dihedral%successes == & - move_updates%bias_dihedral%attempts) THEN + ELSE IF (move_updates%bias_dihedral%successes == & + move_updates%bias_dihedral%attempts) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -489,8 +489,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_trans%successes == 0) THEN rmtrans(molecule_type) = rmtrans(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_trans%successes == & - move_updates%bias_trans%attempts) THEN + ELSE IF (move_updates%bias_trans%successes == & + move_updates%bias_trans%attempts) THEN rmtrans(molecule_type) = rmtrans(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -502,8 +502,9 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmtrans(molecule_type) > 10.0E0_dp) & + IF (rmtrans(molecule_type) > 10.0E0_dp) THEN rmtrans(molecule_type) = 10.0E0_dp + END IF ! clear the counters move_updates%bias_trans%attempts = 0 @@ -520,8 +521,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_cltrans%successes == 0) THEN rmcltrans = rmcltrans/2.0E0_dp - ELSEIF (move_updates%bias_cltrans%successes == & - move_updates%bias_cltrans%attempts) THEN + ELSE IF (move_updates%bias_cltrans%successes == & + move_updates%bias_cltrans%attempts) THEN rmcltrans = rmcltrans*2.0E0_dp ELSE ! now for the middle case @@ -533,8 +534,9 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmcltrans > 10.0E0_dp) & + IF (rmcltrans > 10.0E0_dp) THEN rmcltrans = 10.0E0_dp + END IF ! clear the counters move_updates%bias_cltrans%attempts = 0 @@ -554,8 +556,8 @@ CONTAINS IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi - ELSEIF (move_updates%bias_rot%successes == & - move_updates%bias_rot%attempts) THEN + ELSE IF (move_updates%bias_rot%successes == & + move_updates%bias_rot%attempts) THEN rmrot(molecule_type) = rmrot(molecule_type)*2.0E0_dp ! more than pi rotation is meaningless @@ -592,8 +594,8 @@ CONTAINS IF (move_updates%volume%successes == 0) THEN rmvolume = rmvolume/2.0E0_dp - ELSEIF (move_updates%volume%successes == & - move_updates%volume%attempts) THEN + ELSE IF (move_updates%volume%successes == & + move_updates%volume%attempts) THEN rmvolume = rmvolume*2.0E0_dp ELSE ! now for the middle case diff --git a/src/motion/mc/mc_moves.F b/src/motion/mc/mc_moves.F index bced55b54c..aabf5bcf1f 100644 --- a/src/motion/mc/mc_moves.F +++ b/src/motion/mc/mc_moves.F @@ -261,7 +261,7 @@ CONTAINS CALL change_bond_length(r_old, r_new, mc_par, molecule_type, & molecule_kind, dis_length, particles, rng_stream) - ELSEIF (move_type == 'angle') THEN + ELSE IF (move_type == 'angle') THEN ! record the attempt moves%angle%attempts = moves%angle%attempts + 1 @@ -338,7 +338,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value)*dis_length**2 @@ -366,7 +366,7 @@ CONTAINS moves%bias_bond%successes = moves%bias_bond%successes + 1 move_updates%bias_bond%successes = & move_updates%bias_bond%successes + 1 - ELSEIF (move_type == 'angle') THEN + ELSE IF (move_type == 'angle') THEN moves%angle%qsuccesses = moves%angle%qsuccesses + 1 move_updates%angle%successes = & move_updates%angle%successes + 1 @@ -581,7 +581,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -780,7 +780,7 @@ CONTAINS IF (dir == 1) THEN lx = .TRUE. - ELSEIF (dir == 2) THEN + ELSE IF (dir == 2) THEN ly = .TRUE. END IF @@ -822,7 +822,7 @@ CONTAINS particles%els(iunit)%r(3) = rznew + nzcm END DO - ELSEIF (ly) THEN + ELSE IF (ly) THEN ! *** ROTATE UNITS OF I AROUND y-AXIS *** @@ -884,7 +884,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1208,8 +1208,9 @@ CONTAINS END IF END IF CALL group%bcast(ltoo_small, source) - IF (ltoo_small) & + IF (ltoo_small) THEN CPABORT("Attempted a volume move where box size got too small.") + END IF ! now compute the energy CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) @@ -1227,7 +1228,7 @@ CONTAINS value = -BETA*(energy_term + volume_term + pressure_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1374,7 +1375,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSEIF (bond_list(ibond)%b == iatom) THEN + ELSE IF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1421,7 +1422,7 @@ CONTAINS ! notice we weight by the opposite masses...therefore lighter segments ! will move further - old_length = SQRT(DOT_PRODUCT(bond_a, bond_a)) + old_length = NORM2(bond_a) new_length_a = dis_length*mass_b/(mass_a + mass_b) new_length_b = dis_length*mass_a/(mass_a + mass_b) @@ -1543,7 +1544,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSEIF (bond_list(ibond)%b == iatom) THEN + ELSE IF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1591,15 +1592,15 @@ CONTAINS bond_c(i) = r_new(i, bend_list(bend_number)%c) - & r_new(i, bend_list(bend_number)%b) END DO - old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) - old_length_c = SQRT(DOT_PRODUCT(bond_c, bond_c)) + old_length_a = NORM2(bond_a) + old_length_c = NORM2(bond_c) old_angle = ACOS(DOT_PRODUCT(bond_a, bond_c)/(old_length_a*old_length_c)) DO i = 1, 3 bisector(i) = bond_a(i)/old_length_a + & ! not yet normalized bond_c(i)/old_length_c END DO - bis_length = SQRT(DOT_PRODUCT(bisector, bisector)) + bis_length = NORM2(bisector) bisector(1:3) = bisector(1:3)/bis_length ! now we need to find the cross product of the B-A and B-C vectors and normalize @@ -1607,14 +1608,14 @@ CONTAINS cross_prod(1) = bond_a(2)*bond_c(3) - bond_a(3)*bond_c(2) cross_prod(2) = bond_a(3)*bond_c(1) - bond_a(1)*bond_c(3) cross_prod(3) = bond_a(1)*bond_c(2) - bond_a(2)*bond_c(1) - cross_prod(1:3) = cross_prod(1:3)/SQRT(DOT_PRODUCT(cross_prod, cross_prod)) + cross_prod(1:3) = cross_prod(1:3)/NORM2(cross_prod) ! we have two axis of a coordinate system...let's get the third cross_prod_plane(1) = cross_prod(2)*bisector(3) - cross_prod(3)*bisector(2) cross_prod_plane(2) = cross_prod(3)*bisector(1) - cross_prod(1)*bisector(3) cross_prod_plane(3) = cross_prod(1)*bisector(2) - cross_prod(2)*bisector(1) cross_prod_plane(1:3) = cross_prod_plane(1:3)/ & - SQRT(DOT_PRODUCT(cross_prod_plane, cross_prod_plane)) + NORM2(cross_prod_plane) ! now bisector is x, cross_prod_plane is the y vector (pointing towards c), ! and cross_prod is z @@ -1636,7 +1637,7 @@ CONTAINS temp(1:3) = r_new(1:3, iatom) - & DOT_PRODUCT(cross_prod(1:3), r_new(1:3, iatom))* & cross_prod(1:3) - temp_length = SQRT(DOT_PRODUCT(temp, temp)) + temp_length = NORM2(temp) ! we can now compute all three components of the new bond vector along the ! axis defined above @@ -1667,7 +1668,7 @@ CONTAINS cross_prod(1:3) END IF - ELSEIF (atom_c(iatom) == 1) THEN + ELSE IF (atom_c(iatom) == 1) THEN ! if the y-coordinate is less than zero, we need to switch the sign when we make the vector, ! as the angle computed by the dot product can't distinguish between that @@ -1805,7 +1806,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSEIF (bond_list(ibond)%b == iatom) THEN + ELSE IF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1846,7 +1847,7 @@ CONTAINS bond_a(i) = r_new(i, torsion_list(torsion_number)%c) - & r_new(i, torsion_list(torsion_number)%b) END DO - old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) + old_length_a = NORM2(bond_a) bond_a(1:3) = bond_a(1:3)/old_length_a ! figure out how much we move each side, since we're mass-weighting, by the @@ -1880,7 +1881,7 @@ CONTAINS temp(1:3) = temp(1:3) + r_new(1:3, torsion_list(torsion_number)%b) r_new(1:3, iatom) = temp(1:3) - ELSEIF (atom_d(iatom) == 1) THEN + ELSE IF (atom_d(iatom) == 1) THEN ! shift the coords so c is at the origin r_new(1:3, iatom) = r_new(1:3, iatom) - & @@ -2214,7 +2215,7 @@ CONTAINS .NOT. lin .AND. move_type == 'out') THEN ! standard Metropolis rule prefactor = 1.0_dp - ELSEIF (.NOT. lin .AND. move_type == 'in') THEN + ELSE IF (.NOT. lin .AND. move_type == 'in') THEN prefactor = (1.0_dp - pbias(molecule_type))*volume_in/(pbias(molecule_type)*volume_out) ELSE prefactor = pbias(molecule_type)*volume_out/((1.0_dp - pbias(molecule_type))*volume_in) @@ -2229,7 +2230,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSEIF (del_quickstep_energy < exp_min_val) THEN + ELSE IF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = 0.0_dp ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -2416,7 +2417,7 @@ CONTAINS value = -BETA*(energy_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -2674,7 +2675,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/mc/mc_types.F b/src/motion/mc/mc_types.F index 71b691a80f..25ace61db2 100644 --- a/src/motion/mc/mc_types.F +++ b/src/motion/mc/mc_types.F @@ -1751,8 +1751,9 @@ CONTAINS rcutsq_max = 0.0e0_dp DO itype = 1, SIZE(potparm%pot, 1) DO jtype = itype, SIZE(potparm%pot, 2) - IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) & + IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) THEN rcutsq_max = potparm%pot(itype, jtype)%pot%rcutsq + END IF END DO END DO @@ -1865,8 +1866,9 @@ CONTAINS DO itype = 1, ntypes lnew_type = .TRUE. DO jtype = 1, itype - 1 - IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) & + IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) THEN lnew_type = .FALSE. + END IF END DO IF (lnew_type) THEN nmol_types = nmol_types + 1 @@ -2068,19 +2070,24 @@ CONTAINS ! some ensembles require multiple boxes or molecule types SELECT CASE (mc_par%ensemble) CASE ("GEMC_NPT") - IF (nmol_types <= 1) & + IF (nmol_types <= 1) THEN CPABORT('Cannot have GEMC-NPT simulation with only one molecule type') - IF (nboxes <= 1) & + END IF + IF (nboxes <= 1) THEN CPABORT('Cannot have GEMC-NPT simulation with only one box') + END IF CASE ("GEMC_NVT") - IF (nboxes <= 1) & + IF (nboxes <= 1) THEN CPABORT('Cannot have GEMC-NVT simulation with only one box') + END IF CASE ("TRADITIONAL") - IF (mc_par%pmswap > 0.0E0_dp) & + IF (mc_par%pmswap > 0.0E0_dp) THEN CPABORT('You cannot do swap moves in a system with only one box') + END IF CASE ("VIRIAL") - IF (nchain_total /= 2) & + IF (nchain_total /= 2) THEN CPABORT('You need exactly two molecules in the box to compute the second virial.') + END IF END SELECT ! can't choose an AVBMC target atom number higher than the number diff --git a/src/motion/mc/tamc_run.F b/src/motion/mc/tamc_run.F index bff6b10485..7be1019e15 100644 --- a/src/motion/mc/tamc_run.F +++ b/src/motion/mc/tamc_run.F @@ -269,13 +269,6 @@ CONTAINS IF (simpar%v0 == 0._dp) simpar%v0 = cell%deth END IF - ! Initialize velocities possibly applying constraints at the zeroth MD step -! ! ! CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& -! ! ! l_val=write_binary_restart_file) -!! let us see if this created all the trouble -! CALL setup_velocities(force_env,simpar,globenv,md_env,md_section,constraint_section, & -! write_binary_restart_file) - ! Setup Free Energy Calculation (if required) CALL fe_env_create(fe_env, free_energy_section) CALL set_md_env(md_env=md_env, simpar=simpar, fe_env=fe_env, cell=cell, & @@ -294,7 +287,6 @@ CONTAINS force_env%meta_env%dt = force_env%meta_env%zdt CALL initialize_md_ener(md_ener, force_env, simpar) -! force_env%meta_env%dt=force_env%meta_env%zdt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MC setup up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -306,11 +298,8 @@ CONTAINS ! set some values...will use get_globenv if that ever comes around ! initialize the random numbers -! IF (para_env%is_source()) THEN rng_stream_mc = rng_stream_type(name="Random numbers for monte carlo acc/rej", & distribution_type=UNIFORM) -! ENDIF -!!!!! this should go in a routine hmc_read NULLIFY (mc_section) ALLOCATE (mc_par) @@ -328,7 +317,6 @@ CONTAINS CALL section_vals_val_get(mc_section, "RANDOMTOSKIP", i_val=rand2skip) CPASSERT(rand2skip >= 0) temp = cp_unit_from_cp2k(simpar%temp_ext, "K") -! CALL set_mc_par(mc_par, ensemble=ensemble, nstep=nmccycles, iprint=iprint, temperature=temp, & beta=1.0_dp/temp/boltzmann*joule, exp_max_val=0.9_dp*LOG(HUGE(0.0_dp)), & @@ -372,11 +360,12 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file! "// & "You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR. "// & "Be sure the method you are using can compute the virial!") + END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -386,11 +375,12 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") + END IF END IF ! Computing Forces at zero MD step @@ -411,15 +401,12 @@ CONTAINS CALL section_vals_remove_values(work_section) END IF -! CALL force_env_calc_energy_force (force_env, calc_force=.TRUE.) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) force_env%meta_env => meta_env_saved IF (ASSOCIATED(force_env%qs_env)) THEN -! force_env%qs_env%sim_time=time -! force_env%qs_env%sim_step=itimes force_env%qs_env%sim_time = 0.0_dp force_env%qs_env%sim_step = 0 END IF @@ -434,26 +421,7 @@ CONTAINS END DO END DO END IF -! IF (force_env%meta_env%well_tempered) THEN -! force_env%meta_env%wttemperature = simpar%temp_ext -! IF (force_env%meta_env%wtgamma>EPSILON(1._dp)) THEN -! dummy=force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma-1._dp) -! IF (force_env%meta_env%delta_t>EPSILON(1._dp)) THEN -! check=ABS(force_env%meta_env%delta_t-dummy)<1.E+3_dp*EPSILON(1._dp) -! IF(.NOT.check) CALL cp_abort(__LOCATION__,& -! "Inconsistency between DELTA_T and WTGAMMA (both specified):"//& -! " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") -! ELSE -! force_env%meta_env%delta_t = dummy -! ENDIF -! ELSE -! force_env%meta_env%wtgamma = 1._dp & -! + force_env%meta_env%delta_t/force_env%meta_env%wttemperature -! ENDIF -! force_env%meta_env%invdt = 1._dp/force_env%meta_env%delta_t -! ENDIF CALL tamc_force(force_env) -! CALL metadyn_write_colvar(force_env) END IF IF (simpar%do_respa) THEN @@ -461,16 +429,10 @@ CONTAINS calc_force=.TRUE.) END IF -! CALL force_env_get( force_env, subsys=subsys) -! -! CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& -! particles=particles) - CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles, & virial, force_env%para_env) CALL md_energy(md_env, md_ener) -! CALL md_write_output(md_env) !inits the print env at itimes == 0 also writes trajectories md_stride = 1 ELSE CALL get_md_env(md_env, reftraj=reftraj) @@ -486,7 +448,6 @@ CONTAINS CALL init_mc_moves(moves) CALL init_mc_moves(gmoves) ALLOCATE (r(1:3, SIZE(particles%els))) -! ALLOCATE (r_old(1:3,size(particles%els))) CALL mc_averages_create(MCaverages) !!!!! some more buffers ! Allocate random number for Langevin Thermostat acting on COLVARS @@ -529,7 +490,6 @@ CONTAINS IF (output_unit > 0) THEN WRITE (output_unit, '(a)') "HMC|==== end initial average forces" END IF -! call set_md_env(md_env, init=.FALSE.) CALL metadyn_write_colvar(force_env) @@ -575,8 +535,6 @@ CONTAINS ! Free Energy calculation ! CALL free_energy_evaluate(md_env,should_stop,free_energy_section) - ![AME:UB] IF (should_stop) EXIT - ! Test for .EXIT_MD or for WALL_TIME to exit ! Default: ! IF so we don't overwrite the restart or append to the trajectory @@ -589,30 +547,13 @@ CONTAINS CALL external_control(should_stop, "MD", globenv=globenv) IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) -! CALL md_output(md_env,md_section,force_env%root_section,should_stop) EXIT END IF -! IF(simpar%ensemble /= reftraj_ensemble) THEN -! CALL md_energy(md_env, md_ener) -! CALL temperature_control(simpar, md_env, md_ener, force_env, logger) -! CALL comvel_control(md_ener, force_env, md_section, logger) -! CALL angvel_control(md_ener, force_env, md_section, logger) -! ELSE -! CALL md_ener_reftraj(md_env, md_ener) -! END IF - time_iter_stop = m_walltime() used_time = time_iter_stop - time_iter_start time_iter_start = time_iter_stop -!!!!! this writes the restart... -! CALL md_output(md_env,md_section,force_env%root_section,should_stop) - -! IF(simpar%ensemble == reftraj_ensemble ) THEN -! CALL write_output_reftraj(md_env) -! END IF - IF (output_unit > 0) THEN WRITE (output_unit, '(a,1x,i0)') "HMC| end z step ", istep WRITE (output_unit, '(a)') "HMC|===================================" @@ -627,7 +568,6 @@ CONTAINS CALL write_restart(md_env=md_env, root_section=force_env%root_section) ! if we need the final kinetic energy for Hybrid Monte Carlo -! hmc_ekin%final_ekin=md_ener%ekin ! Remove the iteration level CALL cp_rm_iter_level(logger%iter_info, "MD") @@ -639,15 +579,12 @@ CONTAINS DEALLOCATE (md_env) ! Clean restartable sections.. IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section) -! IF (para_env%is_source()) THEN -! ENDIF CALL MC_ENV_RELEASE(mc_env) DEALLOCATE (mc_env) DEALLOCATE (mc_par) CALL MC_MOVES_RELEASE(moves) CALL MC_MOVES_RELEASE(gmoves) DEALLOCATE (r) -! DEALLOCATE(r_old) DEALLOCATE (xieta) DEALLOCATE (An) DEALLOCATE (fz) @@ -1009,10 +946,6 @@ CONTAINS fz = 0.0_dp ishift = 0 END IF -! lrestart = .false. -! if (present(logger) .and. present(iter)) THEN -! lrestart=.true. -! ENDIF CALL get_mc_par(mc_par, nstep=nstep, iprint=iprint) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) @@ -1070,20 +1003,6 @@ CONTAINS WRITE (output_unit, '(a,f16.8)') "HMC| Running average for potential energy ", averages%ave_energy WRITE (output_unit, '(a,1x,i0)') "HMC|======== End Monte Carlo cycle ", i + ishift END IF -! IF (lrestart) THEN -! k=nstep/5 -! IF(MOD(i,k) == 0) THEN -! force_env%qs_env%sim_time=t1 -! force_env%qs_env%sim_step=it1 -! DO j=1,force_env%meta_env%n_colvar -! force_env%meta_env%metavar(j)%ff_s=fz(j)/real(i+ishift,dp) -! ENDDO -! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=-1) -! CALL section_vals_val_set(mcsec,"RANDOMTOSKIP",i_val=i+ishift) -! CALL write_restart(md_env=mdenv,root_section=force_env%root_section) -! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter) -! ENDIF -! ENDIF END DO force_env%qs_env%sim_time = t1 force_env%qs_env%sim_step = it1 @@ -1216,7 +1135,7 @@ CONTAINS ! to prevent overflows IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/md_conserved_quantities.F b/src/motion/md_conserved_quantities.F index 1c09efe72f..dc65d3fd8f 100644 --- a/src/motion/md_conserved_quantities.F +++ b/src/motion/md_conserved_quantities.F @@ -637,8 +637,9 @@ CONTAINS END DO END IF - IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) & + IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) THEN CPABORT("get_part_ke: qmmm bug") + END IF END SUBROUTINE get_part_ke ! ************************************************************************************************** diff --git a/src/motion/md_energies.F b/src/motion/md_energies.F index 629579deb7..099c430dbc 100644 --- a/src/motion/md_energies.F +++ b/src/motion/md_energies.F @@ -488,11 +488,12 @@ CONTAINS CALL cp_print_key_finished_output(tempkind, logger, motion_section, "MD%PRINT%TEMP_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") + END IF END IF !Thermal Region CALL print_thermal_regions_temperature(thermal_regions, itimes, time*femtoseconds, my_pos, my_act) @@ -558,11 +559,12 @@ CONTAINS "MD%PRINT%TEMP_SHELL_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_SHELL_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_SHELL_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") + END IF END IF END IF END IF diff --git a/src/motion/md_run.F b/src/motion/md_run.F index fbf5728dfa..ababfdc8ac 100644 --- a/src/motion/md_run.F +++ b/src/motion/md_run.F @@ -283,8 +283,9 @@ CONTAINS CALL get_md_env(md_env, ehrenfest_md=ehrenfest_md) !If requested set up the REFTRAJ run - IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) & + IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) THEN CPABORT("Ehrenfest MD does not support reftraj ensemble ") + END IF IF (simpar%ensemble == reftraj_ensemble) THEN reftraj_section => section_vals_get_subs_vals(md_section, "REFTRAJ") ALLOCATE (reftraj) @@ -338,11 +339,12 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file!"// & " You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR."// & " Be sure the method you are using can compute the virial!") + END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -352,11 +354,12 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") + END IF END IF ! Computing Forces at zero MD step @@ -402,10 +405,11 @@ CONTAINS dummy = force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma - 1._dp) IF (force_env%meta_env%delta_t > EPSILON(1._dp)) THEN check = ABS(force_env%meta_env%delta_t - dummy) < 1.E+3_dp*EPSILON(1._dp) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Inconsistency between DELTA_T and WTGAMMA (both specified):"// & " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") + END IF ELSE force_env%meta_env%delta_t = dummy END IF @@ -526,8 +530,9 @@ CONTAINS IF (itimes >= simpar%max_steps) should_stop = .TRUE. ! call external hook e.g. from global optimization - IF (PRESENT(mdctrl)) & + IF (PRESENT(mdctrl)) THEN CALL mdctrl_callback(mdctrl, md_env, should_stop) + END IF IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) diff --git a/src/motion/md_vel_utils.F b/src/motion/md_vel_utils.F index 3bc1acde2b..715e28439d 100644 --- a/src/motion/md_vel_utils.F +++ b/src/motion/md_vel_utils.F @@ -269,7 +269,7 @@ CONTAINS my_ireg = ireg my_nfree = nfree my_temp = temp - ELSEIF (PRESENT(nfree)) THEN + ELSE IF (PRESENT(nfree)) THEN my_ireg = 0 my_nfree = nfree my_temp = simpar%temp_ext @@ -1257,8 +1257,9 @@ CONTAINS IF (simpar%soften_nsteps <= 0) RETURN !nothing todo - IF (ANY(is_fixed /= use_perd_none)) & + IF (ANY(is_fixed /= use_perd_none)) THEN CPABORT("Velocitiy softening with constraints is not supported.") + END IF !backup positions DO i = 1, SIZE(part) @@ -2001,8 +2002,9 @@ CONTAINS CALL get_molecule_kind(molecule_kind=molecule_kind, fixd_list=fixd_list) IF (ASSOCIATED(fixd_list)) THEN DO ifixd = 1, SIZE(fixd_list) - IF (.NOT. fixd_list(ifixd)%restraint%active) & + IF (.NOT. fixd_list(ifixd)%restraint%active) THEN is_fixed(fixd_list(ifixd)%fixd) = fixd_list(ifixd)%itype + END IF END DO END IF END DO @@ -2112,8 +2114,9 @@ CONTAINS CALL get_molecule_kind_set(molecule_kind_set=molecule_kinds%els, & nconstraint=nconstraint, & nconstraint_fixd=nconstraint_fixd) - IF (nconstraint - nconstraint_fixd /= 0) & + IF (nconstraint - nconstraint_fixd /= 0) THEN CPABORT("Only the fixed atom constraint is implemented for core-shell models") + END IF !MK CPPostcondition(.NOT.simpar%constraint,cp_failure_level,routineP,failure) CPASSERT(ASSOCIATED(shell_particles)) CPASSERT(ASSOCIATED(core_particles)) @@ -2251,8 +2254,9 @@ CONTAINS IF (init_cascade) THEN CALL section_vals_val_get(cascade_section, "ENERGY", r_val=energy) - IF (energy < 0.0_dp) & + IF (energy < 0.0_dp) THEN CPABORT("Error occurred reading &CASCADE section: Negative energy found") + END IF IF (iw > 0) THEN ekin = cp_unit_from_cp2k(energy, "keV") @@ -2266,8 +2270,9 @@ CONTAINS atom_list_section => section_vals_get_subs_vals(cascade_section, "ATOM_LIST") CALL section_vals_val_get(atom_list_section, "_DEFAULT_KEYWORD_", n_rep_val=natom) CALL section_vals_list_get(atom_list_section, "_DEFAULT_KEYWORD_", list=atom_list) - IF (natom <= 0) & + IF (natom <= 0) THEN CPABORT("Error occurred reading &CASCADE section: No atom list found") + END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,T11,A,3(11X,A),9X,A)") & @@ -2286,12 +2291,15 @@ CONTAINS no_read_error = .FALSE. READ (UNIT=line, FMT=*, ERR=999) atom_index(iatom), vatom(1:3, iatom), weight(iatom) no_read_error = .TRUE. -999 IF (.NOT. no_read_error) & +999 IF (.NOT. no_read_error) THEN CPABORT("Error occurred reading &CASCADE section. Last line read <"//TRIM(line)//">") - IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) & + END IF + IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) THEN CPABORT("Error occurred reading &CASCADE section: Invalid atom index found") - IF (weight(iatom) < 0.0_dp) & + END IF + IF (weight(iatom) < 0.0_dp) THEN CPABORT("Error occurred reading &CASCADE section: Negative weight found") + END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,I10,4(1X,F14.6))") & "CASCADE| ", atom_index(iatom), vatom(1:3, iatom), weight(iatom) @@ -2311,7 +2319,7 @@ CONTAINS END DO weight(:) = matom(:)*weight(:)*energy/norm DO iatom = 1, natom - norm = SQRT(DOT_PRODUCT(vatom(1:3, iatom), vatom(1:3, iatom))) + norm = NORM2(vatom(1:3, iatom)) vatom(1:3, iatom) = vatom(1:3, iatom)/norm END DO diff --git a/src/motion/neb_io.F b/src/motion/neb_io.F index 0e23a7bbb3..1cd40721df 100644 --- a/src/motion/neb_io.F +++ b/src/motion/neb_io.F @@ -116,33 +116,37 @@ CONTAINS ! Before continuing let's do some consistency check between keywords IF (neb_env%pot_type /= pot_neb_full) THEN ! Requires the use of colvars - IF (.NOT. neb_env%use_colvar) & + IF (.NOT. neb_env%use_colvar) THEN CALL cp_abort(__LOCATION__, & "A potential energy function based on free energy or minimum energy"// & " was requested without enabling the usage of COLVARS. Both methods"// & " are based on COLVARS definition.") + END IF ! Moreover let's check if the proper sections have been defined.. SELECT CASE (neb_env%pot_type) CASE (pot_neb_fe) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%MD") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CALL cp_abort(__LOCATION__, & "A free energy BAND (colvars projected) calculation is requested"// & " but NONE MD section was defined in the input.") + END IF CASE (pot_neb_me) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%GEO_OPT") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CALL cp_abort(__LOCATION__, & "A minimum energy BAND (colvars projected) calculation is requested"// & " but NONE GEO_OPT section was defined in the input.") + END IF END SELECT ELSE - IF (neb_env%use_colvar) & + IF (neb_env%use_colvar) THEN CALL cp_abort(__LOCATION__, & "A band calculation was requested with a full potential energy. USE_COLVAR cannot"// & " be set for this kind of calculation!") + END IF END IF ! String Method CALL section_vals_val_get(neb_section, "STRING_METHOD%SMOOTHING", r_val=neb_env%smoothing) @@ -263,9 +267,10 @@ CONTAINS END IF END DO - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" + routineN//": Done!" + END IF CALL cp_print_key_finished_output(iw, logger, neb_env%neb_section, "FINAL_BAND") diff --git a/src/motion/neb_methods.F b/src/motion/neb_methods.F index 9af2b50a23..cba323ad65 100644 --- a/src/motion/neb_methods.F +++ b/src/motion/neb_methods.F @@ -462,14 +462,16 @@ CONTAINS IF (do_ls .AND. (.NOT. skip_ls)) THEN CALL neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces, & vels, particle_set, iw, output_unit, distances, diis_section, iw2) - IF (iw2 > 0) & + IF (iw2 > 0) THEN WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD after linesearch", & - stepsize + stepsize + END IF ELSE stepsize = MIN(norm*stepsize0, max_stepsize) - IF (iw2 > 0) & + IF (iw2 > 0) THEN WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD no linesearch performed", & - stepsize + stepsize + END IF END IF sline%wrk = stepsize*sline%wrk diis_on = accept_diis_step(istep > max_sd_steps, n_diis, err, crr, set_err, sline, coords, & diff --git a/src/motion/neb_opt_utils.F b/src/motion/neb_opt_utils.F index 3e1c06599d..ea36fe5d36 100644 --- a/src/motion/neb_opt_utils.F +++ b/src/motion/neb_opt_utils.F @@ -228,7 +228,7 @@ CONTAINS LOGICAL, INTENT(IN) :: check_diis LOGICAL :: accepted - REAL(KIND=dp) :: costh, norm1, norm2 + REAL(KIND=dp) :: costh, ref_norm, step_norm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp accepted = .TRUE. @@ -237,9 +237,9 @@ CONTAINS ! (a) The direction of the DIIS step, can be compared to the reference step. ! if the angle is grater than a specified value, the DIIS step is not ! acceptable. - norm1 = SQRT(DOT_PRODUCT(ref, ref)) - norm2 = SQRT(DOT_PRODUCT(step, step)) - costh = DOT_PRODUCT(ref, step)/(norm1*norm2) + ref_norm = NORM2(ref) + step_norm = NORM2(step) + costh = DOT_PRODUCT(ref, step)/(ref_norm*step_norm) IF (check_diis) THEN IF (costh < acceptance_factor(MIN(10, nv))) accepted = .FALSE. ELSE @@ -258,7 +258,7 @@ CONTAINS IF (accepted .AND. check_diis) THEN ! (b) The length of the DIIS step is limited to be no more than 10 times ! the reference step - IF (norm1 > norm2*10.0_dp) accepted = .FALSE. + IF (ref_norm > step_norm*10.0_dp) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "The length of the DIIS step is limited to be no more than 10 times", & @@ -267,10 +267,10 @@ CONTAINS END IF IF (accepted .AND. check_diis) THEN ! (d) If the DIIS matrix is nearly singular, the norm of the DIIS step - ! vector becomes small and cwrk/norm1 becomes large, signaling a - ! numerical stability problems. If the magnitude of cwrk/norm1 + ! vector becomes small and cwrk/ref_norm becomes large, signaling a + ! numerical stability problems. If the magnitude of cwrk/ref_norm ! exceeds 10^8 then the step size is assumed to be unacceptable - IF (ANY(ABS(cwrk(1:nv)/norm1) > 10**8_dp)) accepted = .FALSE. + IF (ANY(ABS(cwrk(1:nv)/ref_norm) > 10**8_dp)) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "If the DIIS matrix is nearly singular, the norm of the DIIS step", & diff --git a/src/motion/neb_utils.F b/src/motion/neb_utils.F index 264b4260d7..7f38f3c615 100644 --- a/src/motion/neb_utils.F +++ b/src/motion/neb_utils.F @@ -118,8 +118,7 @@ CONTAINS CALL rmsd3(particle_set, coords%xyz(:, i), coords%xyz(:, i0), & iw, rotate=my_rotate) END IF - distance = SQRT(DOT_PRODUCT(coords%wrk(:, i) - coords%wrk(:, i0), & - coords%wrk(:, i) - coords%wrk(:, i0))) + distance = NORM2(coords%wrk(:, i) - coords%wrk(:, i0)) END SUBROUTINE neb_replica_distance @@ -224,11 +223,12 @@ CONTAINS DO iatom = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for REPLICA coordinates. Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") + END IF READ (parser%input_line, *) dummy_char, r(1:3) ic = 3*(iatom - 1) coords%xyz(ic + 1:ic + 3, i_rep) = r(1:3)*bohr @@ -737,7 +737,7 @@ CONTAINS ! String method.. tangent(:) = 0.0_dp END SELECT - distance0 = SQRT(DOT_PRODUCT(tangent(:), tangent(:))) + distance0 = NORM2(tangent(:)) IF (distance0 /= 0.0_dp) tangent(:) = tangent(:)/distance0 END SUBROUTINE get_tangent @@ -849,7 +849,7 @@ CONTAINS ALLOCATE (dtmp1(nsize_wrk)) dtmp1(:) = forces%wrk(:, i) - dot_product_band(neb_env, forces%wrk(:, i), tangent, Mmatrix)*tangent forces%wrk(:, i) = dtmp1 - tmp = SQRT(DOT_PRODUCT(dtmp1, dtmp1)) + tmp = NORM2(dtmp1) dtmp1(:) = dtmp1(:)/tmp ! Project out only the spring component interfering with the ! orthogonal gradient of the band diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index 1f59bcbb61..8e9e1464c4 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -182,7 +182,7 @@ CONTAINS CHARACTER(len=2*default_string_length) :: msg CHARACTER(len=default_path_length) :: output_file_name, project_name INTEGER :: handle, iat, ibead, icont, idim, idir, & - ierr, ig, itmp, nrep, prep, stat + ierr, ig, itmp, nrep, prep LOGICAL :: explicit, ltmp REAL(kind=dp) :: dt, mass, omega TYPE(cp_subsys_type), POINTER :: subsys @@ -377,9 +377,7 @@ CONTAINS pint_env%uf_h(pint_env%p, pint_env%ndim), & pint_env%centroid(pint_env%ndim), & pint_env%rtmp_ndim(pint_env%ndim), & - pint_env%rtmp_natom(pint_env%ndim/3), & - STAT=stat) - CPASSERT(stat == 0) + pint_env%rtmp_natom(pint_env%ndim/3)) pint_env%x = 0._dp pint_env%v = 0._dp pint_env%f = 0._dp @@ -476,7 +474,6 @@ CONTAINS pint_env%gle%loc_num_gle = pint_env%p*pint_env%ndim pint_env%gle%glob_num_gle = pint_env%gle%loc_num_gle ALLOCATE (pint_env%gle%map_info%index(pint_env%gle%loc_num_gle)) - CPASSERT(stat == 0) DO itmp = 1, pint_env%gle%loc_num_gle pint_env%gle%map_info%index(itmp) = itmp END DO @@ -1168,8 +1165,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN CPABORT("Invalid size of MOTION%PINT%BEADS%COORD") + END IF ic = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1337,8 +1335,9 @@ CONTAINS WRITE (stmp, *) n_rep_val msg = "Invalid number of atoms in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (3*n_rep_val /= pint_env%ndim) & + IF (3*n_rep_val /= pint_env%ndim) THEN CPABORT(msg) + END IF DO ia = 1, pint_env%ndim/3 CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & i_rep_val=ia, r_vals=r_vals) @@ -1347,8 +1346,9 @@ CONTAINS WRITE (stmp, *) itmp msg = "Number of coordinates != 3 in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (itmp /= 3) & + IF (itmp /= 3) THEN CPABORT(msg) + END IF DO ib = 1, pint_env%p DO ic = 1, 3 idim = 3*(ia - 1) + ic @@ -1464,8 +1464,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN CPABORT("Invalid size of MOTION%PINT%BEAD%VELOCITY") + END IF itmp = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1642,8 +1643,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN CPABORT("Invalid size of MOTION%PINT%NOSE%COORD") + END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1670,8 +1672,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN CPABORT("Invalid size of MOTION%PINT%NOSE%VELOCITY") + END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1687,7 +1690,7 @@ CONTAINS END IF END IF - ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (input_section) input_section => section_vals_get_subs_vals(pint_env%input, & "MOTION%PINT%GLE") diff --git a/src/motion/pint_piglet.F b/src/motion/pint_piglet.F index 0170324d7e..781149afb0 100644 --- a/src/motion/pint_piglet.F +++ b/src/motion/pint_piglet.F @@ -493,7 +493,8 @@ CONTAINS END DO END DO - ! the piglet is such a strong thermostat, that it messes up the "exact" integration. The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) + ! the piglet is such a strong thermostat, that it messes up the "exact" integration. + ! The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) piglet_therm%thermostat_energy = piglet_therm%thermostat_energy - 0.5_dp*delta_ekin CALL timestop(handle) diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index 5d9d1bed66..c305ca9656 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -148,7 +148,7 @@ CONTAINS np = 2**il ! number of points to be generated at this level dl = n/(2*np) ! interval betw points (in index numbers) - vrnc = vrnc/2.0_dp; ! variance at this level (=t at level 0) + vrnc = vrnc/2.0_dp ! variance at this level (=t at level 0) ! loop over points added in this level DO ip = 0, np - 1 diff --git a/src/motion/reftraj_util.F b/src/motion/reftraj_util.F index 55daf473eb..00d61232d1 100644 --- a/src/motion/reftraj_util.F +++ b/src/motion/reftraj_util.F @@ -112,20 +112,22 @@ CONTAINS END IF reftraj%isnap = nskip - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the trajectory file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") + END IF ! Cell File IF (reftraj%info%variable_volume) THEN IF (nskip > 0) THEN CALL parser_get_next_line(reftraj%info%cell_parser, nskip, at_end=my_end) END IF - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the cell file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") + END IF END IF reftraj%natom = natom diff --git a/src/motion/rt_propagation.F b/src/motion/rt_propagation.F index 5e72c71fbc..67170aa565 100644 --- a/src/motion/rt_propagation.F +++ b/src/motion/rt_propagation.F @@ -294,7 +294,8 @@ CONTAINS CALL rt_initialize_rho_from_mos(rtp, mos) END IF ELSE - !The wavefunction was minimized using a linear scaling method. The density matrix is therefore taken from the ls_scf_env. + ! The wavefunction was minimized using a linear scaling method. + ! The density matrix is therefore taken from the ls_scf_env. CALL get_rtp(rtp=rtp, rho_old=rho_old, rho_new=rho_new) DO ispin = 1, SIZE(rho_old)/2 re = 2*ispin - 1 @@ -417,8 +418,9 @@ CONTAINS CALL cp_iterate(logger%iter_info, last=(i_step == max_steps), iter_nr=i_step) rtp%converged = .FALSE. DO i_iter = 1, max_iter - IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) & + IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) THEN CALL qs_ks_did_change(qs_env%ks_env, s_mstruct_changed=.TRUE.) + END IF rtp%iter = i_iter CALL propagation_step(qs_env, rtp, rtp_control) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) @@ -444,9 +446,10 @@ CONTAINS END DO CALL cp_rm_iter_level(logger%iter_info, "MD") - IF (.NOT. rtp%converged) & + IF (.NOT. rtp%converged) THEN CALL cp_abort(__LOCATION__, "propagation did not converge, "// & "either increase MAX_ITER or use a smaller TIMESTEP") + END IF CALL timestop(handle) @@ -617,8 +620,9 @@ CONTAINS CALL set_ks_env(ks_env, complex_ks=imag_ks) IF (imag_ks) THEN CALL qs_ks_allocate_basics(qs_env, is_complex=imag_ks) - IF (.NOT. dft_control%rtp_control%fixed_ions) & + IF (.NOT. dft_control%rtp_control%fixed_ions) THEN CALL rtp_create_SinvH_imag(rtp, dft_control%nspins) + END IF END IF ! h diff --git a/src/motion/simpar_methods.F b/src/motion/simpar_methods.F index 0e25a66a64..b9b5058f74 100644 --- a/src/motion/simpar_methods.F +++ b/src/motion/simpar_methods.F @@ -320,17 +320,19 @@ CONTAINS CALL section_vals_get(tmp_section, explicit=simpar%constraint) IF (simpar%constraint) THEN CALL section_vals_val_get(tmp_section, "SHAKE_TOLERANCE", r_val=simpar%shake_tol) - IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) & + IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN CALL cp_warn(__LOCATION__, & "Shake tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 1000*EPSILON!") + END IF simpar%shake_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%shake_tol) CALL section_vals_val_get(tmp_section, "ROLL_TOLERANCE", r_val=simpar%roll_tol) - IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) & + IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN CALL cp_warn(__LOCATION__, & "Roll tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up roll_tol to 1000*EPSILON!") + END IF simpar%roll_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%roll_tol) END IF diff --git a/src/motion/thermal_region_utils.F b/src/motion/thermal_region_utils.F index 7d1a6aee4c..b90e95b7af 100644 --- a/src/motion/thermal_region_utils.F +++ b/src/motion/thermal_region_utils.F @@ -425,12 +425,14 @@ CONTAINS TRIM(my_reg)//" which is not allowed!") END IF ELSE - IF (.NOT. ipart > 0) & + IF (.NOT. ipart > 0) THEN CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is non-positive!") - IF (.NOT. ipart <= particles%n_els) & + END IF + IF (.NOT. ipart <= particles%n_els) THEN CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is out of bounds!") + END IF END IF END SUBROUTINE set_t_region_index diff --git a/src/motion/thermostat/al_system_dynamics.F b/src/motion/thermostat/al_system_dynamics.F index c17af73a3b..935d2959e4 100644 --- a/src/motion/thermostat/al_system_dynamics.F +++ b/src/motion/thermostat/al_system_dynamics.F @@ -72,20 +72,23 @@ CONTAINS my_shell_adiabatic = .FALSE. map_info => al%map_info - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "INIT") + END IF IF (al%tau_nh <= 0.0_dp) THEN CALL al_OU_step(0.5_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post OU") + END IF ELSE ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 1st OU") + END IF ! Compute the kinetic energy for the region to thermostat for the (T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & @@ -99,8 +102,9 @@ CONTAINS ! Recompute the kinetic energy for the region to thermostat (for the T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & local_molecules, molecule_set, group, vel=vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post rescale_vel") + END IF ! quarter step of chi CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.FALSE.) @@ -108,8 +112,9 @@ CONTAINS ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 2nd OU") + END IF END IF ! Recompute the final kinetic energy for the region to thermostat @@ -187,7 +192,7 @@ CONTAINS iparticle_local, jj, last_atom, nmol_local, nparticle, nparticle_kind, nparticle_local LOGICAL :: check, present_vel REAL(KIND=dp) :: mass - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w(:, :) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(molecule_type), POINTER :: molecule diff --git a/src/motion/thermostat/al_system_init.F b/src/motion/thermostat/al_system_init.F index f68e657e98..776589c531 100644 --- a/src/motion/thermostat/al_system_init.F +++ b/src/motion/thermostat/al_system_init.F @@ -130,9 +130,10 @@ CONTAINS work_section => section_vals_get_subs_vals(section_vals=al_section, & subsection_name="MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (restart .NEQV. explicit) & + IF (restart .NEQV. explicit) THEN CALL cp_abort(__LOCATION__, & "You need to define both CHI and MASS sections (or none) in the AD_LANGEVIN section") + END IF restart = restart .AND. explicit IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section, keyword_name="_DEFAULT_KEYWORD_", & diff --git a/src/motion/thermostat/barostat_types.F b/src/motion/thermostat/barostat_types.F index b5227e3243..0fcea72931 100644 --- a/src/motion/thermostat/barostat_types.F +++ b/src/motion/thermostat/barostat_types.F @@ -118,14 +118,16 @@ CONTAINS ! User defined virial screening CALL section_vals_val_get(barostat_section, "VIRIAL", i_val=barostat%virial_components) check = barostat%virial_components == do_clv_xyz .OR. simpar%ensemble == npt_f_ensemble - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "The screening of the components of "// & "the virial is available only with the NPT_F ensemble!") + END IF ELSE - IF (explicit) & + IF (explicit) THEN CALL cp_warn(__LOCATION__, & "A barostat has been defined with an MD ensemble which does not support barostat! "// & "Its definition will be ignored!") + END IF END IF END SUBROUTINE create_barostat_type diff --git a/src/motion/thermostat/barostat_utils.F b/src/motion/thermostat/barostat_utils.F index 0028cd607a..9c03aa5a03 100644 --- a/src/motion/thermostat/barostat_utils.F +++ b/src/motion/thermostat/barostat_utils.F @@ -75,7 +75,7 @@ CONTAINS baro_kin = baro_kin + 0.5_dp*npt(i, j)%v**2*npt(i, j)%mass END DO END DO - ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v0 = simpar%v0 iv0 = 1._dp/v0 v_shock = simpar%v_shock diff --git a/src/motion/thermostat/extended_system_init.F b/src/motion/thermostat/extended_system_init.F index 1f3feae8b0..733677c944 100644 --- a/src/motion/thermostat/extended_system_init.F +++ b/src/motion/thermostat/extended_system_init.F @@ -126,9 +126,10 @@ CONTAINS restart = explicit work_section2 => section_vals_get_subs_vals(work_section, "MASS") CALL section_vals_get(work_section2, explicit=explicit) - IF (restart .NEQV. explicit) & + IF (restart .NEQV. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "MASS section (or none) in the BAROSTAT section") + END IF restart = explicit .AND. restart END IF @@ -616,21 +617,24 @@ CONTAINS restart = explicit work_section => section_vals_get_subs_vals(nose_section, "COORD") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) & + IF (.NOT. restart .AND. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") + END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) & + IF (.NOT. restart .AND. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") + END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "FORCE") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) & + IF (.NOT. restart .AND. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") + END IF restart = explicit .AND. restart END IF diff --git a/src/motion/thermostat/extended_system_mapping.F b/src/motion/thermostat/extended_system_mapping.F index 24296d6be1..de819b53ab 100644 --- a/src/motion/thermostat/extended_system_mapping.F +++ b/src/motion/thermostat/extended_system_mapping.F @@ -333,8 +333,9 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 + END IF END DO END DO @@ -428,8 +429,9 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 + END IF END DO END DO diff --git a/src/motion/thermostat/gle_system_dynamics.F b/src/motion/thermostat/gle_system_dynamics.F index 9bbbf2728d..819e98448c 100644 --- a/src/motion/thermostat/gle_system_dynamics.F +++ b/src/motion/thermostat/gle_system_dynamics.F @@ -289,7 +289,7 @@ CONTAINS L(i, i) = 1.0_dp D(i) = SST(i, i) DO j = 1, i - 1 - L(i, j) = SST(i, j); + L(i, j) = SST(i, j) DO k = 1, j - 1 L(i, j) = L(i, j) - L(i, k)*L(j, k)*D(k) END DO diff --git a/src/motion/thermostat/thermostat_utils.F b/src/motion/thermostat/thermostat_utils.F index f3e5828f48..3cfc8a24bb 100644 --- a/src/motion/thermostat/thermostat_utils.F +++ b/src/motion/thermostat/thermostat_utils.F @@ -384,8 +384,9 @@ CONTAINS DO ipart = first_atom, last_atom natom_local = natom_local + 1 ! only map the correct region to the thermostat - IF (thermolist(ipart) /= HUGE(0)) & + IF (thermolist(ipart) /= HUGE(0)) THEN thermostat_info%map_loc_thermo_gen(natom_local) = thermolist(ipart) + END IF END DO END DO END DO @@ -452,7 +453,7 @@ CONTAINS qmmm_env) TYPE(section_vals_type), POINTER :: region_sections INTEGER, INTENT(INOUT), OPTIONAL :: sum_of_thermostats - INTEGER, DIMENSION(:), POINTER :: thermolist(:) + INTEGER, POINTER :: thermolist(:) TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(molecule_list_type), POINTER :: molecules TYPE(particle_list_type), POINTER :: particles @@ -652,19 +653,21 @@ CONTAINS nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) & + IF (sum_of_thermostats < 1) THEN CALL cp_abort(__LOCATION__, & "A thermostat type DEFINED is requested but no thermostat "// & "regions are defined in THERMOSTAT/DEFINE_REGION.") + END IF CASE (do_region_thermal) ! Similar to defined region above, but in THERMAL_REGION%DEFINE_REGION nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) & + IF (sum_of_thermostats < 1) THEN CALL cp_abort(__LOCATION__, & "A thermostat type THERMAL is requested but no thermal "// & "regions are defined in THERMAL_REGION/DEFINE_REGION.") + END IF END SELECT ! Here we decide which parallel algorithm to use. @@ -1082,19 +1085,25 @@ CONTAINS atomic_kind => particle_set(ipart)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, mass=mass) IF (present_vel) THEN - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*vel(1, ipart)**2 - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*vel(2, ipart)**2 - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*vel(3, ipart)**2 + END IF ELSE - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*particle_set(ipart)%v(1)**2 - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*particle_set(ipart)%v(2)**2 - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*particle_set(ipart)%v(3)**2 + END IF END IF END DO END DO diff --git a/src/motion/vibrational_analysis.F b/src/motion/vibrational_analysis.F index 88128bdefa..cdefc2aa4d 100644 --- a/src/motion/vibrational_analysis.F +++ b/src/motion/vibrational_analysis.F @@ -653,7 +653,7 @@ CONTAINS DO j = 1, nvib D_deriv(:) = D_deriv(:) + dip_deriv(:, j)*Hint2(j, i) END DO - intensities_d(i) = SQRT(DOT_PRODUCT(D_deriv, D_deriv)) + intensities_d(i) = NORM2(D_deriv) P_deriv = 0._dp DO j = 1, nvib ! P_deriv has units bohr^2/sqrt(a.u.) @@ -970,7 +970,7 @@ CONTAINS work(:) = work - norm*D(:, i) END DO ! Check norm of the new generated vector - norm = SQRT(DOT_PRODUCT(work, work)) + norm = NORM2(work) IF (norm >= 10E4_dp*thrs_motion) THEN ! Accept new vector ifound = ifound + 1 diff --git a/src/motion/xyz2dcd.F b/src/motion/xyz2dcd.F index 7ccc80c0aa..91cacc54bc 100644 --- a/src/motion/xyz2dcd.F +++ b/src/motion/xyz2dcd.F @@ -13,7 +13,8 @@ PROGRAM xyz2dcd ! ! Note: The input coordinates and the cell vectors should be in Angstrom. -! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) +! and comment the corresponding variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -367,9 +368,9 @@ PROGRAM xyz2dcd a(1:3) = h(1:3, 1) b(1:3) = h(1:3, 2) c(1:3) = h(1:3, 3) - abc(1) = SQRT(DOT_PRODUCT(a(1:3), a(1:3))) - abc(2) = SQRT(DOT_PRODUCT(b(1:3), b(1:3))) - abc(3) = SQRT(DOT_PRODUCT(c(1:3), c(1:3))) + abc(1) = NORM2(a(1:3)) + abc(2) = NORM2(b(1:3)) + abc(3) = NORM2(c(1:3)) alpha = angle(b(1:3), c(1:3))*degree beta = angle(a(1:3), c(1:3))*degree gamma = angle(a(1:3), b(1:3))*degree @@ -579,8 +580,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = SQRT(DOT_PRODUCT(a, a)) - length_of_b = SQRT(DOT_PRODUCT(b, b)) + length_of_a = NORM2(a) + length_of_b = NORM2(b) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion_utils.F b/src/motion_utils.F index d83916a8e3..518479b9b3 100644 --- a/src/motion_utils.F +++ b/src/motion_utils.F @@ -180,7 +180,7 @@ CONTAINS END DO ! Normalize Translations DO i = 1, 3 - norm = SQRT(DOT_PRODUCT(Tr(:, i), Tr(:, i))) + norm = NORM2(Tr(:, i)) Tr(:, i) = Tr(:, i)/norm END DO dof = 3 @@ -445,8 +445,9 @@ CONTAINS CALL section_vals_val_get(root_section, "MOTION%PRINT%TRAJECTORY%CHARGE_EXTENDED", & l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) & + IF (i > 1) THEN CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected, ") + END IF END IF IF (new_file) THEN CALL m_timestamp(timestamp) diff --git a/src/mp2_cphf.F b/src/mp2_cphf.F index 17064b72ff..b79c447ade 100644 --- a/src/mp2_cphf.F +++ b/src/mp2_cphf.F @@ -1204,8 +1204,9 @@ CONTAINS precond(ispin)%local_data(:, :)*residual(ispin)%local_data(:, :) END DO ELSE - IF (mp2_env%ri_grad%polak_ribiere) & + IF (mp2_env%ri_grad%polak_ribiere) THEN residual_new_dot_diff_search_vec_old = accurate_dot_product_spin(residual, diff_search_vector) + END IF DO ispin = 1, nspins diff_search_vector(ispin)%local_data(:, :) = & @@ -1810,7 +1811,8 @@ CONTAINS deb = force(1)%overlap_admm(1:3, 1) IF (use_virial) e_dummy = third_tr(virial%pv_virial) END IF - ! Add the second half of the projector deriatives contracting the first order density matrix with the fockian in the auxiliary basis + ! Add the second half of the projector deriatives contracting the first order + ! density matrix with the fockian in the auxiliary basis IF (do_exx) THEN CALL admm_projection_derivative(qs_env, matrix_ks_aux, matrix_p_mp2) ELSE diff --git a/src/mp2_eri.F b/src/mp2_eri.F index 0f8887f897..41e5c51153 100644 --- a/src/mp2_eri.F +++ b/src/mp2_eri.F @@ -743,9 +743,11 @@ CONTAINS basis_set_a => basis_set_list_a(ikind)%gto_basis_set ! When RI_AUX NONE is invoked, the pointers to basis_set_a and basis_set_b are created, ! but not filled. Therefore, we check for the association and the number of entries. - IF (.NOT. ASSOCIATED(basis_set_a) .OR. SUM(basis_set_a%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE + IF (SUM(basis_set_a%nsgf_set) <= 0) CYCLE basis_set_b => basis_set_list_b(jkind)%gto_basis_set - IF (.NOT. ASSOCIATED(basis_set_b) .OR. SUM(basis_set_b%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE + IF (SUM(basis_set_b%nsgf_set) <= 0) CYCLE atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) diff --git a/src/mp2_gpw.F b/src/mp2_gpw.F index 98525dd116..46cb0e6a20 100644 --- a/src/mp2_gpw.F +++ b/src/mp2_gpw.F @@ -559,8 +559,9 @@ CONTAINS starts_array_mc, ends_array_mc, & starts_array_mc_block, ends_array_mc_block, calc_forces) - IF (mp2_env%ri_rpa%do_rse) & + IF (mp2_env%ri_rpa%do_rse) THEN CALL rse_energy(qs_env, mp2_env, para_env, dft_control, mo_coeff, homo, Eigenval) + END IF IF (do_im_time) THEN IF (ASSOCIATED(mat_P_global%matrix)) THEN diff --git a/src/mp2_grids.F b/src/mp2_grids.F index b252e372b8..85dd1350ba 100644 --- a/src/mp2_grids.F +++ b/src/mp2_grids.F @@ -133,12 +133,13 @@ CONTAINS my_regularization = regularization IF (num_integ_points > 20 .AND. e_range < 100.0_dp) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL cp_warn(__LOCATION__, & "You requested a large minimax grid (> 20 points) for a small minimax range R (R < 100). "// & "That may lead to numerical "// & "instabilities when computing minimax grid weights. You can prevent small ranges by choosing "// & "a larger basis set with higher angular momenta or alternatively using all-electron calculations.") + END IF END IF IF (.NOT. do_ri_sos_laplace_mp2) THEN diff --git a/src/mp2_ri_2c.F b/src/mp2_ri_2c.F index 33beee71d0..4ff515a0c1 100644 --- a/src/mp2_ri_2c.F +++ b/src/mp2_ri_2c.F @@ -916,9 +916,9 @@ CONTAINS hab=L_local_col, first_b=my_group_L_start, last_b=my_group_L_end, & eri_method=eri_method) - ELSEIF (eri_method == do_eri_gpw .OR. & - (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & - .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN + ELSE IF (eri_method == do_eri_gpw .OR. & + (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & + .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN CALL mp2_eri_2c_integrate_gpw(qs_env, para_env_sub, my_group_L_start, my_group_L_end, & natom, potential, sab_orb_sub, L_local_col, kind_of) diff --git a/src/mp2_ri_gpw.F b/src/mp2_ri_gpw.F index 93e6956add..39ce98dfc8 100644 --- a/src/mp2_ri_gpw.F +++ b/src/mp2_ri_gpw.F @@ -384,7 +384,8 @@ CONTAINS END IF END DO IF (my_alpha_beta_case .AND. calc_forces) THEN - ! Is just an approximation, but the call does not allow it, it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI + ! Is just an approximation, but the call does not allow it, + ! it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(ispin) + my_B_size(jspin), dimen_RI) ELSE CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(jspin), dimen_RI) @@ -451,11 +452,12 @@ CONTAINS my_Emp2_Ex = my_Emp2_Ex + sym_fac*local_ab(a_global, b)*external_ab(b, a)/ & (Eigenval(homo(ispin) + a_global, ispin) + Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) - IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) & + IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) THEN t_ab(a_global, b) = -(amp_fac*local_ab(a_global, b) - mp2_env%scale_T*external_ab(b, a))/ & (Eigenval(homo(ispin) + a_global, ispin) + & Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) + END IF END DO END DO END DO @@ -673,8 +675,9 @@ CONTAINS ! We do not need this matrix later, so deallocate it here to safe memory IF (calc_forces) DEALLOCATE (mp2_env%ri_grad%PQ_half) - IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) & + IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN DEALLOCATE (mp2_env%ri_grad%operator_half) + END IF CALL dgemm_counter_write(dgemm_counter, para_env) @@ -1394,7 +1397,8 @@ CONTAINS ! 2*(NR/NG)+2*(1-(NR/NG))*(o/NB+NB-2)/NG = (NR/NG)*(1-(o/NB+NB-2)/NG)+(o/NB+NB-2)/NG ! We are looking for the minimum of the communication volume, ! thus, if the prefactor of (NR/NG) is smaller than zero, use the largest possible replication group size. - ! If the factor is larger than zero, set the replication group size to 1. (For small systems and a large number of subgroups) + ! If the factor is larger than zero, set the replication group size to 1. + ! (For small systems and a large number of subgroups) ! Replication group size = 1 implies that the integration group size equals the number of subgroups integ_group_size = ngroup @@ -2547,8 +2551,9 @@ CONTAINS DO iiB = 1, homo ! diagonal elements already updated DO jjB = iiB + 1, homo - IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) & + IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) THEN num_sing_ij = num_sing_ij + 1 + END IF END DO END DO diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 9c98de42df..266f1edd5d 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -331,7 +331,7 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(matrix_P_munu_local) CALL dbcsr_deallocate_matrix_set(mat_munu_local) - ELSEIF (eri_method == do_eri_gpw) THEN + ELSE IF (eri_method == do_eri_gpw) THEN CALL get_qs_env(qs_env, ks_env=ks_env) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) diff --git a/src/mpiwrap/message_passing.F b/src/mpiwrap/message_passing.F index 3c62f4ee9b..15f8d39d2c 100644 --- a/src/mpiwrap/message_passing.F +++ b/src/mpiwrap/message_passing.F @@ -33,7 +33,8 @@ MODULE message_passing #include "../base/base_uses.f90" -! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types +! To simplify the transition between the old MPI module and the F08-style module, +! we introduce these constants to switch between the required handle types ! Unfortunately, Fortran does not offer something like typedef in C++ #if defined(__parallel) && defined(__MPI_F08) #define MPI_DATA_TYPE TYPE(MPI_Datatype) @@ -60,9 +61,11 @@ MODULE message_passing #endif #if defined(__parallel) -! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion), +! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines +! (problems with types and ranks explosion), ! we do not quite know what is in the module, so we can not include any.... -! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is +! to nevertheless get checking for what is included, we use the mpi module +! without use clause, getting all there is #if defined(__MPI_F08) USE mpi_f08 #else diff --git a/src/mpiwrap/mp_perf_env.F b/src/mpiwrap/mp_perf_env.F index 9c331367a6..7a28a50ebc 100644 --- a/src/mpiwrap/mp_perf_env.F +++ b/src/mpiwrap/mp_perf_env.F @@ -13,6 +13,8 @@ MODULE mp_perf_env USE kinds, ONLY: dp #include "../base/base_uses.f90" + IMPLICIT NONE + PRIVATE PUBLIC :: mp_perf_env_type diff --git a/src/mpiwrap/mp_perf_test.F b/src/mpiwrap/mp_perf_test.F index 3e9a701fbc..675e5b675d 100644 --- a/src/mpiwrap/mp_perf_test.F +++ b/src/mpiwrap/mp_perf_test.F @@ -34,6 +34,8 @@ MODULE mp_perf_test #endif #endif + IMPLICIT NONE + PRIVATE PUBLIC :: mpi_perf_test @@ -334,8 +336,9 @@ CONTAINS END IF rcount = Nloc DO itests = 1, 3 - IF (ionode .AND. output_unit > 0) & + IF (ionode .AND. output_unit > 0) THEN WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------" + END IF ! *** reference *** DO j = 1, Nprocs DO i = 1, Nloc diff --git a/src/mscfg_methods.F b/src/mscfg_methods.F index ee2a906e27..823de2c554 100644 --- a/src/mscfg_methods.F +++ b/src/mscfg_methods.F @@ -191,8 +191,10 @@ CONTAINS smear_almo_scf = qs_env%scf_control%smear%do_smear IF (smear_almo_scf) THEN scf_section => section_vals_get_subs_vals(dft_section, "SCF") - CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) !! Get total number of added MOs - tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 !! Get total number of atoms (assume consecutive atoms) + !! Get total number of added MOs + CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) + !! Get total number of atoms (assume consecutive atoms) + tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 !! Check that number of added MOs matches the number of atoms !! (to ensure compatibility, since each fragment will be computed with such parameters) IF (tot_isize /= tot_added_mos) THEN @@ -200,7 +202,8 @@ CONTAINS END IF !! Get total number of MOs CALL get_qs_env(qs_env, mos=mos) - IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") !! Unrestricted ALMO is not implemented yet + !! Unrestricted ALMO is not implemented yet + IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") CALL get_mo_set(mo_set=mos(1), nmo=nmo) !! Initialize storage of MO energies for ALMO smearing CPASSERT(ASSOCIATED(almo_scf_env)) diff --git a/src/mulliken.F b/src/mulliken.F index d1fe760821..0f77d12cf9 100644 --- a/src/mulliken.F +++ b/src/mulliken.F @@ -726,7 +726,7 @@ CONTAINS charges(i) = charges(i) + p_block(i, j)*s_block(i, j) END DO END DO - ELSEIF (iblock_col == iatom) THEN + ELSE IF (iblock_col == iatom) THEN DO j = 1, SIZE(p_block, 2) DO i = 1, SIZE(p_block, 1) charges(j) = charges(j) + p_block(i, j)*s_block(i, j) diff --git a/src/negf_control_types.F b/src/negf_control_types.F index 8d9c718239..0defb5e2e0 100644 --- a/src/negf_control_types.F +++ b/src/negf_control_types.F @@ -183,16 +183,19 @@ CONTAINS IF (ALLOCATED(negf_control%contacts)) THEN DO i = SIZE(negf_control%contacts), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) & + IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) THEN DEALLOCATE (negf_control%contacts(i)%atomlist_bulk) + END IF - IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) & + IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) THEN DEALLOCATE (negf_control%contacts(i)%atomlist_screening) + END IF IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell)) THEN DO j = SIZE(negf_control%contacts(i)%atomlist_cell), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) & + IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) THEN DEALLOCATE (negf_control%contacts(i)%atomlist_cell(j)%vector) + END IF END DO DEALLOCATE (negf_control%contacts(i)%atomlist_cell) END IF @@ -365,8 +368,9 @@ CONTAINS CALL section_vals_val_get(negf_section, "INTEGRATION_MIN_POINTS", i_val=negf_control%integr_min_points) CALL section_vals_val_get(negf_section, "INTEGRATION_MAX_POINTS", i_val=negf_control%integr_max_points) - IF (negf_control%integr_max_points < negf_control%integr_min_points) & + IF (negf_control%integr_max_points < negf_control%integr_min_points) THEN negf_control%integr_max_points = negf_control%integr_min_points + END IF CALL section_vals_val_get(negf_section, "MAX_SCF", i_val=negf_control%max_scf) @@ -428,8 +432,9 @@ CONTAINS DO i_rep = 1, n_rep IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN - IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) & + IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN natoms_total = natoms_total + SIZE(negf_control%contacts(i_rep)%atomlist_screening) + END IF END IF END DO diff --git a/src/negf_env_types.F b/src/negf_env_types.F index 7ddea351b0..f4d2564279 100644 --- a/src/negf_env_types.F +++ b/src/negf_env_types.F @@ -290,9 +290,10 @@ CONTAINS (icontact, sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, & para_env, negf_env, sub_env, negf_control, negf_section, log_unit, is_separate=.TRUE.) ELSE - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the separate bulk DFT calculation" + " from the separate bulk DFT calculation" + END IF CALL force_env_get(sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, qs_env=qs_env_contact) CALL qs_energies(qs_env_contact, consistent_energies=.FALSE., calc_forces=.FALSE.) CALL negf_env_contact_init_matrices(contact_env=negf_env%contacts(icontact), sub_env=sub_env, & @@ -314,9 +315,10 @@ CONTAINS CALL negf_env_contact_read_write_hs(icontact, force_env, para_env, negf_env, sub_env, negf_control, negf_section, & log_unit, is_separate=.FALSE., is_dft_entire=is_dft_entire) ELSE - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the entire system bulk DFT calculation" + " from the entire system bulk DFT calculation" + END IF IF (.NOT. is_dft_entire) CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) is_dft_entire = .TRUE. CALL negf_env_contact_init_matrices_gamma(contact_env=negf_env%contacts(icontact), & @@ -329,8 +331,9 @@ CONTAINS END DO ! stage 3: obtain an initial KS-matrix for the scattering region - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(/,T2,A,T70)') "NEGF| Construct the Kohn-Sham matrix for the scattering region" + END IF IF (negf_control%read_write_HS) THEN CALL negf_env_scatt_read_write_hs(force_env, para_env, negf_env, sub_env, negf_control, negf_section, log_unit, & is_dft_entire=is_dft_entire) @@ -915,18 +918,22 @@ CONTAINS CALL cp_abort(__LOCATION__, & "Primary and secondary bulk contact cells should not overlap ") ELSE IF (r2_origin_cell(1) < r2_origin_cell(2)) THEN - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(1)%vector))) + END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(1)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(2)%vector))) + END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(2)%vector(:) ELSE - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(2)%vector))) + END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(2)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(1)%vector))) + END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(1)%vector(:) END IF IF (.NOT. contact_control%read_write_HS) THEN @@ -1690,8 +1697,9 @@ CONTAINS natoms_cell0 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) & + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) THEN natoms_cell0 = natoms_cell0 + 1 + END IF END DO ALLOCATE (atomlist_cell0(natoms_cell0)) @@ -1771,8 +1779,9 @@ CONTAINS natoms_cell1 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) & + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) THEN natoms_cell1 = natoms_cell1 + 1 + END IF END DO ALLOCATE (atomlist_cell1(natoms_cell1)) diff --git a/src/negf_green_methods.F b/src/negf_green_methods.F index f7ff34dbbf..bc0d5076e0 100644 --- a/src/negf_green_methods.F +++ b/src/negf_green_methods.F @@ -363,8 +363,9 @@ CONTAINS ! omega * S_S - H_S - V_Hartree CALL cp_fm_to_cfm(msourcer=s_s, mtarget=g_ret_s) CALL cp_cfm_scale_and_add_fm(omega, g_ret_s, z_mone, h_s) - IF (PRESENT(v_hartree_s)) & + IF (PRESENT(v_hartree_s)) THEN CALL cp_cfm_scale_and_add_fm(z_one, g_ret_s, z_one, v_hartree_s) + END IF ! g_ret_s = [omega * S_S - H_S - \sum_{contact} self_energy_{contact}^{ret.} ]^-1 CALL cp_cfm_scale_and_add(z_one, g_ret_s, z_mone, self_energy_ret_sum) diff --git a/src/negf_integr_cc.F b/src/negf_integr_cc.F index c4facd0f4f..87d553d2c0 100644 --- a/src/negf_integr_cc.F +++ b/src/negf_integr_cc.F @@ -173,8 +173,9 @@ CONTAINS ! rescale all but the end-points, as they are transformed into themselves (-1.0 -> -1.0; 0.0 -> 0.0). ! Moreover, by applying this rescaling transformation to the end-points we cannot guarantee the exact ! result due to rounding errors in evaluation of COS function. - IF (nnodes_half > 2) & + IF (nnodes_half > 2) THEN CALL rescale_nodes_cos(nnodes_half - 2, cc_env%tnodes(2:)) + END IF SELECT CASE (interval_id) CASE (cc_interval_full) diff --git a/src/negf_integr_simpson.F b/src/negf_integr_simpson.F index 9d57abd95c..d732913bdf 100644 --- a/src/negf_integr_simpson.F +++ b/src/negf_integr_simpson.F @@ -312,8 +312,9 @@ CONTAINS END IF IF (nintervals > 0) THEN - IF (SIZE(xnodes_unity) < 4*nintervals) & + IF (SIZE(xnodes_unity) < 4*nintervals) THEN nintervals = SIZE(xnodes_unity)/4 + END IF DO interval = 1, nintervals xnodes_unity(4*interval - 3) = 0.125_dp* & @@ -553,14 +554,16 @@ CONTAINS DO interval = 1, nintervals_exist errors(interval) = subintervals(interval)%error - IF (subintervals(interval)%error > subintervals(interval)%conv) & + IF (subintervals(interval)%error > subintervals(interval)%conv) THEN nintervals = nintervals + 1 + END IF END DO CALL sort(errors, nintervals_exist, inds) - IF (nintervals > 0) & + IF (nintervals > 0) THEN ALLOCATE (sr_env%subintervals(nintervals)) + END IF nintervals = 0 DO ipoint = nintervals_exist, 1, -1 diff --git a/src/negf_integr_utils.F b/src/negf_integr_utils.F index 4cb86ead5f..82651f58fa 100644 --- a/src/negf_integr_utils.F +++ b/src/negf_integr_utils.F @@ -81,11 +81,9 @@ CONTAINS SELECT CASE (shape_id) CASE (contour_shape_linear) - IF (PRESENT(xnodes)) & - CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) + IF (PRESENT(xnodes)) CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) - IF (PRESENT(weights)) & - weights(:) = b - a + IF (PRESENT(weights)) weights(:) = b - a CASE (contour_shape_arc) ALLOCATE (tnodes_angle(nnodes)) @@ -93,8 +91,7 @@ CONTAINS tnodes_angle(:) = tnodes(:) CALL rescale_nodes_pi_phi(a, b, nnodes, tnodes_angle) - IF (PRESENT(xnodes)) & - CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) + IF (PRESENT(xnodes)) CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) IF (PRESENT(weights)) THEN rscale = (pi - get_arc_smallest_angle(a, b))*get_arc_radius(a, b) diff --git a/src/negf_matrix_utils.F b/src/negf_matrix_utils.F index 5b55feab07..5e957b06c3 100644 --- a/src/negf_matrix_utils.F +++ b/src/negf_matrix_utils.F @@ -342,8 +342,9 @@ CONTAINS DO ic = 1, ncell rep = i_to_c(direction_axis_abs, ic) - IF (ABS(rep) <= 2) & + IF (ABS(rep) <= 2) THEN CALL dbcsr_add(matrix_cells_raw(rep)%matrix, mat_nosym(ic)%matrix, 1.0_dp, 1.0_dp) + END IF END DO IF (direction_axis >= 0) THEN @@ -469,15 +470,17 @@ CONTAINS block=rblock, found=found) IF (found) THEN iproc = rank_contact(irow, icol) - IF (iproc > 0) & + IF (iproc > 0) THEN send_nelems(iproc) = send_nelems(iproc) + SIZE(rblock) + END IF END IF CALL dbcsr_get_block_p(matrix=matrix_contact, row=irow, col=icol, block=rblock, found=found) IF (found) THEN iproc = rank_device(irow, icol) - IF (iproc > 0) & + IF (iproc > 0) THEN recv_nelems(iproc) = recv_nelems(iproc) + SIZE(rblock) + END IF END IF END DO END DO @@ -485,14 +488,16 @@ CONTAINS ! pack blocks ALLOCATE (recv_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN ALLOCATE (recv_packed_blocks(iproc)%vector(recv_nelems(iproc))) + END IF END DO ALLOCATE (send_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (send_nelems(iproc) > 0) & + IF (send_nelems(iproc) > 0) THEN ALLOCATE (send_packed_blocks(iproc)%vector(send_nelems(iproc))) + END IF END DO send_nelems(:) = 0 @@ -556,15 +561,17 @@ CONTAINS CALL para_env%irecv(recv_packed_blocks(iproc)%vector, iproc - 1, recv_handlers(iproc), 1) END IF ELSE - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN CALL MOVE_ALLOC(send_packed_blocks(iproc)%vector, recv_packed_blocks(iproc)%vector) + END IF END IF END DO ! unpack blocks DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN CALL recv_handlers(iproc)%wait() + END IF END DO recv_nelems(:) = 0 @@ -601,22 +608,25 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) & + IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) THEN CALL send_handlers(iproc)%wait() + END IF END DO ! release memory DEALLOCATE (recv_handlers, send_handlers) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN DEALLOCATE (send_packed_blocks(iproc)%vector) + END IF END DO DEALLOCATE (send_packed_blocks) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) & + IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) THEN DEALLOCATE (recv_packed_blocks(iproc)%vector) + END IF END DO DEALLOCATE (recv_packed_blocks) @@ -744,8 +754,9 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN nomirror = nomirror + 1 + END IF END DO ! create the mirror imgs diff --git a/src/negf_methods.F b/src/negf_methods.F index 8fda96399e..8487a70d82 100644 --- a/src/negf_methods.F +++ b/src/negf_methods.F @@ -304,8 +304,9 @@ CONTAINS ! restart.hs ! ---------- - IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) & + IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) THEN CALL negf_write_restart(filename, negf_env, negf_control) + END IF ! current ! ------- @@ -965,8 +966,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_circular(ispin)) + END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_fm(ispin), & @@ -983,8 +985,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_linear(ispin)) + END IF END DO IF (nspins > 1) THEN @@ -1149,8 +1152,9 @@ CONTAINS END IF END IF - IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) & + IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) THEN CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) + END IF CALL get_qs_env(qs_env, blacs_env=blacs_env, do_kpoints=do_kpoints, dft_control=dft_control, & matrix_ks_kp=matrix_ks_qs_kp, para_env=para_env, rho=rho_struct, subsys=subsys) @@ -1395,8 +1399,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_circular(ispin)) + END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_new_fm(ispin), & @@ -1413,8 +1418,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_linear(ispin)) + END IF ! non-equilibrium part delta = 0.0_dp @@ -1439,8 +1445,9 @@ CONTAINS base_contact=base_contact, & matrix_s_global=matrix_s_fm, & g_surf_cache=g_surf_nonequiv(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_nonequiv(ispin)) + END IF END IF END DO @@ -2134,8 +2141,9 @@ CONTAINS DO ipoint = 1, npoints IF (ASSOCIATED(g_ret_s(ipoint)%matrix_struct)) THEN CALL cp_cfm_finish_copy_general(g_ret_s(ipoint), info1(ipoint)) - IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) & + IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) THEN CALL cp_cfm_cleanup_copy_general(info1(ipoint)) + END IF END IF END DO diff --git a/src/negf_subgroup_types.F b/src/negf_subgroup_types.F index e5efda48c6..2eb0b3a5a6 100644 --- a/src/negf_subgroup_types.F +++ b/src/negf_subgroup_types.F @@ -137,8 +137,9 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) & + IF (ALLOCATED(sub_env%group_distribution)) THEN DEALLOCATE (sub_env%group_distribution) + END IF sub_env%ngroups = 0 diff --git a/src/offload/offload_api.F b/src/offload/offload_api.F index e9f508ee05..c9c4b8c48c 100644 --- a/src/offload/offload_api.F +++ b/src/offload/offload_api.F @@ -158,8 +158,9 @@ CONTAINS device_id = offload_get_chosen_device_c() - IF (device_id < 0) & + IF (device_id < 0) THEN CPABORT("No offload device has been chosen.") + END IF END FUNCTION offload_get_chosen_device diff --git a/src/openpmd_api.F b/src/openpmd_api.F index 82de3ca08c..00265196e0 100644 --- a/src/openpmd_api.F +++ b/src/openpmd_api.F @@ -24,11 +24,14 @@ MODULE openpmd_api USE kinds, ONLY: default_string_length, dp, sp USE message_passing, ONLY: mp_comm_type #include "./base/base_uses.f90" +#endif IMPLICIT NONE PRIVATE +#ifdef __OPENPMD + INTEGER, PARAMETER :: openpmd_access_create = 0 INTEGER, PARAMETER :: openpmd_access_read_only = 1 @@ -259,7 +262,6 @@ MODULE openpmd_api #:for dim in dimensions PUBLIC :: openpmd_dynamic_memory_view_type_${dim}$d #:endfor - #endif CONTAINS @@ -1214,6 +1216,5 @@ MODULE openpmd_api CALL openpmd_c_mesh_set_unit_dimension(this%c_ptr, unitDimension) END SUBROUTINE openpmd_mesh_set_unit_dimension - #endif END MODULE openpmd_api diff --git a/src/optimize_basis.F b/src/optimize_basis.F index 813e9e52a9..9fbbeb1eb1 100644 --- a/src/optimize_basis.F +++ b/src/optimize_basis.F @@ -196,8 +196,9 @@ CONTAINS DO iopt = 0, opt_bas%powell_param%maxfun CALL compute_residuum_vectors(opt_bas, f_env_id, matrix_S_inv, tot_time, & para_env_top, para_env, iopt) - IF (para_env_top%is_source()) & + IF (para_env_top%is_source()) THEN CALL powell_optimize(opt_bas%powell_param%nvar, opt_bas%x_opt, opt_bas%powell_param) + END IF CALL para_env_top%bcast(opt_bas%powell_param%state) CALL para_env_top%bcast(opt_bas%x_opt) CALL update_free_vars(opt_bas) @@ -362,9 +363,10 @@ CONTAINS icomb = MOD(icalc - 1, opt_bas%ncombinations) opt_bas%powell_param%f = opt_bas%powell_param%f + & (f_vec(icalc) + energy(icalc))*opt_bas%fval_weight(icomb) - IF (opt_bas%use_condition_number) & + IF (opt_bas%use_condition_number) THEN opt_bas%powell_param%f = opt_bas%powell_param%f + & LOG(cond_vec(icalc))*opt_bas%condition_weight(icomb) + END IF END DO ELSE f_vec = 0.0_dp; cond_vec = 0.0_dp; my_time = 0.0_dp; energy = 0.0_dp @@ -560,8 +562,7 @@ CONTAINS END DO DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & - SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) END DO CALL timestop(handle) @@ -667,8 +668,9 @@ CONTAINS tot_time = tot_time + my_time unit_nr = -1 - IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) & + IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) THEN unit_nr = cp_logger_get_default_unit_nr(logger) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,I8)') "BASOPT| Information at iteration number:", iopt diff --git a/src/optimize_basis_types.F b/src/optimize_basis_types.F index ec2b96dff3..de46ed724b 100644 --- a/src/optimize_basis_types.F +++ b/src/optimize_basis_types.F @@ -177,8 +177,9 @@ CONTAINS IF (ALLOCATED(kind%deriv_info(iinfo)%in_use_set)) DEALLOCATE (kind%deriv_info(iinfo)%in_use_set) IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr)) THEN DO icont = 1, SIZE(kind%deriv_info(iinfo)%use_contr) - IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) & + IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) THEN DEALLOCATE (kind%deriv_info(iinfo)%use_contr(icont)%in_use) + END IF END DO DEALLOCATE (kind%deriv_info(iinfo)%use_contr) END IF @@ -190,22 +191,30 @@ CONTAINS DO ibasis = 0, SIZE(kind%flex_basis) - 1 IF (ALLOCATED(kind%flex_basis(ibasis)%subset)) THEN DO iset = 1, SIZE(kind%flex_basis(ibasis)%subset) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) & + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%l) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_coeff) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exps) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_exps) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_x_ind) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_const) + END IF END DO DEALLOCATE (kind%flex_basis(ibasis)%subset) END IF diff --git a/src/optimize_basis_utils.F b/src/optimize_basis_utils.F index 239226980e..0646e2fe77 100644 --- a/src/optimize_basis_utils.F +++ b/src/optimize_basis_utils.F @@ -83,8 +83,9 @@ CONTAINS CALL generate_initial_basis(kind_section, opt_bas, para_env) CALL section_vals_get(train_section, n_repetition=opt_bas%ntraining_sets) - IF (opt_bas%ntraining_sets == 0) & + IF (opt_bas%ntraining_sets == 0) THEN CPABORT("No training set was specified in the Input") + END IF ALLOCATE (opt_bas%training_input(opt_bas%ntraining_sets)) ALLOCATE (opt_bas%training_dir(opt_bas%ntraining_sets)) @@ -136,8 +137,9 @@ CONTAINS logger => cp_get_default_logger() unit_nr = -1 - IF (logger%para_env%is_source()) & + IF (logger%para_env%is_source()) THEN unit_nr = cp_logger_get_default_unit_nr(logger) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,A)') "BASOPT| Total number of calculations ", & @@ -294,14 +296,16 @@ CONTAINS CALL section_vals_val_get(optbas_section, "GROUP_PARTITION", i_vals=i_vals) isize = SIZE(i_vals) nptot = SUM(i_vals) - IF (nptot /= nproc) & + IF (nptot /= nproc) THEN CALL cp_abort(__LOCATION__, & "Number of processors in group distribution does not match number of MPI tasks."// & " Please change input.") - IF (.NOT. isize <= ncalc) & + END IF + IF (.NOT. isize <= ncalc) THEN CALL cp_abort(__LOCATION__, & "Number of Groups larger than number of calculations"// & " Please change input.") + END IF CPASSERT(nptot == nproc) ALLOCATE (opt_bas%comp_group(isize)) ALLOCATE (opt_bas%group_partition(0:isize - 1)) @@ -741,12 +745,14 @@ CONTAINS CALL section_vals_val_get(const_section, "USE_EXP", i_vals=def_exp, i_rep_section=irep) CALL section_vals_val_get(const_section, "BOUNDARIES", explicit=is_bound, i_rep_section=irep) CALL section_vals_val_get(const_section, "MAX_VAR_FRACTION", explicit=is_varlim, i_rep_section=irep) - IF (is_bound .AND. is_varlim) & + IF (is_bound .AND. is_varlim) THEN CALL cp_abort(__LOCATION__, "Exponent has two constraints. "// & "This is not possible at the moment. Please change input.") - IF (.NOT. is_bound .AND. .NOT. is_varlim) & + END IF + IF (.NOT. is_bound .AND. .NOT. is_varlim) THEN CALL cp_abort(__LOCATION__, "Exponent is declared to be constraint but none is given"// & " Please change input.") + END IF IF (def_exp(1) == -1) THEN DO iset = 1, flex_basis%nsets IF (def_exp(2) == -1) THEN @@ -754,27 +760,30 @@ CONTAINS CALL set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (def_exp(2) <= flex_basis%subset(iset)%nexp) & + IF (def_exp(2) <= flex_basis%subset(iset)%nexp) THEN CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") + END IF CALL set_constraint(flex_basis, iset, def_exp(2), const_section, is_bound, is_varlim, irep) END IF END DO ELSE - IF (.NOT. def_exp(1) <= flex_basis%nsets) & + IF (.NOT. def_exp(1) <= flex_basis%nsets) THEN CALL cp_abort(__LOCATION__, & "Set number of constraint is larger than number of sets in the template basis set."// & " Please change input.") + END IF IF (def_exp(2) == -1) THEN DO ipgf = 1, flex_basis%subset(iset)%nexp CALL set_constraint(flex_basis, def_exp(1), ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) & + IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) THEN CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") + END IF CALL set_constraint(flex_basis, def_exp(1), def_exp(2), const_section, is_bound, is_varlim, irep) END IF END IF @@ -805,10 +814,11 @@ CONTAINS REAL(KIND=dp) :: r_val REAL(KIND=dp), DIMENSION(:), POINTER :: r_vals - IF (flex_basis%subset(iset)%exp_has_const(ipgf)) & + IF (flex_basis%subset(iset)%exp_has_const(ipgf)) THEN CALL cp_abort(__LOCATION__, & "Multiple constraints due to collision in CONSTRAIN_EXPONENTS."// & " Please change input.") + END IF flex_basis%subset(iset)%exp_has_const(ipgf) = .TRUE. IF (is_bound) THEN flex_basis%subset(iset)%exp_const(ipgf)%const_type = 0 @@ -816,12 +826,13 @@ CONTAINS flex_basis%subset(iset)%exp_const(ipgf)%llim = MINVAL(r_vals) flex_basis%subset(iset)%exp_const(ipgf)%ulim = MAXVAL(r_vals) r_val = flex_basis%subset(iset)%exps(ipgf) - IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) & + IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) THEN CALL cp_abort(__LOCATION__, & "Exponent "//cp_to_string(r_val)// & " declared in constraint is out of bounds of constraint"//cp_to_string(MINVAL(r_vals))// & " to"//cp_to_string(MAXVAL(r_vals))// & " Please change input.") + END IF flex_basis%subset(iset)%exp_const(ipgf)%init = SUM(r_vals)/2.0_dp flex_basis%subset(iset)%exp_const(ipgf)%var_fac = MAXVAL(r_vals)/flex_basis%subset(iset)%exp_const(ipgf)%init - 1.0_dp END IF @@ -1139,8 +1150,7 @@ CONTAINS ! just to get an understandable basis normalize coefficients DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & - SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) END DO DEALLOCATE (r_val) diff --git a/src/optimize_embedding_potential.F b/src/optimize_embedding_potential.F index c36cbdd7aa..0c38b6568a 100644 --- a/src/optimize_embedding_potential.F +++ b/src/optimize_embedding_potential.F @@ -151,8 +151,9 @@ CONTAINS END DO ! Find out whether we need a spin-dependend embedding potential - IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) & + IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) THEN open_shell_embed = .TRUE. + END IF ! If it's open shell, we need to check spin states IF (open_shell_embed) THEN @@ -667,12 +668,14 @@ CONTAINS TYPE(opt_embed_pot_type) :: opt_embed ! Read the potential as a vector in the auxiliary basis - IF (opt_embed%read_embed_pot) & + IF (opt_embed%read_embed_pot) THEN CALL read_embed_pot_vector(qs_env, embed_pot, spin_embed_pot, section, & opt_embed%embed_pot_coef, opt_embed%open_shell_embed) + END IF ! Read the potential as a cube (two cubes for open shell) - IF (opt_embed%read_embed_pot_cube) & + IF (opt_embed%read_embed_pot_cube) THEN CALL read_embed_pot_cube(embed_pot, spin_embed_pot, section, opt_embed%open_shell_embed) + END IF END SUBROUTINE read_embed_pot @@ -695,8 +698,9 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CPABORT("Embedding cube file not found. ") + END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(embed_pot, filename, scaling_factor) @@ -706,8 +710,9 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_SPIN_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CPABORT("Embedding spin cube file not found. ") + END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(spin_embed_pot, filename, scaling_factor) @@ -784,8 +789,9 @@ CONTAINS READ (restart_unit) dimen_restart_basis ! Check the dimensions of the bases: the actual and the restart one - IF (.NOT. (dimen_restart_basis == dimen_aux)) & + IF (.NOT. (dimen_restart_basis == dimen_aux)) THEN CPABORT("Wrong dimension of the embedding basis in the restart file.") + END IF ALLOCATE (coef_read(dimen_var_aux)) coef_read = 0.0_dp @@ -844,8 +850,9 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_RESTART_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CPABORT("Embedding restart file not found. ") + END IF END SUBROUTINE embed_restart_file_name @@ -1505,14 +1512,16 @@ CONTAINS ELSE ! Finite basis optimization ! If the previous step has been rejected, we go back to the previous expansion coefficients - IF (.NOT. opt_embed%accept_step) & + IF (.NOT. opt_embed%accept_step) THEN CALL cp_fm_scale_and_add(1.0_dp, opt_embed%embed_pot_coef, -1.0_dp, opt_embed%step) + END IF ! Do a simple steepest descent IF (opt_embed%steep_desc) THEN - IF (opt_embed%i_iter > 2) & + IF (opt_embed%i_iter > 2) THEN opt_embed%trust_rad = Barzilai_Borwein(opt_embed%step, opt_embed%prev_step, & opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad) + END IF IF (ABS(opt_embed%trust_rad) > opt_embed%max_trad) THEN IF (opt_embed%trust_rad > 0.0_dp) THEN opt_embed%trust_rad = opt_embed%max_trad @@ -1530,9 +1539,11 @@ CONTAINS ! First, update the Hessian inverse if needed IF (opt_embed%i_iter > 1) THEN - IF (opt_embed%accept_step) & ! We don't update Hessian if the step has been rejected + IF (opt_embed%accept_step) THEN + ! We don't update Hessian if the step has been rejected CALL symm_rank_one_update(opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad, & opt_embed%step, opt_embed%prev_embed_pot_Hess, opt_embed%embed_pot_Hess) + END IF END IF ! Add regularization term to the Hessian @@ -2213,8 +2224,9 @@ CONTAINS ! If energy change is larger than the predicted one, increase trust radius twice ! Else (between 0 and 1) leave as it is, unless Newton step has been taken and if the step is less than max IF ((ener_ratio > 1.0_dp) .AND. (.NOT. opt_embed%newton_step) .AND. & - (opt_embed%trust_rad < opt_embed%max_trad)) & + (opt_embed%trust_rad < opt_embed%max_trad)) THEN opt_embed%trust_rad = 2.0_dp*opt_embed%trust_rad + END IF ELSE ! Energy decreases ! If the decrease is not too large we allow this step to be taken ! Otherwise, the step is rejected @@ -2222,8 +2234,9 @@ CONTAINS opt_embed%accept_step = .FALSE. END IF ! Trust radius is decreased 4 times unless it's smaller than the minimal allowed value - IF (opt_embed%trust_rad >= opt_embed%min_trad) & + IF (opt_embed%trust_rad >= opt_embed%min_trad) THEN opt_embed%trust_rad = 0.25_dp*opt_embed%trust_rad + END IF END IF IF (opt_embed%accept_step) opt_embed%last_accepted = opt_embed%i_iter diff --git a/src/optimize_input.F b/src/optimize_input.F index 318487e913..bf550ed1b4 100644 --- a/src/optimize_input.F +++ b/src/optimize_input.F @@ -525,8 +525,9 @@ CONTAINS n_frames_current = 0 NULLIFY (pos_traj, energy_traj, force_traj) filename = oi_env%fm_env%ref_traj_file_name - IF (filename == "") & + IF (filename == "") THEN CPABORT("The reference trajectory file name is empty") + END IF CALL parser_create(local_parser, filename, para_env=para_env) DO CALL parser_read_line(local_parser, 1, at_end=at_end) @@ -559,8 +560,9 @@ CONTAINS ! now force reference trajectory filename = oi_env%fm_env%ref_force_file_name - IF (filename == "") & + IF (filename == "") THEN CPABORT("The reference force file name is empty") + END IF CALL parser_create(local_parser, filename, para_env=para_env) DO iframe = 1, n_frames CALL parser_read_line(local_parser, 1) diff --git a/src/pair_potential_types.F b/src/pair_potential_types.F index ec797ee3f5..413632847a 100644 --- a/src/pair_potential_types.F +++ b/src/pair_potential_types.F @@ -641,10 +641,12 @@ CONTAINS potparm%at1 = 'NULL' potparm%at2 = 'NULL' potparm%rcutsq = 0.0_dp - IF (ASSOCIATED(potparm%pair_spline_data)) & + IF (ASSOCIATED(potparm%pair_spline_data)) THEN CALL spline_data_p_release(potparm%pair_spline_data) - IF (ASSOCIATED(potparm%spl_f)) & + END IF + IF (ASSOCIATED(potparm%spl_f)) THEN CALL spline_factor_release(potparm%spl_f) + END IF DO i = 1, SIZE(potparm%type) potparm%set(i)%rmin = not_initialized @@ -1049,8 +1051,9 @@ CONTAINS IF (PRESENT(istart)) l_start = istart IF (PRESENT(iend)) l_end = iend DO i = l_start, l_end - IF (.NOT. ASSOCIATED(source%pot(i)%pot)) & + IF (.NOT. ASSOCIATED(source%pot(i)%pot)) THEN CALL pair_potential_single_create(source%pot(i)%pot) + END IF CALL pair_potential_single_copy(source%pot(i)%pot, dest%pot(i)%pot) END DO END SUBROUTINE pair_potential_p_copy diff --git a/src/pair_potential_util.F b/src/pair_potential_util.F index bb0163846f..9e77235b32 100644 --- a/src/pair_potential_util.F +++ b/src/pair_potential_util.F @@ -109,7 +109,7 @@ CONTAINS index = INT(r/pot%set(j)%eam%drar) + 1 IF (index > pot%set(j)%eam%npoints) THEN index = pot%set(j)%eam%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = r - pot%set(j)%eam%rval(index) @@ -119,17 +119,17 @@ CONTAINS ELSE IF (pot%type(j) == b4_type) THEN IF (r <= pot%set(j)%buck4r%r1) THEN pp = pot%set(j)%buck4r%a*EXP(-pot%set(j)%buck4r%b*r) - ELSEIF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN + ELSE IF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly1 pp = pp + pot%set(j)%buck4r%poly1(n)*r**n END DO - ELSEIF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN + ELSE IF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly2 pp = pp + pot%set(j)%buck4r%poly2(n)*r**n END DO - ELSEIF (r > pot%set(j)%buck4r%r3) THEN + ELSE IF (r > pot%set(j)%buck4r%r3) THEN pp = -pot%set(j)%buck4r%c/r**6 END IF lvalue = pp @@ -139,7 +139,7 @@ CONTAINS IF (index2 > pot%set(j)%tab%npoints) THEN index2 = pot%set(j)%tab%npoints index1 = index2 - 1 - ELSEIF (index1 < 1) THEN + ELSE IF (index1 < 1) THEN index1 = 1 index2 = 2 END IF @@ -156,8 +156,9 @@ CONTAINS ELSE IF (pot%type(j) == gp_type) THEN pot%set(j)%gp%values(1) = r lvalue = evalf(pot%set(j)%gp%myid, pot%set(j)%gp%values) - IF (EvalErrType > 0) & + IF (EvalErrType > 0) THEN CPABORT("Error evaluating generic potential energy function") + END IF ELSE lvalue = 0.0_dp END IF @@ -189,7 +190,7 @@ CONTAINS fac = pot%z1*pot%z2/evolt ener_zbl = fac/r*(0.1818_dp*EXP(-3.2_dp*x) + 0.5099_dp*EXP(-0.9423_dp*x) + & 0.2802_dp*EXP(-0.4029_dp*x) + 0.02817_dp*EXP(-0.2016_dp*x)) - ELSEIF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN + ELSE IF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN ener_zbl = pot%zbl_poly(0) + pot%zbl_poly(1)*r + pot%zbl_poly(2)*r*r + pot%zbl_poly(3)*r*r*r + & pot%zbl_poly(4)*r*r*r*r + pot%zbl_poly(5)*r*r*r*r*r ELSE diff --git a/src/pao_io.F b/src/pao_io.F index 166da4d769..ac4c035268 100644 --- a/src/pao_io.F +++ b/src/pao_io.F @@ -121,8 +121,9 @@ CONTAINS END IF ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN CPABORT("Restart PAO parametrization does not match") + END IF ! check kinds DO ikind = 1, SIZE(kinds) @@ -130,13 +131,15 @@ CONTAINS END DO ! check number of atoms - IF (SIZE(positions, 1) /= natoms) & + IF (SIZE(positions, 1) /= natoms) THEN CPABORT("Number of atoms do not match") + END IF ! check atom2kind DO iatom = 1, natoms - IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) & + IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) THEN CPABORT("Restart atomic kinds do not match.") + END IF END DO ! check positions, warning only @@ -160,8 +163,9 @@ CONTAINS END IF CALL para_env%bcast(buffer) CALL dbcsr_get_block_p(matrix=pao%matrix_X, row=iatom, col=iatom, block=block_X, found=found) - IF (ASSOCIATED(block_X)) & + IF (ASSOCIATED(block_X)) THEN block_X = buffer + END IF DEALLOCATE (buffer) END DO @@ -212,8 +216,9 @@ CONTAINS ! check if file starts with proper header !TODO: introduce a more unique header READ (unit_nr, fmt=*) label, i1 - IF (TRIM(label) /= "Version") & + IF (TRIM(label) /= "Version") THEN CPABORT("PAO restart file appears to be corrupted.") + END IF IF (i1 /= file_format_version) CPABORT("Restart PAO file format version is wrong") DO WHILE (.TRUE.) @@ -340,8 +345,9 @@ CONTAINS atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) - IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) & + IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) THEN CPABORT("Some kinds are missing.") + END IF CALL get_atomic_kind(atomic_kind_set(ikind), z=z, name=name) CALL get_qs_kind(qs_kind_set(ikind), & @@ -350,20 +356,27 @@ CONTAINS pao_potentials=pao_potentials) CALL pao_param_count(pao, qs_env, ikind=ikind, nparams=nparams) - IF (pao_kind%nparams /= nparams) & + IF (pao_kind%nparams /= nparams) THEN CPABORT("Number of parameters do not match") - IF (TRIM(pao_kind%name) /= TRIM(name)) & + END IF + IF (TRIM(pao_kind%name) /= TRIM(name)) THEN CPABORT("Kind names do not match") - IF (pao_kind%z /= z) & + END IF + IF (pao_kind%z /= z) THEN CPABORT("Atomic numbers do not match") - IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) & + END IF + IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) THEN CPABORT("Primary Basis-set name does not match") - IF (pao_kind%prim_basis_size /= basis_set%nsgf) & + END IF + IF (pao_kind%prim_basis_size /= basis_set%nsgf) THEN CPABORT("Primary Basis-set size does not match") - IF (pao_kind%pao_basis_size /= pao_basis_size) & + END IF + IF (pao_kind%pao_basis_size /= pao_basis_size) THEN CPABORT("PAO basis size does not match") - IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) & + END IF + IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) THEN CPABORT("Number of PAO_POTENTIALS does not match") + END IF DO ipot = 1, SIZE(pao_potentials) IF (pao_kind%pao_potentials(ipot)%maxl /= pao_potentials(ipot)%maxl) THEN @@ -421,8 +434,9 @@ CONTAINS CALL para_env%max(unit_max) IF (unit_max > 0) THEN IF (pao%iw > 0) WRITE (pao%iw, '(A,A)') " PAO| Writing restart file." - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL write_restart_header(pao, qs_env, energy, unit_nr) + END IF CALL pao_write_diagonal_blocks(para_env, pao%matrix_X, "Xblock", unit_nr) @@ -463,8 +477,10 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) & ! catch corner-case + IF (SIZE(local_block) > 0) THEN + ! catch corner-case mpi_buffer(:, :) = local_block(:, :) + END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/pao_linpot_rotinv.F b/src/pao_linpot_rotinv.F index 91c735c395..12698d45c1 100644 --- a/src/pao_linpot_rotinv.F +++ b/src/pao_linpot_rotinv.F @@ -83,10 +83,12 @@ CONTAINS ! terms sensing neighboring atoms DO ipot = 1, npots pot_maxl = pao_potentials(ipot)%maxl ! maxl is taken from central atom - IF (pot_maxl < 0) & + IF (pot_maxl < 0) THEN CPABORT("ROTINV parametrization requires non-negative PAO_POTENTIAL%MAXL") - IF (MOD(pot_maxl, 2) /= 0) & + END IF + IF (MOD(pot_maxl, 2) /= 0) THEN CPABORT("ROTINV parametrization requires even-numbered PAO_POTENTIAL%MAXL") + END IF DO max_shell = 1, nshells DO min_shell = 1, max_shell DO lpot = 0, pot_maxl, 2 @@ -203,8 +205,9 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) & + IF (SIZE(jpao_potentials) /= npots) THEN CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") + END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom @@ -448,8 +451,9 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) & + IF (SIZE(jpao_potentials) /= npots) THEN CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") + END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom diff --git a/src/pao_main.F b/src/pao_main.F index db6fcac257..b4a61ce1ab 100644 --- a/src/pao_main.F +++ b/src/pao_main.F @@ -279,8 +279,9 @@ CONTAINS EXIT END IF - IF (MOD(icycle, pao%write_cycles) == 0) & - CALL pao_write_restart(pao, qs_env, energy) ! write an intermediate restart file + IF (MOD(icycle, pao%write_cycles) == 0) THEN + CALL pao_write_restart(pao, qs_env, energy) + END IF ! write an intermediate restart file END IF ! check for early abort without convergence? diff --git a/src/pao_methods.F b/src/pao_methods.F index 203df6946c..cdce9d2815 100644 --- a/src/pao_methods.F +++ b/src/pao_methods.F @@ -133,8 +133,9 @@ CONTAINS ! Load torch model. IF (LEN_TRIM(pao_model_file) > 0) THEN - IF (.NOT. ALLOCATED(pao%models)) & + IF (.NOT. ALLOCATED(pao%models)) THEN ALLOCATE (pao%models(SIZE(qs_kind_set))) + END IF CALL pao_model_load(pao, qs_env, ikind, pao_model_file, pao%models(ikind)) END IF @@ -290,8 +291,9 @@ CONTAINS CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind), pao_basis_size=M) CPASSERT(M > 0) - IF (blk_sizes_pri(iatom) < M) & + IF (blk_sizes_pri(iatom) < M) THEN CPABORT("PAO basis size exceeds primary basis size.") + END IF blk_sizes_aux(iatom) = M END DO @@ -554,8 +556,9 @@ CONTAINS CALL dbcsr_release(matrix_S_desym) - IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) & + IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) THEN CPABORT("Number of electrons wrong. Trace(PS) ="//cp_to_string(trace_PS)) + END IF CALL timestop(handle) END SUBROUTINE pao_check_trace_PS @@ -983,12 +986,15 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) "PAO| Adding forces." IF (pao%max_pao /= 0) THEN - IF (pao%penalty_strength /= 0.0_dp) & + IF (pao%penalty_strength /= 0.0_dp) THEN CPABORT("PAO forces require PENALTY_STRENGTH or MAX_PAO set to zero") - IF (pao%linpot_regu_strength /= 0.0_dp) & + END IF + IF (pao%linpot_regu_strength /= 0.0_dp) THEN CPABORT("PAO forces require LINPOT_REGULARIZATION_STRENGTH or MAX_PAO set to zero") - IF (pao%regularization /= 0.0_dp) & + END IF + IF (pao%regularization /= 0.0_dp) THEN CPABORT("PAO forces require REGULARIZATION or MAX_PAO set to zero") + END IF END IF CALL get_qs_env(qs_env, & @@ -999,11 +1005,13 @@ CONTAINS ALLOCATE (forces(natoms, 3)) CALL pao_calc_AB(pao, qs_env, ls_scf_env, gradient=.TRUE., forces=forces) ! without penalty terms - IF (SIZE(pao%ml_training_set) > 0) & + IF (SIZE(pao%ml_training_set) > 0) THEN CALL pao_ml_forces(pao, qs_env, pao%matrix_G, forces) + END IF - IF (ALLOCATED(pao%models)) & + IF (ALLOCATED(pao%models)) THEN CALL pao_model_forces(pao, qs_env, pao%matrix_G, forces) + END IF CALL para_env%sum(forces) DO iatom = 1, natoms diff --git a/src/pao_ml.F b/src/pao_ml.F index b711d54387..95de014193 100644 --- a/src/pao_ml.F +++ b/src/pao_ml.F @@ -95,8 +95,9 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO|ML| Initializing maschine learning...' - IF (pao%parameterization /= pao_rotinv_param) & + IF (pao%parameterization /= pao_rotinv_param) THEN CPABORT("PAO maschine learning requires ROTINV parametrization") + END IF CALL get_qs_env(qs_env, para_env=para_env, atomic_kind_set=atomic_kind_set) @@ -166,8 +167,9 @@ CONTAINS CALL pao_read_raw(filename, param, hmat, kinds, atom2kind, positions, xblocks, ml_range) ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN CPABORT("Restart PAO parametrization does not match") + END IF ! map read-in kinds onto kinds of this run CALL match_kinds(pao, qs_env, kinds, kindsmap) @@ -277,8 +279,9 @@ CONTAINS END DO END DO - IF (ANY(kindsmap < 1)) & + IF (ANY(kindsmap < 1)) THEN CPABORT("PAO: Could not match all kinds from training set") + END IF END SUBROUTINE match_kinds ! ************************************************************************************************** @@ -301,8 +304,10 @@ CONTAINS training_list => training_lists(ikind) IF (training_list%npoints > 0) CYCLE ! it's ok CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) - IF (pao_basis_size /= basis_set%nsgf) & ! if this kind has pao enabled... + IF (pao_basis_size /= basis_set%nsgf) THEN + ! if this kind has pao enabled... CPABORT("Found no training-points for kind: "//TRIM(training_list%kindname)) + END IF END DO END SUBROUTINE sanity_check @@ -343,10 +348,12 @@ CONTAINS ! figure out size of input and output inp_size = 0; out_size = 0 - IF (ALLOCATED(training_list%head%input)) & + IF (ALLOCATED(training_list%head%input)) THEN inp_size = SIZE(training_list%head%input) - IF (ALLOCATED(training_list%head%output)) & + END IF + IF (ALLOCATED(training_list%head%output)) THEN out_size = SIZE(training_list%head%output) + END IF CALL para_env%sum(inp_size) CALL para_env%sum(out_size) @@ -574,8 +581,9 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, "(A,E20.10,A,T71,I10)") " PAO|ML| max prediction variance:", & MAXVAL(variances), " for atom:", MAXLOC(variances) - IF (MAXVAL(variances) > pao%ml_tolerance) & + IF (MAXVAL(variances) > pao%ml_tolerance) THEN CPABORT("Variance of prediction above ML_TOLERANCE.") + END IF DEALLOCATE (variances) diff --git a/src/pao_ml_descriptor.F b/src/pao_ml_descriptor.F index a99b71053e..2550b05021 100644 --- a/src/pao_ml_descriptor.F +++ b/src/pao_ml_descriptor.F @@ -138,8 +138,9 @@ CONTAINS Rab = pbc(ra, rb, cell) CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=pao_descriptors) - IF (SIZE(pao_descriptors) /= ndesc) & + IF (SIZE(pao_descriptors) /= ndesc) THEN CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") + END IF weight = pao_descriptors(idesc)%weight beta = pao_descriptors(idesc)%beta CALL pao_calc_gaussian(basis_set, block_V=block_V, Rab=Rab, lpot=0, beta=beta, weight=weight) @@ -150,8 +151,9 @@ CONTAINS CALL diamat_all(V_evecs, V_evals) ! use eigenvalues of V_block as descriptor - IF (PRESENT(descriptor)) & + IF (PRESENT(descriptor)) THEN descriptor((idesc - 1)*N + 1:idesc*N) = V_evals(:) + END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN @@ -254,8 +256,9 @@ CONTAINS ! check if N was chosen large enough IF (natoms > N) THEN - IF (neighbor_dist(N + 1) < screening_radius) & + IF (neighbor_dist(N + 1) < screening_radius) THEN CPABORT("PAO heuristic for descriptor size broke down") + END IF END IF DO idesc = 1, ndesc @@ -273,8 +276,9 @@ CONTAINS CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=jpao_descriptors) CALL get_atomic_kind(particle_set(katom)%atomic_kind, kind_number=kkind) CALL get_qs_kind(qs_kind_set(kkind), pao_descriptors=kpao_descriptors) - IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) & + IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) THEN CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") + END IF jweight = jpao_descriptors(idesc)%weight jbeta = jpao_descriptors(idesc)%beta kweight = kpao_descriptors(idesc)%weight @@ -304,8 +308,9 @@ CONTAINS CALL diamat_all(S_evecs, S_evals) ! use eigenvalues of S_block as descriptor - IF (PRESENT(descriptor)) & + IF (PRESENT(descriptor)) THEN descriptor((idesc - 1)*N + 1:idesc*N) = S_evals(:) + END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN diff --git a/src/pao_ml_gaussprocess.F b/src/pao_ml_gaussprocess.F index b97e60b661..c73c250c12 100644 --- a/src/pao_ml_gaussprocess.F +++ b/src/pao_ml_gaussprocess.F @@ -112,8 +112,9 @@ CONTAINS ! calculate prediction's variance variance = kernel(pao%gp_scale, descriptor, descriptor) - DOT_PRODUCT(weights, cov) - IF (variance < 0.0_dp) & + IF (variance < 0.0_dp) THEN CPABORT("PAO gaussian process found negative variance") + END IF DEALLOCATE (cov, weights) END SUBROUTINE pao_ml_gp_predict diff --git a/src/pao_model.F b/src/pao_model.F index 01dc20903a..1fb7d10fcd 100644 --- a/src/pao_model.F +++ b/src/pao_model.F @@ -120,18 +120,24 @@ CONTAINS ! Check compatibility CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) CALL get_atomic_kind(atomic_kind_set(ikind), name=kind_name, z=z) - IF (model%version /= 2) & + IF (model%version /= 2) THEN CPABORT("Model version not supported.") - IF (TRIM(model%kind_name) /= TRIM(kind_name)) & + END IF + IF (TRIM(model%kind_name) /= TRIM(kind_name)) THEN CPABORT("Kind name does not match.") - IF (model%atomic_number /= z) & + END IF + IF (model%atomic_number /= z) THEN CPABORT("Atomic number does not match.") - IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) & + END IF + IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) THEN CPABORT("Primary basis set name does not match.") - IF (model%prim_basis_size /= basis_set%nsgf) & + END IF + IF (model%prim_basis_size /= basis_set%nsgf) THEN CPABORT("Primary basis set size does not match.") - IF (model%pao_basis_size /= pao_basis_size) & + END IF + IF (model%pao_basis_size /= pao_basis_size) THEN CPABORT("PAO basis size does not match.") + END IF CALL omp_init_lock(model%lock) CALL timestop(handle) diff --git a/src/pao_optimizer.F b/src/pao_optimizer.F index 6b5a46b663..63a5329dd7 100644 --- a/src/pao_optimizer.F +++ b/src/pao_optimizer.F @@ -48,8 +48,9 @@ CONTAINS CALL dbcsr_copy(pao%matrix_D_preconed, pao%matrix_D) END IF - IF (pao%optimizer == pao_opt_bfgs) & + IF (pao%optimizer == pao_opt_bfgs) THEN CALL pao_opt_init_bfgs(pao) + END IF END SUBROUTINE pao_opt_init @@ -85,11 +86,13 @@ CONTAINS CALL dbcsr_release(pao%matrix_D) CALL dbcsr_release(pao%matrix_G_prev) - IF (pao%precondition) & + IF (pao%precondition) THEN CALL dbcsr_release(pao%matrix_D_preconed) + END IF - IF (pao%optimizer == pao_opt_bfgs) & + IF (pao%optimizer == pao_opt_bfgs) THEN CALL dbcsr_release(pao%matrix_BFGS) + END IF END SUBROUTINE pao_opt_finalize diff --git a/src/pao_param_equi.F b/src/pao_param_equi.F index d0c64c33b3..4f81db62e7 100644 --- a/src/pao_param_equi.F +++ b/src/pao_param_equi.F @@ -49,8 +49,9 @@ CONTAINS SUBROUTINE pao_param_init_equi(pao) TYPE(pao_env_type), POINTER :: pao - IF (pao%precondition) & + IF (pao%precondition) THEN CPABORT("PAO preconditioning not supported for selected parametrization.") + END IF END SUBROUTINE pao_param_init_equi diff --git a/src/pao_param_exp.F b/src/pao_param_exp.F index f8a4897ba3..1aba9e19ac 100644 --- a/src/pao_param_exp.F +++ b/src/pao_param_exp.F @@ -104,8 +104,9 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) & + IF (pao%precondition) THEN CPABORT("PAO preconditioning not supported for selected parametrization.") + END IF CALL timestop(handle) END SUBROUTINE pao_param_init_exp diff --git a/src/pao_param_fock.F b/src/pao_param_fock.F index 023bbaae5c..9ffed6bbec 100644 --- a/src/pao_param_fock.F +++ b/src/pao_param_fock.F @@ -95,8 +95,10 @@ CONTAINS ! calculate homo-lumo gap (it's useful for detecting numerical issues) gap = HUGE(dp) - IF (m < n) & ! catch special case n==m + IF (m < n) THEN + ! catch special case n==m gap = H_evals(m + 1) - H_evals(m) + END IF IF (PRESENT(penalty)) THEN ! penalty terms: occupied and virtual eigenvalues repel each other @@ -164,8 +166,9 @@ CONTAINS M5 = MATMUL(MATMUL(block_N, M4), block_N) ! add regularization gradient - IF (PRESENT(penalty)) & + IF (PRESENT(penalty)) THEN M5 = M5 + 2.0_dp*pao%regularization*V + END IF ! symmetrize G = 0.5_dp*(M5 + TRANSPOSE(M5)) ! the final gradient diff --git a/src/pao_param_gth.F b/src/pao_param_gth.F index 31a8a8eda1..51fa85e990 100644 --- a/src/pao_param_gth.F +++ b/src/pao_param_gth.F @@ -123,8 +123,9 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) & + IF (pao%precondition) THEN CALL pao_param_gth_preconditioner(pao, qs_env, nterms) + END IF DEALLOCATE (row_blk_size, col_blk_size, nterms) CALL timestop(handle) @@ -208,8 +209,9 @@ CONTAINS CALL group%sum(block) CALL dbcsr_get_block_p(matrix=matrix_gth_overlap, row=iatom, col=jatom, block=block_overlap, found=found) - IF (ASSOCIATED(block_overlap)) & + IF (ASSOCIATED(block_overlap)) THEN block_overlap = block + END IF DEALLOCATE (block) END DO @@ -232,8 +234,9 @@ CONTAINS converged=converged) CALL dbcsr_release(matrix_gth_overlap) - IF (.NOT. converged) & + IF (.NOT. converged) THEN CPABORT("PAO: Sqrt of GTH-preconditioner did not converge.") + END IF CALL timestop(handle) END SUBROUTINE pao_param_gth_preconditioner @@ -381,8 +384,9 @@ CONTAINS DEALLOCATE (world_X, world_G) ! sum penalty energies across ranks - IF (PRESENT(penalty)) & + IF (PRESENT(penalty)) THEN CALL group%sum(penalty) + END IF ! print homo-lumo gap encountered by fock-layer CALL group%min(gaps) @@ -421,20 +425,24 @@ CONTAINS CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) CALL get_qs_kind(qs_kind_set(ikind), pao_potentials=pao_potentials) - IF (SIZE(pao_potentials) /= 1) & + IF (SIZE(pao_potentials) /= 1) THEN CPABORT("GTH parametrization requires exactly one PAO_POTENTIAL section per KIND") + END IF max_projector = pao_potentials(1)%max_projector maxl = pao_potentials(1)%maxl - IF (maxl < 0) & + IF (maxl < 0) THEN CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAXL") + END IF - IF (max_projector < 0) & + IF (max_projector < 0) THEN CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAX_PROJECTOR") + END IF - IF (MOD(maxl, 2) /= 0) & + IF (MOD(maxl, 2) /= 0) THEN CPABORT("GTH parametrization requires even-numbered PAO_POTENTIAL%MAXL") + END IF ncombis = (max_projector + 1)*(max_projector + 2)/2 nparams = ncombis*(maxl/2 + 1) diff --git a/src/pao_param_linpot.F b/src/pao_param_linpot.F index f4a1e21e2b..d32896a5ac 100644 --- a/src/pao_param_linpot.F +++ b/src/pao_param_linpot.F @@ -124,8 +124,9 @@ CONTAINS CALL pao_param_linpot_regularizer(pao) - IF (pao%precondition) & + IF (pao%precondition) THEN CALL pao_param_linpot_preconditioner(pao) + END IF CALL para_env%sync() ! ensure that timestop is not called too early @@ -445,19 +446,23 @@ CONTAINS CALL dbcsr_get_block_p(matrix=pao%matrix_V_terms, row=iatom, col=iatom, block=block_V_terms, found=found) CPASSERT(ASSOCIATED(block_V_terms)) nterms = SIZE(block_V_terms, 2) - IF (nterms > 0) & ! protect against corner-case of zero pao parameters + IF (nterms > 0) THEN + ! protect against corner-case of zero pao parameters vec_V = MATMUL(block_V_terms, block_X(:, 1)) + END IF block_V(1:n, 1:n) => vec_V(:) ! map vector into matrix ! symmetrize - IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) & + IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) THEN CPABORT("block_V not symmetric") + END IF block_V = 0.5_dp*(block_V + TRANSPOSE(block_V)) ! symmetrize exactly ! regularization energy ! protect against corner-case of zero pao parameters - IF (PRESENT(penalty) .AND. nterms > 0) & + IF (PRESENT(penalty) .AND. nterms > 0) THEN regu_energy = regu_energy + DOT_PRODUCT(block_X(:, 1), MATMUL(block_R, block_X(:, 1))) + END IF CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & gap=gaps(iatom), evals=evals(:, iatom)) @@ -473,16 +478,18 @@ CONTAINS !TODO: this 2nd call does double work. However, *sometimes* this branch is not taken. CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & M1=block_M1, G=block_M2, gap=gaps(iatom), evals=evals(:, iatom)) - IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) & + IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) THEN CPABORT("matrix not symmetric") + END IF ! gradient dE/dX IF (PRESENT(matrix_G)) THEN CALL dbcsr_get_block_p(matrix=matrix_G, row=iatom, col=iatom, block=block_G, found=found) CPASSERT(ASSOCIATED(block_G)) block_G(:, 1) = MATMUL(vec_M2, block_V_terms) - IF (PRESENT(penalty)) & - block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) ! regularization gradient + IF (PRESENT(penalty)) THEN + block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) + END IF ! regularization gradient END IF ! forced dE/dR diff --git a/src/pao_param_methods.F b/src/pao_param_methods.F index 010af4c056..37264fbec9 100644 --- a/src/pao_param_methods.F +++ b/src/pao_param_methods.F @@ -231,8 +231,9 @@ CONTAINS CALL group%max(delta_max) IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO| checked unitaryness, max delta:', delta_max - IF (delta_max > pao%check_unitary_tol) & + IF (delta_max > pao%check_unitary_tol) THEN CPABORT("Found bad unitaryness:"//cp_to_string(delta_max)) + END IF CALL timestop(handle) END SUBROUTINE pao_assert_unitary diff --git a/src/pao_types.F b/src/pao_types.F index 242f6095c4..1cb794451a 100644 --- a/src/pao_types.F +++ b/src/pao_types.F @@ -121,7 +121,8 @@ MODULE pao_types !> \var constants_ready set when stuff, which does not depend of atomic positions is ready !> \var need_initial_scf set when the initial density matrix is not self-consistend !> \var matrix_X parameters of pao basis, which eventually determine matrix_U. Uses diag_distribution. -!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. Uses diag_distribution. +!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. +!> Uses diag_distribution. !> \var matrix_H0 Diagonal blocks of core hamiltonian, uses diag_distribution !> \var matrix_Y selector matrix which translates between primary and pao basis. !> basically a block diagonal "rectangular identity matrix". Uses s_matrix-distribution. @@ -253,8 +254,9 @@ CONTAINS CALL dbcsr_release(pao%matrix_H0) DEALLOCATE (pao%ml_training_set) - IF (ALLOCATED(pao%ml_training_matrices)) & + IF (ALLOCATED(pao%ml_training_matrices)) THEN DEALLOCATE (pao%ml_training_matrices) + END IF IF (ALLOCATED(pao%models)) THEN DO i = 1, SIZE(pao%models) diff --git a/src/particle_methods.F b/src/particle_methods.F index e7336c66ad..97a88055d6 100644 --- a/src/particle_methods.F +++ b/src/particle_methods.F @@ -1184,10 +1184,12 @@ CONTAINS count_list(elem_seen) = 1 END IF END IF - IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) & + IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) THEN w_cif_type_symbol = LEN_TRIM(cif_type_symbol(iatom)) - IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) & + END IF + IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) THEN w_cif_label = LEN_TRIM(cif_label(iatom)) + END IF END DO atom_loop ! Determine the format of each line in cif considering width of cif_type_symbol and cif_label @@ -1260,9 +1262,10 @@ CONTAINS file_unit = cp_print_key_unit_nr(logger, input_section, "PRINT%FINAL_STRUCTURE", & file_status="REPLACE", file_form="FORMATTED", & extension=".xyz") - IF (file_unit > 0) & + IF (file_unit > 0) THEN CALL write_particle_coordinates(particle_set, file_unit, dump_extxyz, "POS", title, & cell=cell, unit_conv=unit_conv, print_kind=print_kind) + END IF END IF ! Write CIF @@ -1430,9 +1433,10 @@ CONTAINS CALL section_release(tmp_cell_section) CALL cp_print_key_finished_output(file_unit, logger, input_section, & "PRINT%FINAL_STRUCTURE") - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" + routineN//": Done!" + END IF CALL timestop(handle) diff --git a/src/pexsi_interface.F b/src/pexsi_interface.F index fccdf461da..e2d09937ab 100644 --- a/src/pexsi_interface.F +++ b/src/pexsi_interface.F @@ -108,17 +108,22 @@ CONTAINS IF (PRESENT(muMin0)) pexsi_options%options%muMin0 = muMin0 IF (PRESENT(muMax0)) pexsi_options%options%muMax0 = muMax0 IF (PRESENT(mu0)) pexsi_options%options%mu0 = mu0 - IF (PRESENT(muInertiaTolerance)) & + IF (PRESENT(muInertiaTolerance)) THEN pexsi_options%options%muInertiaTolerance = muInertiaTolerance - IF (PRESENT(muInertiaExpansion)) & + END IF + IF (PRESENT(muInertiaExpansion)) THEN pexsi_options%options%muInertiaExpansion = muInertiaExpansion - IF (PRESENT(muPEXSISafeGuard)) & + END IF + IF (PRESENT(muPEXSISafeGuard)) THEN pexsi_options%options%muPEXSISafeGuard = muPEXSISafeGuard - IF (PRESENT(numElectronPEXSITolerance)) & + END IF + IF (PRESENT(numElectronPEXSITolerance)) THEN pexsi_options%options%numElectronPEXSITolerance = numElectronPEXSITolerance + END IF IF (PRESENT(matrixType)) pexsi_options%options%matrixType = matrixType - IF (PRESENT(isSymbolicFactorize)) & + IF (PRESENT(isSymbolicFactorize)) THEN pexsi_options%options%isSymbolicFactorize = isSymbolicFactorize + END IF IF (PRESENT(ordering)) pexsi_options%options%ordering = ordering IF (PRESENT(rowOrdering)) pexsi_options%options%rowOrdering = rowOrdering IF (PRESENT(npSymbFact)) pexsi_options%options%npSymbFact = npSymbFact @@ -205,17 +210,22 @@ CONTAINS IF (PRESENT(muMin0)) muMin0 = pexsi_options%options%muMin0 IF (PRESENT(muMax0)) muMax0 = pexsi_options%options%muMax0 IF (PRESENT(mu0)) mu0 = pexsi_options%options%mu0 - IF (PRESENT(muInertiaTolerance)) & + IF (PRESENT(muInertiaTolerance)) THEN muInertiaTolerance = pexsi_options%options%muInertiaTolerance - IF (PRESENT(muInertiaExpansion)) & + END IF + IF (PRESENT(muInertiaExpansion)) THEN muInertiaExpansion = pexsi_options%options%muInertiaExpansion - IF (PRESENT(muPEXSISafeGuard)) & + END IF + IF (PRESENT(muPEXSISafeGuard)) THEN muPEXSISafeGuard = pexsi_options%options%muPEXSISafeGuard - IF (PRESENT(numElectronPEXSITolerance)) & + END IF + IF (PRESENT(numElectronPEXSITolerance)) THEN numElectronPEXSITolerance = pexsi_options%options%numElectronPEXSITolerance + END IF IF (PRESENT(matrixType)) matrixType = pexsi_options%options%matrixType - IF (PRESENT(isSymbolicFactorize)) & + IF (PRESENT(isSymbolicFactorize)) THEN isSymbolicFactorize = pexsi_options%options%isSymbolicFactorize + END IF IF (PRESENT(ordering)) ordering = pexsi_options%options%ordering IF (PRESENT(rowOrdering)) rowOrdering = pexsi_options%options%rowOrdering IF (PRESENT(npSymbFact)) npSymbFact = pexsi_options%options%npSymbFact @@ -281,8 +291,9 @@ CONTAINS CALL timeset(routineN, handle) cp_pexsi_plan_initialize = f_ppexsi_plan_initialize(comm%get_handle(), numProcRow, & numProcCol, outputFileIndex, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(comm) @@ -329,8 +340,9 @@ CONTAINS CALL f_ppexsi_load_real_hs_matrix(plan, pexsi_options%options, nrows, nnz, nnzLocal, & numColLocal, colptrLocal, rowindLocal, & HnzvalLocal, isSIdentity, SnzvalLocal, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) @@ -343,9 +355,11 @@ CONTAINS CPABORT("Requires linking to the PEXSI library.") ! MARK_USED macro does not work on assumed shape variables - IF (.FALSE.) THEN; DO + IF (.FALSE.) THEN + DO IF (colptrLocal(1) > rowindLocal(1) .OR. HnzvalLocal(1) > SnzvalLocal(1)) EXIT - END DO; END IF + END DO + END IF #endif END SUBROUTINE cp_pexsi_load_real_hs_matrix @@ -396,8 +410,9 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) @@ -440,8 +455,9 @@ CONTAINS CALL f_ppexsi_retrieve_real_dft_matrix(plan, DMnzvalLocal, EDMnzvalLocal, & FDMnzvalLocal, totalEnergyH, & totalEnergyS, totalFreeEnergy, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) @@ -470,8 +486,9 @@ CONTAINS CALL timeset(routineN, handle) CALL f_ppexsi_plan_finalize(plan, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) diff --git a/src/pexsi_methods.F b/src/pexsi_methods.F index dc9c429e67..3a8bb968b2 100644 --- a/src/pexsi_methods.F +++ b/src/pexsi_methods.F @@ -146,8 +146,9 @@ CONTAINS pexsi_env%num_ranks_per_pole = min_ranks_per_pole ! not a PEXSI option pexsi_env%csr_screening = csr_screening - IF (numElectronInitialTolerance < numElectronTargetTolerance) & + IF (numElectronInitialTolerance < numElectronTargetTolerance) THEN numElectronInitialTolerance = numElectronTargetTolerance + END IF pexsi_env%tol_nel_initial = numElectronInitialTolerance pexsi_env%tol_nel_target = numElectronTargetTolerance @@ -337,20 +338,24 @@ CONTAINS IF (first_call) THEN ! Assertion that matrices have the expected symmetry (both should be symmetric if no ! S preconditioning and no molecular clustering) - IF (.NOT. dbcsr_has_symmetry(matrix_ks)) & + IF (.NOT. dbcsr_has_symmetry(matrix_ks)) THEN CPABORT("PEXSI interface expects a non-symmetric DBCSR Kohn-Sham matrix") - IF (.NOT. dbcsr_has_symmetry(matrix_s)) & + END IF + IF (.NOT. dbcsr_has_symmetry(matrix_s)) THEN CPABORT("PEXSI interface expects a non-symmetric DBCSR overlap matrix") + END IF ! Assertion on datatype IF ((pexsi_env%csr_mat_s%nzval_local%data_type /= dbcsr_csr_type_real_8) & - .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) & + .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) THEN CPABORT("Complex data type not supported by PEXSI") + END IF ! Assertion on number of non-zero elements !(TODO: update when PEXSI changes to Long Int) - IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) & + IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) THEN CPABORT("Total number of non-zero elements of CSR matrix is too large to be handled by PEXSI") + END IF END IF CALL dbcsr_get_info(matrix_ks, distribution=dist) @@ -464,8 +469,9 @@ CONTAINS n_total_inertia_iter END IF - IF (.NOT. pexsi_convergence) & + IF (.NOT. pexsi_convergence) THEN CPABORT("PEXSI did not converge. Consider logPEXSI0 for more information.") + END IF ! Retrieve results from PEXSI IF (mynode < pexsi_env%mp_dims(1)*pexsi_env%mp_dims(2)) THEN diff --git a/src/pilaenv_hack.F b/src/pilaenv_hack.F index 4b59ed9474..89d89b4d54 100644 --- a/src/pilaenv_hack.F +++ b/src/pilaenv_hack.F @@ -18,6 +18,8 @@ !> \return ... ! ************************************************************************************************** INTEGER FUNCTION PILAENV(ICTXT, PREC) + IMPLICIT NONE + INTEGER :: ICTXT CHARACTER(LEN=1) :: PREC @@ -29,5 +31,5 @@ END FUNCTION PILAENV !> \brief ... ! ************************************************************************************************** SUBROUTINE NAG_dummy() - + IMPLICIT NONE END SUBROUTINE NAG_dummy diff --git a/src/pme.F b/src/pme.F index d6703d8124..6470a00c8b 100644 --- a/src/pme.F +++ b/src/pme.F @@ -358,7 +358,7 @@ CONTAINS fgcore_coulomb(2, particle_set(p2)%shell_index) - fat(2)*dvols fgcore_coulomb(3, particle_set(p2)%shell_index) = & fgcore_coulomb(3, particle_set(p2)%shell_index) - fat(3)*dvols - ELSEIF (p2 /= 0) THEN + ELSE IF (p2 /= 0) THEN CALL dg_sum_patch_force_3d(drpot, rhos2, exp_igr%centre(:, p2), fat) fg_coulomb(1, p2) = fg_coulomb(1, p2) - fat(1)*dvols fg_coulomb(2, p2) = fg_coulomb(2, p2) - fat(2)*dvols @@ -505,7 +505,7 @@ CONTAINS ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) - ELSEIF (my_is1_core) THEN + ELSE IF (my_is1_core) THEN center1 => exp_igr%core_centre(:, particle_set(p1)%shell_index) ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) @@ -545,7 +545,7 @@ CONTAINS ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) - ELSEIF (my_is2_core) THEN + ELSE IF (my_is2_core) THEN center2 => exp_igr%core_centre(:, particle_set(p2)%shell_index) ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) @@ -633,7 +633,7 @@ CONTAINS ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) ez1 => exp_igr%core_ez(:, particle_set(p1)%shell_index) - ELSEIF (my_is1_shell) THEN + ELSE IF (my_is1_shell) THEN ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) @@ -659,7 +659,7 @@ CONTAINS ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) ez2 => exp_igr%core_ez(:, particle_set(p2)%shell_index) - ELSEIF (my_is2_shell) THEN + ELSE IF (my_is2_shell) THEN ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) diff --git a/src/population_analyses.F b/src/population_analyses.F index 2a0988a05a..715eeac5bf 100644 --- a/src/population_analyses.F +++ b/src/population_analyses.F @@ -187,10 +187,11 @@ CONTAINS ! Build full S^(1/2) matrix (computationally expensive) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) & + IF (ndep /= 0) THEN CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") + END IF ! Build Lowdin population matrix for each spin DO ispin = 1, nspin diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index 2a0cc28187..09ae1f3d75 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -1938,8 +1938,9 @@ CONTAINS CALL bs_env%para_env%max(z_end_global) n_z = z_end_global - z_start_global + 1 - IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) & + IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) THEN CPABORT("Please choose a cell that has 90° angles to the z-direction.") + END IF ! for integration, we need the dz and the conversion from H -> eV and a_Bohr -> Å bs_env%unit_ldos_int_z_inv_Ang2_eV = bs_env%hmat(3, 3)/REAL(n_z, KIND=dp)/evolt/angstrom**2 diff --git a/src/preconditioner.F b/src/preconditioner.F index 69d1ad3509..15bbe74ebe 100644 --- a/src/preconditioner.F +++ b/src/preconditioner.F @@ -137,8 +137,9 @@ CONTAINS ! Thanks to the mess with the matrices we need to make sure in this case that the ! Previous inverse is properly stored as a sparse matrix, fm gets deallocated here ! if it wasn't anyway - IF (preconditioner_env%solver == ot_precond_solver_update) & + IF (preconditioner_env%solver == ot_precond_solver_update) THEN CALL transfer_fm_to_dbcsr(preconditioner_env%fm, preconditioner_env%dbcsr_matrix, matrix_h) + END IF needs_full_spectrum = .FALSE. needs_homo = .FALSE. @@ -261,7 +262,8 @@ CONTAINS DEALLOCATE (preconditioner(ispin)%preconditioner) END DO DEALLOCATE (preconditioner) - CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, ot_precond_full_single_inverse) ! these are 'independent' + CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, & + ot_precond_full_single_inverse) ! these are 'independent' ! do nothing CASE DEFAULT CPABORT("Unknown preconditioner type") @@ -388,7 +390,7 @@ CONTAINS co_rotate=qs_env%mo_derivs(ispin)%matrix, & para_env=para_env, & blacs_env=blacs_env) - ELSEIF (use_mo_coeff_b) THEN + ELSE IF (use_mo_coeff_b) THEN CALL calculate_subspace_eigenvalues(mo_coeff_b, matrix_ks(ispin)%matrix, & do_rotation=.TRUE., & para_env=para_env, & diff --git a/src/preconditioner_apply.F b/src/preconditioner_apply.F index 0316f37bc9..e567636e74 100644 --- a/src/preconditioner_apply.F +++ b/src/preconditioner_apply.F @@ -167,8 +167,9 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) & + IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) THEN CPABORT("NOT ASSOCIATED preconditioner_env%dbcsr_matrix") + END IF CALL dbcsr_multiply('N', 'N', 1.0_dp, preconditioner_env%dbcsr_matrix, matrix_in, & 0.0_dp, matrix_out) diff --git a/src/preconditioner_makes.F b/src/preconditioner_makes.F index c83f6ce23e..4dae5616cb 100644 --- a/src/preconditioner_makes.F +++ b/src/preconditioner_makes.F @@ -93,8 +93,9 @@ CONTAINS precon_type = preconditioner_env%in_use SELECT CASE (precon_type) CASE (ot_precond_full_single) - IF (my_solver_type /= ot_precond_solver_default) & + IF (my_solver_type /= ot_precond_solver_default) THEN CPABORT("Only PRECOND_SOLVER DEFAULT for the moment") + END IF IF (PRESENT(matrix_s)) THEN CALL make_full_single(preconditioner_env, preconditioner_env%fm, & matrix_h, matrix_s, energy_homo, energy_gap) @@ -105,14 +106,16 @@ CONTAINS CASE (ot_precond_s_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. PRESENT(matrix_s)) & + IF (.NOT. PRESENT(matrix_s)) THEN CPABORT("Type for S=1 not implemented") + END IF CALL make_full_s_inverse(preconditioner_env, matrix_s) CASE (ot_precond_full_kinetic) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) & + IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) THEN CPABORT("Type for S=1 not implemented") + END IF CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap) CASE (ot_precond_full_single_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol @@ -745,8 +748,9 @@ CONTAINS matrices(1)%matrix => dbcsr_cThc CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=1.0E-3_dp, selection_crit=2, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) - IF (ASSOCIATED(preconditioner_env%max_ev_vector)) & + IF (ASSOCIATED(preconditioner_env%max_ev_vector)) THEN CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%max_ev_vector) + END IF CALL arnoldi_ev(matrices, arnoldi_env) max_ev = REAL(get_selected_ritz_val(arnoldi_env, 1), dp) @@ -776,8 +780,9 @@ CONTAINS CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=2.0E-2_dp, selection_crit=3, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) END IF - IF (ASSOCIATED(preconditioner_env%min_ev_vector)) & + IF (ASSOCIATED(preconditioner_env%min_ev_vector)) THEN CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%min_ev_vector) + END IF ! compute the LUMO energy CALL arnoldi_ev(matrices, arnoldi_env) diff --git a/src/preconditioner_solvers.F b/src/preconditioner_solvers.F index 21834c0f22..92670b6114 100644 --- a/src/preconditioner_solvers.F +++ b/src/preconditioner_solvers.F @@ -91,8 +91,9 @@ CONTAINS ! make sure preconditioner_env is not destroyed in between occ_matrix = 1.0_dp IF (ASSOCIATED(preconditioner_env%sparse_matrix)) THEN - IF (preconditioner_env%condition_num < 0.0_dp) & + IF (preconditioner_env%condition_num < 0.0_dp) THEN CALL estimate_cond_num(preconditioner_env%sparse_matrix, preconditioner_env%condition_num) + END IF CALL dbcsr_filter(preconditioner_env%sparse_matrix, & 1.0_dp/preconditioner_env%condition_num*0.01_dp) occ_matrix = dbcsr_get_occupation(preconditioner_env%sparse_matrix) diff --git a/src/pw/dgs.F b/src/pw/dgs.F index 6f47d09e24..3124a68eb4 100644 --- a/src/pw/dgs.F +++ b/src/pw/dgs.F @@ -420,7 +420,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(1)) THEN + ELSE IF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -433,7 +433,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(2)) THEN + ELSE IF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -446,7 +446,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(3)) THEN + ELSE IF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -495,7 +495,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(1)) THEN + ELSE IF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -508,7 +508,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(2)) THEN + ELSE IF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -521,7 +521,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(3)) THEN + ELSE IF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -572,7 +572,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%npts_local(1)) THEN + ELSE IF (ii >= drpot(1)%npts_local(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%npts_local(1) + 1 folded = .TRUE. ELSE @@ -585,7 +585,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%npts_local(2)) THEN + ELSE IF (ii >= drpot(1)%npts_local(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%npts_local(2) + 1 folded = .TRUE. ELSE @@ -598,7 +598,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%npts_local(3)) THEN + ELSE IF (ii >= drpot(1)%npts_local(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%npts_local(3) + 1 folded = .TRUE. ELSE @@ -651,7 +651,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(1)) THEN + ELSE IF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%npts_local(1) + 1 folded = .TRUE. ELSE @@ -664,7 +664,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(2)) THEN + ELSE IF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%npts_local(2) + 1 folded = .TRUE. ELSE @@ -677,7 +677,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(3)) THEN + ELSE IF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%npts_local(3) + 1 folded = .TRUE. ELSE @@ -724,7 +724,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%desc%npts(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%desc%npts(1)) THEN + ELSE IF (ii >= drpot(1)%desc%npts(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -737,7 +737,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%desc%npts(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%desc%npts(2)) THEN + ELSE IF (ii >= drpot(1)%desc%npts(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -750,7 +750,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%desc%npts(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%desc%npts(3)) THEN + ELSE IF (ii >= drpot(1)%desc%npts(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%desc%npts(3) + 1 folded = .TRUE. ELSE @@ -798,7 +798,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%desc%npts(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(1)) THEN + ELSE IF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -811,7 +811,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%desc%npts(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(2)) THEN + ELSE IF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -824,7 +824,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%desc%npts(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(3)) THEN + ELSE IF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%desc%npts(3) + 1 folded = .TRUE. ELSE diff --git a/src/pw/dirichlet_bc_methods.F b/src/pw/dirichlet_bc_methods.F index 6dc8e30b92..69499538b4 100644 --- a/src/pw/dirichlet_bc_methods.F +++ b/src/pw/dirichlet_bc_methods.F @@ -905,7 +905,7 @@ CONTAINS END SELECT alpha = linspace(0.0_dp, 2*pi, n_dbcs + 1) - alpha_rotd = alpha + delta_alpha; + alpha_rotd = alpha + delta_alpha SELECT CASE (parallel_axis) CASE (x_axis) DO j = 1, n_dbcs @@ -1180,7 +1180,7 @@ CONTAINS IF (direction == FWROT) THEN vec_tmp = MATMUL(Rmat, vec) vec_transfd = vec_tmp + Tp - ELSEIF (direction == BWROT) THEN + ELSE IF (direction == BWROT) THEN Rmat_inv = inv_3x3(Rmat) Tpoint(1) = Rmat_inv(1, 1)*Tp(1) + Rmat_inv(1, 2)*Tp(2) + Rmat_inv(1, 3)*Tp(3) Tpoint(2) = Rmat_inv(2, 1)*Tp(1) + Rmat_inv(2, 2)*Tp(2) + Rmat_inv(2, 3)*Tp(3) diff --git a/src/pw/fft/fftw3_lib.F b/src/pw/fft/fftw3_lib.F index b71f789160..08de4d3143 100644 --- a/src/pw/fft/fftw3_lib.F +++ b/src/pw/fft/fftw3_lib.F @@ -162,9 +162,10 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_export_wisdom_to_filename(wisdom_file_name_c) - IF (isuccess == 0) & + IF (isuccess == 0) THEN CALL cp_warn(__LOCATION__, "Error exporting wisdom to file "//TRIM(wisdom_file)//". "// & "Wisdom was not exported.") + END IF END IF END IF @@ -191,8 +192,9 @@ CONTAINS LOGICAL :: file_exists isuccess = fftw_init_threads() - IF (isuccess == 0) & + IF (isuccess == 0) THEN CPABORT("Error initializing FFTW with threads") + END IF ! Read FFTW wisdom (if available) ! all nodes are opening the file here... @@ -212,10 +214,11 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_import_wisdom_from_filename(wisdom_file_name_c) - IF (isuccess == 0) & + IF (isuccess == 0) THEN CALL cp_warn(__LOCATION__, "Error importing wisdom from file "//TRIM(wisdom_file)//". "// & "Maybe the file was created with a different configuration than CP2K is run with. "// & "CP2K continues without importing wisdom.") + END IF END IF END IF #else @@ -1039,7 +1042,7 @@ CONTAINS IF (plan%fsign == +1 .AND. plan%trans) THEN istride = plan%m idist = 1 - ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN + ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN ostride = plan%m odist = 1 END IF @@ -1161,7 +1164,7 @@ CONTAINS !$ out_offset = 1 + plan%num_rows*my_id*plan%n !$ IF (plan%fsign == +1 .AND. plan%trans) THEN !$ in_offset = 1 + plan%num_rows*my_id -!$ ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN +!$ ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN !$ out_offset = 1 + plan%num_rows*my_id !$ END IF !$ scal_offset = 1 + plan%n*plan%num_rows*my_id diff --git a/src/pw/fft/mltfftsg_tools.F b/src/pw/fft/mltfftsg_tools.F index a81b903ac7..c1a5b01d5b 100644 --- a/src/pw/fft/mltfftsg_tools.F +++ b/src/pw/fft/mltfftsg_tools.F @@ -15,7 +15,10 @@ MODULE mltfftsg_tools #include "../../base/base_uses.f90" + IMPLICIT NONE + PRIVATE + INTEGER, PARAMETER :: ctrig_length = 1024 INTEGER, PARAMETER :: cache_size = 2048 PUBLIC :: mltfftsg diff --git a/src/pw/fft_tools.F b/src/pw/fft_tools.F index 3f05511557..0c0940b882 100644 --- a/src/pw/fft_tools.F +++ b/src/pw/fft_tools.F @@ -1135,7 +1135,7 @@ CONTAINS END IF END IF - ELSEIF (sign == BWFFT) THEN + ELSE IF (sign == BWFFT) THEN ! Stage 3 -> 1 bbuf => fft_scratch%a5buf @@ -1217,7 +1217,7 @@ CONTAINS CALL release_fft_scratch(fft_scratch) - ELSEIF (DIM(2) == 1) THEN + ELSE IF (DIM(2) == 1) THEN ! ! Second case; one stage of communication @@ -1277,7 +1277,7 @@ CONTAINS END IF END IF - ELSEIF (sign == BWFFT) THEN + ELSE IF (sign == BWFFT) THEN ! Stage 3 -> 1 IF (test) THEN diff --git a/src/pw/mt_util.F b/src/pw/mt_util.F index 148c8f3b92..365f65c469 100644 --- a/src/pw/mt_util.F +++ b/src/pw/mt_util.F @@ -110,8 +110,9 @@ CONTAINS g3d = fourpi/g2 screen_function%array(ig) = screen_function%array(ig) - g3d*EXP(-g2/(4.0E0_dp*alpha2)) END DO - IF (screen_function%pw_grid%have_g0) & + IF (screen_function%pw_grid%have_g0) THEN screen_function%array(1) = screen_function%array(1) + fourpi/(4.0E0_dp*alpha2) + END IF CASE (MT2D) iz = special_dimension ! iz is the direction with NO PBC zlength = slab_size ! zlength is the thickness of the cell diff --git a/src/pw/ps_implicit_methods.F b/src/pw/ps_implicit_methods.F index 705f5bbde2..ba575985e8 100644 --- a/src/pw/ps_implicit_methods.F +++ b/src/pw/ps_implicit_methods.F @@ -274,8 +274,9 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -286,8 +287,9 @@ CONTAINS END DO CALL ps_implicit_print_convergence_msg(iter, max_iter, outp_unit) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN CALL pw_copy(v_new, ps_implicit_env%initial_guess) + END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -439,8 +441,9 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -454,8 +457,9 @@ CONTAINS CALL pw_shrink(neumann_directions, dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_local_shftd, v_new_xpndd, v_new) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN CALL pw_copy(v_new_xpndd, ps_implicit_env%initial_guess) + END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -705,8 +709,9 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -994,8 +999,9 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -1249,13 +1255,15 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) & + IF (info /= 0) THEN CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") + END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Inversion of R failed!") + END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) CALL pw_pool_release(pw_pool_xpndd) @@ -1378,13 +1386,15 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) & + IF (info /= 0) THEN CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") + END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Inversion of R failed!") + END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) diff --git a/src/pw/ps_wavelet_base.F b/src/pw/ps_wavelet_base.F index 2a9fc0f9b0..ad7d3efa69 100644 --- a/src/pw/ps_wavelet_base.F +++ b/src/pw/ps_wavelet_base.F @@ -12,6 +12,7 @@ MODULE ps_wavelet_base USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_fft3d, ONLY: ctrig,& ctrig_length,& @@ -705,9 +706,8 @@ CONTAINS REAL(KIND=dp), INTENT(in) :: hx, hy, hz INTEGER :: i1, i2, j1, j2, j3 - REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2, pi + REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2 - pi = 4._dp*ATAN(1._dp) fourpi2 = 4._dp*pi**2 j3 = i3 !n3/2+1-abs(n3/2+2-i3) mu3 = REAL(j3 - 1, KIND=dp)/REAL(n3, KIND=dp) diff --git a/src/pw/ps_wavelet_fft3d.F b/src/pw/ps_wavelet_fft3d.F index 2381556718..cf470a0206 100644 --- a/src/pw/ps_wavelet_fft3d.F +++ b/src/pw/ps_wavelet_fft3d.F @@ -112,15 +112,14 @@ CONTAINS ! Different factorizations affect the performance ! Factoring 64 as 4*4*4 might for example be faster on some machines than 8*8. INTEGER :: n - REAL(KIND=dp) :: trig - INTEGER :: after, before, now, isign, ic + REAL(KIND=dp) :: trig(2, ctrig_length) + INTEGER :: after(7), before(7), now(7), isign, ic CHARACTER(LEN=888) :: err INTEGER :: i, itt, j, nh + INTEGER, DIMENSION(7, 149) :: idata REAL(KIND=dp) :: angle, trigc, trigs, twopi - DIMENSION now(7), after(7), before(7), trig(2, ctrig_length) - INTEGER, DIMENSION(7, 149) :: idata ! The factor 6 is only allowed in the first place! DATA((idata(i, j), i=1, 7), j=1, 76)/ & 3, 3, 1, 1, 1, 1, 1, 4, 4, 1, 1, 1, 1, 1, & @@ -285,7 +284,8 @@ CONTAINS ! GNU General Public License, see http://www.gnu.org/copyleft/gpl.txt . INTEGER :: mm, nfft, m, nn, n - REAL(KIND=dp) :: zin, zout, trig + REAL(KIND=dp) :: zin(2, mm, m), zout(2, nn, n), & + trig(2, ctrig_length) INTEGER :: after, now, before, isign INTEGER :: atb, atn, ia, ias, ib, itrig, itt, j, & @@ -297,7 +297,6 @@ CONTAINS rt2i, s, s1, s2, s25, s3, s34, s4, s5, s6, s7, s8, sin2, sin4, ui1, ui2, ui3, ur1, ur2, & ur3, vi1, vi2, vi3, vr1, vr2, vr3 - DIMENSION trig(2, ctrig_length), zin(2, mm, m), zout(2, nn, n) atn = after*now atb = after*before @@ -321,7 +320,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO DO 2000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -342,7 +342,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -360,7 +361,8 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO; END DO + END DO + END DO END IF ELSE IF (4*ias == after) THEN IF (isign == 1) THEN @@ -382,7 +384,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -402,7 +405,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO END IF ELSE IF (4*ias == 3*after) THEN IF (isign == 1) THEN @@ -424,7 +428,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -444,7 +449,8 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO; END DO + END DO + END DO END IF ELSE itrig = ias*before + 1 @@ -468,7 +474,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO END IF 2000 CONTINUE ELSE IF (now == 4) THEN @@ -510,7 +517,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO DO 4000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -554,7 +562,8 @@ CONTAINS s = r2 + r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO ELSE itt = ias*before itrig = itt + 1 @@ -608,7 +617,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO END IF 4000 CONTINUE ELSE @@ -649,7 +659,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO; END DO + END DO + END DO DO 4100, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -693,7 +704,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO; END DO + END DO + END DO ELSE itt = ias*before itrig = itt + 1 @@ -747,7 +759,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO; END DO + END DO + END DO END IF 4100 CONTINUE END IF @@ -842,7 +855,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO DO 8000, ia = 2, after ias = ia - 1 itt = ias*before @@ -969,7 +983,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO 8000 CONTINUE ELSE @@ -1062,7 +1077,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO DO 8001, ia = 2, after ias = ia - 1 @@ -1190,7 +1206,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO 8001 CONTINUE END IF @@ -1226,7 +1243,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO DO 3000, ia = 2, after ias = ia - 1 IF (4*ias == 3*after) THEN @@ -1259,7 +1277,8 @@ CONTAINS zout(2, j, nout2) = s1 - r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 + r2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1289,7 +1308,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 - s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO END IF ELSE IF (8*ias == 3*after) THEN IF (isign == 1) THEN @@ -1323,7 +1343,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1355,7 +1376,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO END IF ELSE itt = ias*before @@ -1397,7 +1419,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO END IF 3000 CONTINUE ELSE IF (now == 5) THEN @@ -1460,7 +1483,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO DO 5000, ia = 2, after ias = ia - 1 IF (8*ias == 5*after) THEN @@ -1519,7 +1543,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1575,7 +1600,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO END IF ELSE ias = ia - 1 @@ -1650,7 +1676,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO END IF 5000 CONTINUE ELSE IF (now == 6) THEN @@ -1724,7 +1751,8 @@ CONTAINS zout(2, j, nout2) = ui2 - vi2 zout(1, j, nout6) = ur3 - vr3 zout(2, j, nout6) = ui3 - vi3 - END DO; END DO + END DO + END DO ELSE CPABORT("error fftstp") END IF diff --git a/src/pw/ps_wavelet_kernel.F b/src/pw/ps_wavelet_kernel.F index c535a1fa43..b39df92602 100644 --- a/src/pw/ps_wavelet_kernel.F +++ b/src/pw/ps_wavelet_kernel.F @@ -12,6 +12,7 @@ MODULE ps_wavelet_kernel USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_base, ONLY: scramble_unpack USE ps_wavelet_fft3d, ONLY: ctrig,& @@ -235,8 +236,8 @@ CONTAINS shift INTEGER, ALLOCATABLE, DIMENSION(:) :: after, before, now REAL(kind=dp) :: a, b, c, cp, d, diff, dx, feI, feR, foI, & - foR, fR, mu1, pi, pion, ponx, pony, & - sp, value, x + foR, fR, mu1, pion, ponx, pony, sp, & + value, x REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: kernel_scf, x_scf, y_scf REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: btrig, cossinarr REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: halfft_cache, kernel @@ -355,9 +356,6 @@ CONTAINS ALLOCATE (now(7)) ALLOCATE (before(7)) - !constants - pi = 4._dp*ATAN(1._dp) - !arrays for the halFFT CALL ctrig(n3/2, btrig, after, before, now, 1, ic) diff --git a/src/pw/ps_wavelet_methods.F b/src/pw/ps_wavelet_methods.F index 7ca3a4c95d..624bae7120 100644 --- a/src/pw/ps_wavelet_methods.F +++ b/src/pw/ps_wavelet_methods.F @@ -90,10 +90,12 @@ CONTAINS hz = pw_grid%dr(wavelet%axis(3)) IF (poisson_params%wavelet_method == WAVELET0D) THEN - IF (hx /= hy) & + IF (hx /= hy) THEN CPABORT("Poisson solver for non cubic cells not yet implemented") - IF (hz /= hy) & + END IF + IF (hz /= hy) THEN CPABORT("Poisson solver for non cubic cells not yet implemented") + END IF END IF CALL RS_z_slice_distribution(wavelet, pw_grid) diff --git a/src/pw/ps_wavelet_scaling_function.F b/src/pw/ps_wavelet_scaling_function.F index 1eed8a8d73..6352c34555 100644 --- a/src/pw/ps_wavelet_scaling_function.F +++ b/src/pw/ps_wavelet_scaling_function.F @@ -74,9 +74,7 @@ CONTAINS !open (unit=1,file='scfunction',status='unknown') DO i = 0, nd a(i) = 1._dp*i*ni/nd - (.5_dp*ni - 1._dp) - !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-1._dp),x(i) END DO - !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) END SUBROUTINE scaling_function @@ -128,9 +126,7 @@ CONTAINS !open (unit=1,file='wavelet',status='unknown') DO i = 0, nd - 1 a(i) = 1._dp*i*ni/nd - (.5_dp*ni - .5_dp) - !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-.5_dp),x(i) END DO - !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) @@ -166,7 +162,7 @@ CONTAINS !> \param n ... !> \param x ... ! ************************************************************************************************** - SUBROUTINE zero(n, x) + PURE SUBROUTINE zero(n, x) INTEGER, INTENT(in) :: n REAL(KIND=dp), INTENT(out) :: x(n) diff --git a/src/pw/ps_wavelet_types.F b/src/pw/ps_wavelet_types.F index dfbfceb2db..464697a8d0 100644 --- a/src/pw/ps_wavelet_types.F +++ b/src/pw/ps_wavelet_types.F @@ -55,10 +55,12 @@ CONTAINS TYPE(ps_wavelet_type), POINTER :: wavelet IF (ASSOCIATED(wavelet)) THEN - IF (ASSOCIATED(wavelet%karray)) & + IF (ASSOCIATED(wavelet%karray)) THEN DEALLOCATE (wavelet%karray) - IF (ASSOCIATED(wavelet%rho_z_sliced)) & + END IF + IF (ASSOCIATED(wavelet%rho_z_sliced)) THEN DEALLOCATE (wavelet%rho_z_sliced) + END IF DEALLOCATE (wavelet) END IF END SUBROUTINE ps_wavelet_release diff --git a/src/pw/pw_fpga.F b/src/pw/pw_fpga.F index 3d26adb66c..3819cd0749 100644 --- a/src/pw/pw_fpga.F +++ b/src/pw/pw_fpga.F @@ -117,8 +117,9 @@ CONTAINS CPABORT("OFFLOAD and FPGA cannot be configured concurrently! Recompile with -D__NO_OFFLOAD_PW.") #endif stat = pw_fpga_initialize() - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("pw_fpga_init: failed") + END IF #endif #if (__PW_FPGA_SP && !(__PW_FPGA)) diff --git a/src/pw/pw_gpu.F b/src/pw/pw_gpu.F index 2f6a055c4d..3e752e77da 100644 --- a/src/pw/pw_gpu.F +++ b/src/pw/pw_gpu.F @@ -301,8 +301,9 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) & + IF (r_dim(1) == 1) THEN CPABORT("This processor distribution is not supported.") + END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) @@ -463,8 +464,9 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) & + IF (r_dim(1) == 1) THEN CPABORT("This processor distribution is not supported.") + END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) diff --git a/src/pw/pw_grid_types.F b/src/pw/pw_grid_types.F index b5c6024351..62a9f61387 100644 --- a/src/pw/pw_grid_types.F +++ b/src/pw/pw_grid_types.F @@ -44,7 +44,8 @@ MODULE pw_grid_types INTEGER, DIMENSION(:), ALLOCATABLE :: nyzray ! number of g-space rays (pe) TYPE(mp_cart_type) :: group = mp_cart_type() ! real space group (2-dim cart) INTEGER, DIMENSION(:, :, :, :), ALLOCATABLE :: bo ! list of axis distribution - INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane....should go: hard-codes to plane distributed + INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane + ! should go: hard-codes to plane distributed END TYPE pw_para_type ! all you always wanted to know about grids, but were... diff --git a/src/pw/pw_poisson_methods.F b/src/pw/pw_poisson_methods.F index 89f8f65c32..04910df1ab 100644 --- a/src/pw/pw_poisson_methods.F +++ b/src/pw/pw_poisson_methods.F @@ -537,8 +537,9 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN CPABORT("vhartree has a different grid than the poisson solver") + END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -948,8 +949,9 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN CPABORT("vhartree has a different grid than the poisson solver") + END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -1292,12 +1294,12 @@ CONTAINS CALL timeset(routineN, handle) - IF (PRESENT(parameters)) & - poisson_env%parameters = parameters + IF (PRESENT(parameters)) poisson_env%parameters = parameters IF (PRESENT(cell_hmat)) THEN - IF (ANY(poisson_env%cell_hmat /= cell_hmat)) & + IF (ANY(poisson_env%cell_hmat /= cell_hmat)) THEN CALL pw_poisson_cleanup(poisson_env) + END IF poisson_env%cell_hmat(:, :) = cell_hmat(:, :) poisson_env%rebuild = .TRUE. END IF diff --git a/src/pw/pw_poisson_types.F b/src/pw/pw_poisson_types.F index b73b8423cb..624cadd4c0 100644 --- a/src/pw/pw_poisson_types.F +++ b/src/pw/pw_poisson_types.F @@ -367,8 +367,9 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d*(1.0_dp - COS(rlength*gg)) END DO - IF (grid%have_g0) & + IF (grid%have_g0) THEN gf%array(1) = 0.5_dp*fourpi*rlength*rlength + END IF CASE (MT2D, MT1D, MT0D) @@ -377,8 +378,9 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d + green%screen_fn%array(ig) END DO - IF (grid%have_g0) & + IF (grid%have_g0) THEN gf%array(1) = green%screen_fn%array(1) + END IF CASE (PS_IMPLICIT) @@ -452,10 +454,12 @@ CONTAINS DEALLOCATE (gftype%p3m_charge) END IF END IF - IF (ALLOCATED(gftype%p3m_bm2)) & + IF (ALLOCATED(gftype%p3m_bm2)) THEN DEALLOCATE (gftype%p3m_bm2) - IF (ALLOCATED(gftype%p3m_coeff)) & + END IF + IF (ALLOCATED(gftype%p3m_coeff)) THEN DEALLOCATE (gftype%p3m_coeff) + END IF END SUBROUTINE pw_green_release ! ************************************************************************************************** diff --git a/src/pw/pw_spline_utils.F b/src/pw/pw_spline_utils.F index 4e708be0a3..8459f07cb6 100644 --- a/src/pw/pw_spline_utils.F +++ b/src/pw/pw_spline_utils.F @@ -2116,7 +2116,7 @@ CONTAINS + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 + ww0(2)*vv7 + vv0*ww1(2) coarse_coeffs(i + 3, j, k) = coarse_coeffs(i + 3, j, k) & + ww1(4)*vv6 + ww0(3)*vv7 + vv0*ww1(3) - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv0 = fine_values(fi, fj, fk) vv1 = fine_values(fine_bo(1, 1), fj, fk) @@ -2158,7 +2158,7 @@ CONTAINS + ww1(3)*vv4 + ww0(2)*vv5 + ww1(2)*vv6 coarse_coeffs(i + 2, j, k) = coarse_coeffs(i + 2, j, k) & + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv6 = fine_values(fi, fj, fk) vv7 = fine_values(fine_bo(1, 1), fj, fk) @@ -2202,7 +2202,7 @@ CONTAINS + ww1(3)*vv2 + ww0(2)*vv3 + ww1(2)*vv4 coarse_coeffs(i + 1, j, k) = coarse_coeffs(i + 1, j, k) & + ww1(4)*vv2 + ww0(3)*vv3 + ww1(3)*vv4 - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv4 = fine_values(fi, fj, fk) vv5 = fine_values(fine_bo(1, 1), fj, fk) @@ -2244,7 +2244,7 @@ CONTAINS + ww1(3)*vv0 + ww0(2)*vv1 + ww1(2)*vv2 coarse_coeffs(i, j, k) = coarse_coeffs(i, j, k) & + ww1(4)*vv0 + ww0(3)*vv1 + ww1(3)*vv2 - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv2 = fine_values(fi, fj, fk) vv3 = fine_values(fine_bo(1, 1), fk, fk) @@ -2348,8 +2348,9 @@ CONTAINS send_offset(ip) = send_tot_size send_tot_size = send_tot_size + send_size(ip) END DO - IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) & + IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) THEN CPABORT("Error calculating send_tot_size") + END IF ALLOCATE (send_buf(0:send_tot_size - 1)) rcv_tot_size = 0 @@ -2374,10 +2375,12 @@ CONTAINS sent_size(p) = sent_size(p) + coarse_slice_size END DO - IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) & + IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) THEN CPABORT("error 1 filling send buffer") - IF (sent_size(n_procs - 1) /= send_tot_size) & + END IF + IF (sent_size(n_procs - 1) /= send_tot_size) THEN CPABORT("error 2 filling send buffer") + END IF IF (local_data) THEN DEALLOCATE (coarse_coeffs) @@ -2441,10 +2444,12 @@ CONTAINS END DO - IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) & + IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) THEN CPABORT("error 1 handling the rcv buffer") - IF (sent_size(n_procs - 1) /= rcv_tot_size) & + END IF + IF (sent_size(n_procs - 1) /= rcv_tot_size) THEN CPABORT("error 2 handling the rcv buffer") + END IF ! dealloc DEALLOCATE (send_size, send_offset, rcv_size, rcv_offset) diff --git a/src/pw/realspace_grid_cube.F b/src/pw/realspace_grid_cube.F index c470d2ac77..05af7923fa 100644 --- a/src/pw/realspace_grid_cube.F +++ b/src/pw/realspace_grid_cube.F @@ -121,9 +121,10 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") + END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) @@ -268,8 +269,9 @@ CONTAINS ELSE size_of_z = CEILING(REAL(pw%pw_grid%bounds(2, 3) - pw%pw_grid%bounds(1, 3) + 1, dp)/REAL(my_stride(3), dp)) num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) & + IF (MODULO(size_of_z, num_entries_line) /= 0) THEN num_linebreak = num_linebreak + 1 + END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL mp_unit%set_handle(unit_nr) CALL pw_to_cube_parallel(pw, mp_unit, title, particles_r, particles_z, particles_zeff, & @@ -409,8 +411,9 @@ CONTAINS ! Each data line of a Gaussian cube contains max 6 entries with last line potentially containing less if nz % 6 /= 0 ! Thus, this size is simply the number of entries multiplied by the entry size + the number of line breaks num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) & + IF (MODULO(size_of_z, num_entries_line) /= 0) THEN num_linebreak = num_linebreak + 1 + END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL cube_to_pw_parallel(grid, filename, scaling, msglen, silent=silent) END IF @@ -630,9 +633,10 @@ CONTAINS IF ((lbounds_local(1) <= i) .AND. (i <= ubounds_local(1)) .AND. (lbounds_local(2) <= j) & .AND. (j <= ubounds_local(2))) THEN !allow scaling of external potential values by factor 'scaling' (SCALING_FACTOR in input file) - IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) & + IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) THEN CALL cp_abort(__LOCATION__, & "Error in parallel read of input cube file.") + END IF END IF END DO @@ -824,8 +828,9 @@ CONTAINS END IF tmp = TRIM(tmp)//TRIM(value) counter = counter + 1 - IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) & + IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) THEN tmp = TRIM(tmp)//NEW_LINE('C') + END IF END DO writebuffer(islice) = tmp islice = islice + 1 @@ -889,9 +894,10 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") + END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_cube_unittest.F b/src/pw/realspace_grid_cube_unittest.F index 7732cea3ea..b1685dc56b 100644 --- a/src/pw/realspace_grid_cube_unittest.F +++ b/src/pw/realspace_grid_cube_unittest.F @@ -19,20 +19,24 @@ PROGRAM realspace_grid_cube_unittest REAL(KIND=dp), DIMENSION(7) :: slice_buffer, slice_reference WRITE (value, cube_value_format) 0.33004E-101_dp - IF (INDEX(value, "E-101") <= 0) & + IF (INDEX(value, "E-101") <= 0) THEN ERROR STOP "Cube value format must preserve three-digit negative exponents." + END IF reference = [0.0_dp, -0.91458E-35_dp, 0.33004E-101_dp, & -0.32487E-103_dp, 1.0_dp, -1.0_dp] WRITE (values(1:78), cube_values_format) reference values(79:79) = NEW_LINE("C") - IF (INDEX(values, "E-101") <= 0) & + IF (INDEX(values, "E-101") <= 0) THEN ERROR STOP "Cube line format must preserve E-101." - IF (INDEX(values, "E-103") <= 0) & + END IF + IF (INDEX(values, "E-103") <= 0) THEN ERROR STOP "Cube line format must preserve E-103." + END IF CALL cube_read_values(values, buffer) - IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) & + IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) THEN ERROR STOP "Cube reader must parse adjacent explicit-exponent values." + END IF slice_reference(1:6) = reference slice_reference(7) = 0.27183E-123_dp @@ -40,7 +44,8 @@ PROGRAM realspace_grid_cube_unittest slice_values(79:79) = NEW_LINE("C") WRITE (slice_values(80:92), cube_value_format) slice_reference(7) CALL cube_read_values(slice_values, slice_buffer) - IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) & + IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) THEN ERROR STOP "Cube reader must parse multi-line z-slices." + END IF END PROGRAM realspace_grid_cube_unittest diff --git a/src/pw/realspace_grid_openpmd.F b/src/pw/realspace_grid_openpmd.F index b64caaa0e6..131d0344ff 100644 --- a/src/pw/realspace_grid_openpmd.F +++ b/src/pw/realspace_grid_openpmd.F @@ -340,9 +340,10 @@ CONTAINS IF (PRESENT(mpi_io)) parallel_write = mpi_io my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") + END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_types.F b/src/pw/realspace_grid_types.F index b54f99a6ee..57ac9540a9 100644 --- a/src/pw/realspace_grid_types.F +++ b/src/pw/realspace_grid_types.F @@ -659,8 +659,9 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN CPABORT("Different rs and pw indentifiers") + END IF IF (rs%desc%distributed) THEN CALL transfer_rs2pw_distributed(rs, pw) @@ -702,8 +703,9 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN CPABORT("Different rs and pw indentifiers") + END IF IF (rs%desc%distributed) THEN CALL transfer_pw2rs_distributed(rs, pw) diff --git a/src/qcschema.F b/src/qcschema.F index a4eae93faf..23ce8e1b05 100644 --- a/src/qcschema.F +++ b/src/qcschema.F @@ -407,10 +407,12 @@ CONTAINS IF (dft_control%dft_plus_u) CPABORT('WARNING: DFT+U not supported in QCSchema') IF (dft_control%do_sccs) CPABORT('WARNING: SCCS not supported in QCSchema') IF (qs_env%qmmm) CPABORT('WARNING: QM/MM not supported in QCSchema') - IF (dft_control%qs_control%mulliken_restraint) & + IF (dft_control%qs_control%mulliken_restraint) THEN CPABORT('WARNING: Mulliken restrains not supported in QCSchema') - IF (dft_control%qs_control%semi_empirical) & + END IF + IF (dft_control%qs_control%semi_empirical) THEN CPABORT('WARNING: semi_empirical methods not supported in QCSchema') + END IF IF (dft_control%qs_control%dftb) CPABORT('WARNING: DFTB not supported in QCSchema') IF (dft_control%qs_control%xtb) CPABORT('WARNING: xTB not supported in QCSchema') diff --git a/src/qmmm_create.F b/src/qmmm_create.F index f15dd5d2f0..1cbe80ccf4 100644 --- a/src/qmmm_create.F +++ b/src/qmmm_create.F @@ -228,11 +228,12 @@ CONTAINS IF (explicit .AND. use_multipole == do_multipole_section_on) qmmm_env_qm%multipole = .TRUE. IF (qmmm_env_qm%periodic .AND. qmmm_env_qm%multipole) CALL cite_reference(Laino2006) IF (qmmm_coupl_type == do_qmmm_none) THEN - IF (qmmm_env_qm%periodic) & + IF (qmmm_env_qm%periodic) THEN CALL cp_warn(__LOCATION__, & "QMMM periodic calculation with coupling NONE was requested! "// & "Switching off the periodic keyword since periodic and non-periodic "// & "calculation with coupling NONE represent the same method! ") + END IF qmmm_env_qm%periodic = .FALSE. END IF @@ -298,8 +299,9 @@ CONTAINS CALL get_cell(mm_cell, abc=abc_mm) IF (qmmm_env_qm%image_charge) THEN - IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) & + IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) THEN CPABORT("QM and MM box need to have the same size when using image charges") + END IF END IF ! Assign charges and mm_el_pot_radius from fist_topology diff --git a/src/qmmm_elpot.F b/src/qmmm_elpot.F index 9774d16564..da89a5d1a5 100644 --- a/src/qmmm_elpot.F +++ b/src/qmmm_elpot.F @@ -145,7 +145,7 @@ CONTAINS t = 2._dp/(rootpi*x*rc)*EXP(-(x/rc)**2) pot0_2(2, i) = (t - pot0_2(1, i)/x)*dx END DO - ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN ! S-wave expansion :: 1/x - exp(-2*x/rc) * ( 1/x - 1/rc ) pot0_2(1, 1) = 1.0_dp/rc pot0_2(2, 1) = 0.0_dp diff --git a/src/qmmm_force.F b/src/qmmm_force.F index 4b4b876627..a892769aff 100644 --- a/src/qmmm_force.F +++ b/src/qmmm_force.F @@ -135,10 +135,11 @@ CONTAINS WRITE (unit=output_unit, fmt='("ip, j, pos, lat_pos ",2I6,6F12.5)') ip, j, & particles_qm(ip)%r, DOT_PRODUCT(qm_cell%h_inv(j, :), particles_qm(ip)%r) END IF - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "QM/MM QM atoms must be fully contained in the same image of the QM box "// & "- No wrapping of coordinates is allowed! ") + END IF END DO END DO diff --git a/src/qmmm_gaussian_init.F b/src/qmmm_gaussian_init.F index c588591b9e..7885a7c400 100644 --- a/src/qmmm_gaussian_init.F +++ b/src/qmmm_gaussian_init.F @@ -163,7 +163,7 @@ CONTAINS IF (qmmm_coupl_type == do_qmmm_gauss) THEN CALL set_mm_potential_erf(qmmm_gaussian_fns, & compatibility, num_geep_gauss) - ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN CALL set_mm_potential_swave(qmmm_gaussian_fns, & num_geep_gauss) END IF diff --git a/src/qmmm_gpw_energy.F b/src/qmmm_gpw_energy.F index af8d7d34af..d62e251621 100644 --- a/src/qmmm_gpw_energy.F +++ b/src/qmmm_gpw_energy.F @@ -126,8 +126,9 @@ CONTAINS print_section => section_vals_get_subs_vals(input_section, "QMMM%PRINT") iw = cp_print_key_unit_nr(logger, print_section, "PROGRAM_RUN_INFO", & extension=".qmmmLog") - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(T2,"QMMM|",1X,A)') "Information on the QM/MM Electrostatic Potential:" + END IF ! ! Initializing vectors: ! Zeroing v_qmmm_rspace @@ -148,7 +149,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -172,9 +173,10 @@ CONTAINS CASE (do_qmmm_pcharge) CPABORT("Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.") CASE (do_qmmm_gauss, do_qmmm_swave) - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(T2,"QMMM|",1X,A)') & - "QM/MM Coupling computed collocating the Gaussian Potential Functions." + "QM/MM Coupling computed collocating the Gaussian Potential Functions." + END IF interp_section => section_vals_get_subs_vals(input_section, & "QMMM%INTERPOLATOR") CALL qmmm_elec_with_gaussian(qmmm_env=qmmm_env, & @@ -807,8 +809,9 @@ CONTAINS IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm qt = mm_charges(LIndMM) - IF (shells) & + IF (shells) THEN ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm + END IF ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) diff --git a/src/qmmm_gpw_forces.F b/src/qmmm_gpw_forces.F index f2ecb1a293..a4246fdc39 100644 --- a/src/qmmm_gpw_forces.F +++ b/src/qmmm_gpw_forces.F @@ -176,7 +176,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -1212,8 +1212,9 @@ CONTAINS LIndMM = pot%mm_atom_index(Imm) IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - IF (shells) & + IF (shells) THEN ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm + END IF qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN @@ -1421,10 +1422,11 @@ CONTAINS Err(K) = (Analytical_Forces(K, I) - Num_Forces(K, I))/Num_Forces(K, I)*100.0_dp END IF END DO - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) IndMM, Analytical_Forces(1, I), Num_Forces(1, I), Err(1), & - Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & - Analytical_Forces(3, I), Num_Forces(3, I), Err(3) + Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & + Analytical_Forces(3, I), Num_Forces(3, I), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1532,10 +1534,11 @@ CONTAINS Err(2) = (debug_force(2) - force(2))/force(2)*100.0_dp Err(3) = (debug_force(3) - force(3))/force(3)*100.0_dp END IF - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) Icount, debug_force(1), force(1), Err(1), & - debug_force(2), force(2), Err(2), & - debug_force(3), force(3), Err(3) + debug_force(2), force(2), Err(2), & + debug_force(3), force(3), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1638,9 +1641,10 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + END IF Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1654,10 +1658,11 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1752,9 +1757,10 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + END IF Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1768,10 +1774,11 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) diff --git a/src/qmmm_image_charge.F b/src/qmmm_image_charge.F index 607d4db02f..f721612be5 100644 --- a/src/qmmm_image_charge.F +++ b/src/qmmm_image_charge.F @@ -587,11 +587,12 @@ CONTAINS CALL calculate_image_matrix(image_matrix=qs_env%image_matrix, & ipiv=qs_env%ipiv, qs_env=qs_env, qmmm_env=qmmm_env) qmmm_env%image_charge_pot%state_image_matrix = calc_once_done - IF (qmmm_env%center_qm_subsys0) & + IF (qmmm_env%center_qm_subsys0) THEN CALL cp_warn(__LOCATION__, & "The image atoms are fully "// & "constrained and the image matrix is only calculated once. "// & "To be safe, set CENTER to NEVER ") + END IF CASE (calc_once_done) ! do nothing image matrix is stored CASE DEFAULT diff --git a/src/qmmm_init.F b/src/qmmm_init.F index a2499ee7c9..3655e31cd0 100644 --- a/src/qmmm_init.F +++ b/src/qmmm_init.F @@ -667,10 +667,11 @@ CONTAINS ELSE IF (qmmm_env%spherical_cutoff(2) <= 0.0_dp) qmmm_env%spherical_cutoff(2) = EPSILON(0.0_dp) tmp_radius = qmmm_env%spherical_cutoff(1) - 20.0_dp*qmmm_env%spherical_cutoff(2) - IF (tmp_radius <= 0.0_dp) & + IF (tmp_radius <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "SPHERICAL_CUTOFF(1) > 20*SPHERICAL_CUTOFF(1)! Please correct parameters for "// & "the Spherical Cutoff in order to satisfy the previous condition!") + END IF END IF ! ! Initialization of arrays and core_charge_radius... @@ -1032,12 +1033,15 @@ CONTAINS END SELECT END DO END IF - IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) & + IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) THEN ALLOCATE (mm_link_scale_factor(link_involv_mm)) - IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) & + END IF + IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) THEN ALLOCATE (fist_scale_charge_link(link_involv_mm)) - IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) & + END IF + IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) THEN ALLOCATE (mm_link_atoms(link_involv_mm)) + END IF IF (PRESENT(qm_atom_index)) ALLOCATE (qm_atom_index(num_qm_atom_tot)) IF (PRESENT(qm_atom_type)) ALLOCATE (qm_atom_type(num_qm_atom_tot)) IF (PRESENT(qm_atom_index)) qm_atom_index = 0 @@ -1286,8 +1290,9 @@ CONTAINS CALL section_vals_val_get(move_section, "RADIUS", r_val=radius, i_rep_section=i_add) CALL section_vals_val_get(move_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) & + IF (n_rep_val == 1) THEN CALL section_vals_val_get(move_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) + END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1313,8 +1318,9 @@ CONTAINS CALL section_vals_val_get(add_section, "CHARGE", r_val=charge, i_rep_section=i_add) CALL section_vals_val_get(add_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) & + IF (n_rep_val == 1) THEN CALL section_vals_val_get(add_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) + END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, charge, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1496,8 +1502,9 @@ CONTAINS END IF DO j = i + 1, num_image_mm_atom atom_b = qmmm_env%image_charge_pot%image_mm_list(j) - IF (atom_a == atom_b) & + IF (atom_a == atom_b) THEN CPABORT("There are atoms doubled in image list.") + END IF END DO END DO diff --git a/src/qmmm_links_methods.F b/src/qmmm_links_methods.F index c7ca6d962e..671195819f 100644 --- a/src/qmmm_links_methods.F +++ b/src/qmmm_links_methods.F @@ -63,18 +63,20 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") + END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") + END IF ip_mm = ip particles(ip_mm)%r = alpha*particles(ip_mm)%r + (1.0_dp - alpha)*particles(ip_qm)%r END DO @@ -110,18 +112,20 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") + END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") + END IF ip_mm = ip particles_qm(ip_qm)%f = particles_qm(ip_qm)%f + particles_qm(ip_mm)%f*(1.0_dp - alpha) particles_qm(ip_mm)%f = particles_qm(ip_mm)%f*alpha diff --git a/src/qmmm_per_elpot.F b/src/qmmm_per_elpot.F index c13f0ff4fe..1d46ede77e 100644 --- a/src/qmmm_per_elpot.F +++ b/src/qmmm_per_elpot.F @@ -173,7 +173,7 @@ CONTAINS g = SQRT(g2) IF (qmmm_coupl_type == do_qmmm_gauss) THEN LG(idim) = 4.0_dp*Pi/g2*EXP(-(g2*rc2)/4.0_dp) - ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN tmp = 4.0_dp/rc2 LG(idim) = 4.0_dp*Pi*tmp**2/(g2*(g2 + tmp)**2) END IF @@ -363,8 +363,9 @@ CONTAINS CALL ewald_env_get(ewald_env, ewald_type=ewald_type, do_multipoles=do_multipoles, & gmax=gmax, o_spline=o_spline, alpha=alpha, rcut=rcut) - IF (do_multipoles) & + IF (do_multipoles) THEN CPABORT("No multipole force fields allowed in QM-QM Ewald long range correction") + END IF SELECT CASE (qmmm_coupl_type) CASE (do_qmmm_coulomb) diff --git a/src/qmmm_tb_methods.F b/src/qmmm_tb_methods.F index 8058c41956..a1d0aab62f 100644 --- a/src/qmmm_tb_methods.F +++ b/src/qmmm_tb_methods.F @@ -147,7 +147,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -159,7 +159,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -179,7 +179,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -263,7 +263,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -275,7 +275,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -363,7 +363,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -375,7 +375,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -469,7 +469,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -512,7 +512,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -644,7 +644,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -654,7 +654,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -675,7 +675,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -703,7 +703,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -743,7 +743,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN ! use all kinds END IF DO i = 1, SIZE(list) @@ -887,7 +887,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -897,7 +897,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -917,7 +917,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -1054,7 +1054,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1116,7 +1116,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1159,7 +1159,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN ! END IF DO i = 1, SIZE(list) diff --git a/src/qmmm_topology_util.F b/src/qmmm_topology_util.F index 3ea4eaf263..ad9f796bdb 100644 --- a/src/qmmm_topology_util.F +++ b/src/qmmm_topology_util.F @@ -139,8 +139,9 @@ CONTAINS molecule => molecule_set(imolecule) CALL get_molecule(molecule, molecule_kind=molecule_kind, & first_atom=first_atom, last_atom=last_atom) - IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) & + IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) THEN qm_mol_num = qm_mol_num + 1 + END IF END DO ! ALLOCATE (qm_molecule_index(qm_mol_num)) diff --git a/src/qmmm_util.F b/src/qmmm_util.F index 18cdfd5389..3357a6cfff 100644 --- a/src/qmmm_util.F +++ b/src/qmmm_util.F @@ -128,10 +128,11 @@ CONTAINS END IF IF (force_env%in_use == use_qmmmx) THEN - IF (iwall_type /= do_qmmm_wall_none) & + IF (iwall_type /= do_qmmm_wall_none) THEN CALL cp_warn(__LOCATION__, & "Reflective walls for QM/MM are not implemented (or useful) when "// & "force mixing is active. Skipping!") + END IF RETURN END IF @@ -619,7 +620,7 @@ CONTAINS REAL(KIND=dp) :: r, r0 - r = SQRT(DOT_PRODUCT(rij, rij)) + r = NORM2(rij) r0 = spherical_cutoff(1) - 20.0_dp*spherical_cutoff(2) factor = 0.5_dp*(1.0_dp - TANH((r - r0)/spherical_cutoff(2))) diff --git a/src/qmmmx_force.F b/src/qmmmx_force.F index 1e69447e42..72afe1f591 100644 --- a/src/qmmmx_force.F +++ b/src/qmmmx_force.F @@ -80,9 +80,10 @@ CONTAINS TYPE(section_vals_type), POINTER :: force_env_section IF (PRESENT(require_consistent_energy_force)) THEN - IF (require_consistent_energy_force) & + IF (require_consistent_energy_force) THEN CALL cp_abort(__LOCATION__, & "qmmmx_energy_and_forces got require_consistent_energy_force but force mixing is active. ") + END IF END IF ! Possibly translate the system @@ -118,9 +119,9 @@ CONTAINS IF (mom_conserv_region == do_fm_mom_conserv_core) THEN mom_conserv_min_label = force_mixing_label_QM_core - ELSEIF (mom_conserv_region == do_fm_mom_conserv_QM) THEN + ELSE IF (mom_conserv_region == do_fm_mom_conserv_QM) THEN mom_conserv_min_label = force_mixing_label_QM_dynamics - ELSEIF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN + ELSE IF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN mom_conserv_min_label = force_mixing_label_buffer ELSE CPABORT("Got unknown MOMENTUM_CONSERVATION_REGION (not CORE, QM, or BUFFER) !") @@ -141,8 +142,9 @@ CONTAINS ELSE IF (mom_conserv_type == do_fm_mom_conserv_equal_a) THEN mom_conserv_mass = 0.0_dp DO ip = 1, SIZE(cur_indices) - IF (cur_labels(ip) >= mom_conserv_min_label) & + IF (cur_labels(ip) >= mom_conserv_min_label) THEN mom_conserv_mass = mom_conserv_mass + particles_qmmm_core(cur_indices(ip))%atomic_kind%mass + END IF END DO delta_a = total_f/mom_conserv_mass DO ip = 1, SIZE(cur_indices) diff --git a/src/qmmmx_util.F b/src/qmmmx_util.F index 680cba631d..6779e0100a 100644 --- a/src/qmmmx_util.F +++ b/src/qmmmx_util.F @@ -285,8 +285,9 @@ CONTAINS ![NB] need more sophisticated QM extended, buffer rules ! add QM using hysteretic selection (core_list, r_qm) + unbreakable bonds - IF (debug_this_module .AND. output_unit > 0) & + IF (debug_this_module .AND. output_unit > 0) THEN WRITE (output_unit, *) "BOB QM_extended_seed_is_core_list ", QM_extended_seed_is_core_list + END IF IF (QM_extended_seed_is_core_list) THEN QM_extended_seed_min_label_val = force_mixing_label_QM_core_list ELSE ! QM region seed is all of core, not just core list + unbreakable bonds @@ -378,17 +379,19 @@ CONTAINS EXIT END IF END DO - IF (old_index <= 0) & + IF (old_index <= 0) THEN CALL cp_abort(__LOCATION__, & "add_new_label found atom with a label "// & "already set, but not in new_indices array") + END IF new_labels(old_index) = label ELSE n_new = n_new + 1 - IF (n_new > max_n_qm) & + IF (n_new > max_n_qm) THEN CALL cp_abort(__LOCATION__, & "add_new_label tried to add more atoms "// & "than allowed by &FORCE_MIXING&MAX_N_QM!") + END IF IF (n_new > SIZE(new_indices)) CALL reallocate(new_indices, 1, n_new + 9) IF (n_new > SIZE(new_labels)) CALL reallocate(new_labels, 1, n_new + 9) new_indices(n_new) = ip @@ -483,8 +486,9 @@ CONTAINS adaptive_exclude = .FALSE. DO im_exclude = 1, SIZE(adaptive_exclude_molecules) IF (TRIM(molecule_set(im)%molecule_kind%name) == TRIM(adaptive_exclude_molecules(im_exclude)) .OR. & - TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) & + TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) THEN adaptive_exclude = .TRUE. + END IF END DO IF (adaptive_exclude) CYCLE END IF @@ -493,15 +497,17 @@ CONTAINS IF (molec_in_inner) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) & + IF (new_full_labels(ip) < set_label_val) THEN CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) + END IF END DO ELSE IF (molec_in_outer) THEN IF (ANY(orig_full_labels(molecule_set(im)%first_atom:molecule_set(im)%last_atom) >= set_label_val)) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) & + IF (new_full_labels(ip) < set_label_val) THEN CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) + END IF END DO END IF END IF @@ -644,8 +650,9 @@ CONTAINS ! get CUR_INDICES, CUR_LABELS CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels) - IF (SIZE(cur_indices) <= 0) & + IF (SIZE(cur_indices) <= 0) THEN CPABORT("cur_indices is empty, found no QM atoms") + END IF IF (debug_this_module .AND. output_unit > 0) THEN WRITE (output_unit, *) "cur_indices ", cur_indices @@ -665,21 +672,23 @@ CONTAINS EXIT END IF END DO - IF (.NOT. mapped) & + IF (.NOT. mapped) THEN CALL cp_abort(__LOCATION__, & "Force-mixing failed to find QM_KIND mapping for atom of type "// & TRIM(particles(cur_indices(ip))%atomic_kind%element_symbol)// & "! ") + END IF END IF END DO ! pre-existing QM_KIND section specifies list of core atom qm_kind_section => section_vals_get_subs_vals3(qmmm_section, "QM_KIND") CALL section_vals_get(qm_kind_section, n_repetition=i_rep_section_core) - IF (i_rep_section_core <= 0) & + IF (i_rep_section_core <= 0) THEN CALL cp_abort(__LOCATION__, & "Force-mixing QM didn't find any QM_KIND sections, "// & "so no core specified!") + END IF i_rep_section_extended = i_rep_section_core DO ielem = 1, n_elements new_element_core = .TRUE. @@ -800,8 +809,9 @@ CONTAINS n_labels = n_labels + SIZE(labels_entry) END DO - IF (n_indices /= n_labels) & + IF (n_indices /= n_labels) THEN CPABORT("got unequal numbers of force_mixing indices and labels!") + END IF END SUBROUTINE get_force_mixing_indices END MODULE qmmmx_util diff --git a/src/qs_2nd_kernel_ao.F b/src/qs_2nd_kernel_ao.F index 882a42af8d..dd4e7540c8 100644 --- a/src/qs_2nd_kernel_ao.F +++ b/src/qs_2nd_kernel_ao.F @@ -301,8 +301,9 @@ CONTAINS CPASSERT(.NOT. dft_control%qs_control%gapw_xc) CPASSERT(.NOT. dft_control%qs_control%lrigpw) CPASSERT(.NOT. linres_control%lr_triplet) - IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) & + IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) THEN CPABORT("kpp1_admm has to be associated if ADMM kernel calculations are requested") + END IF nspins = dft_control%nspins diff --git a/src/qs_active_space_methods.F b/src/qs_active_space_methods.F index a4bcfd1e69..56c589cbd6 100644 --- a/src/qs_active_space_methods.F +++ b/src/qs_active_space_methods.F @@ -288,19 +288,23 @@ CONTAINS NULLIFY (kpoints) CALL get_qs_env(qs_env, do_kpoints=do_kpoints, dft_control=dft_control, kpoints=kpoints) IF (do_kpoints) THEN - IF (.NOT. ASSOCIATED(kpoints)) & + IF (.NOT. ASSOCIATED(kpoints)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") + END IF CALL get_kpoint_info(kpoints, kp_scheme=kp_scheme, nkp=nkp, use_real_wfn=use_real_wfn) IF (TRIM(kp_scheme) /= "GAMMA" .OR. nkp /= 1 .OR. .NOT. use_real_wfn) THEN CALL cp_abort(__LOCATION__, & "Only Gamma-point DFT%KPOINTS are supported in the active space module") END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env)) & + IF (.NOT. ASSOCIATED(kpoints%kp_env)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) & + END IF + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) & + END IF + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point MOs for active space module") + END IF END IF ! adiabatic rescaling? @@ -786,7 +790,7 @@ CONTAINS END IF mo_set_active%eigenvalues(i) = eigenvalues(i, ispin) ! if it was not an active orbital, check whether it is an inactive orbital - ELSEIF (nmo_inactive_remaining > 0) THEN + ELSE IF (nmo_inactive_remaining > 0) THEN CALL cp_fm_to_fm(fm_dummy, fm_target_inactive, 1, i, i) ! store on the fly the mapping of inactive orbitals active_space_env%inactive_orbitals(nmo_inactive - nmo_inactive_remaining + 1, ispin) = i @@ -819,7 +823,7 @@ CONTAINS DO j = 0, jm IF (ANY(active_space_env%active_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [A]" - ELSEIF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN + ELSE IF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [I]" ELSE WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [V]" @@ -996,7 +1000,7 @@ CONTAINS IF (i == 1) THEN n1 = nmo n2 = nmo - ELSEIF (i == 2) THEN + ELSE IF (i == 2) THEN n1 = nmo n2 = nmo ELSE @@ -1451,8 +1455,9 @@ CONTAINS ! Check the input group CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) IF (eri_env%eri_gpw%group_size < 1) eri_env%eri_gpw%group_size = para_env%num_pe - IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) & + IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) THEN CPABORT("Group size must be a divisor of the total number of processes!") + END IF ! Create a new para_env or reuse the old one IF (eri_env%eri_gpw%group_size == para_env%num_pe) THEN eri_env%para_env_sub => para_env @@ -1774,7 +1779,7 @@ CONTAINS ! DEALLOCATE (eri, eri_index) END DO - ELSEIF (eri_env%method == eri_method_full_gpw) THEN + ELSE IF (eri_env%method == eri_method_full_gpw) THEN DO isp2 = isp1, nspins CALL get_mo_set(mo_set=mos(isp2), nmo=nmo2) nx = (nmo2*(nmo2 + 1))/2 @@ -2193,7 +2198,7 @@ CONTAINS CALL section_vals_val_get(input, "STRIDE", i_vals=istride) IF (SIZE(istride) == 1) THEN str(1:3) = istride(1) - ELSEIF (SIZE(istride) == 3) THEN + ELSE IF (SIZE(istride) == 3) THEN str(1:3) = istride(1:3) ELSE CPABORT("STRIDE arguments inconsistent") @@ -3136,7 +3141,7 @@ CONTAINS END IF converged = .TRUE. EXIT - ELSEIF (ABS(delta_E) <= eps_iter) THEN + ELSE IF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" @@ -3318,7 +3323,7 @@ CONTAINS converged = .TRUE. EXIT ! check for convergence - ELSEIF (ABS(delta_E) <= eps_iter) THEN + ELSE IF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" diff --git a/src/qs_active_space_mixing.F b/src/qs_active_space_mixing.F index b39d14d962..5813e70d75 100644 --- a/src/qs_active_space_mixing.F +++ b/src/qs_active_space_mixing.F @@ -256,8 +256,7 @@ CONTAINS active_space_env%as_mix_x_buffer(ib, :) = p_old active_space_env%as_mix_r_buffer(ib, :) = p_solver - p_old - res_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & - active_space_env%as_mix_r_buffer(ib, :))) + res_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) IF (nb == 1 .OR. res_norm < 1.E-14_dp) THEN CALL active_space_direct_mix(p_old, p_solver, mixing_store%alpha, p_mixed) @@ -337,7 +336,7 @@ CONTAINS ALLOCATE (p_res(ndim)) p_res(:) = p_solver(:) - p_old(:) - res_norm = SQRT(DOT_PRODUCT(p_res, p_res)) + res_norm = NORM2(p_res) mixing_store%ncall = mixing_store%ncall + 1 IF (mixing_store%ncall == 1) THEN @@ -358,8 +357,7 @@ CONTAINS active_space_env%as_mix_r_buffer(ib, :) = p_res - active_space_env%as_mix_r_old active_space_env%as_mix_x_buffer(ib, :) = p_old - active_space_env%as_mix_x_old - delta_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & - active_space_env%as_mix_r_buffer(ib, :))) + delta_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) can_update = res_norm > 1.E-14_dp .AND. delta_norm > 1.E-14_dp IF (can_update) THEN diff --git a/src/qs_active_space_types.F b/src/qs_active_space_types.F index 8042e71158..c470db2ec7 100644 --- a/src/qs_active_space_types.F +++ b/src/qs_active_space_types.F @@ -237,8 +237,9 @@ CONTAINS DEALLOCATE (active_space_env%as_mix_x_buffer) END IF - IF (ASSOCIATED(active_space_env%pmat_inactive)) & + IF (ASSOCIATED(active_space_env%pmat_inactive)) THEN CALL dbcsr_deallocate_matrix_set(active_space_env%pmat_inactive) + END IF DEALLOCATE (active_space_env) END IF @@ -380,8 +381,9 @@ CONTAINS ! 1) Collect the amount of local data from each process nonzero_elements_local = 0 - IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) & + IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) THEN nonzero_elements_local = eri%nzerow_local(i12l) + END IF CALL mp_group%allgather(nonzero_elements_local, nonzero_elements_global) ! 2) Prepare arrays for communication (calculate the offsets and the total number of elements) diff --git a/src/qs_cdft_methods.F b/src/qs_cdft_methods.F index 03f8f75cdd..950b77b4f7 100644 --- a/src/qs_cdft_methods.F +++ b/src/qs_cdft_methods.F @@ -181,8 +181,9 @@ CONTAINS becke_control => cdft_control%becke_control group => cdft_control%group cutoffs => becke_control%cutoffs - IF (cdft_control%atomic_charges) & + IF (cdft_control%atomic_charges) THEN charge => cdft_control%charge + END IF in_memory = .FALSE. IF (cdft_control%save_pot) THEN in_memory = becke_control%in_memory @@ -221,7 +222,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) END DO END DO @@ -243,8 +244,9 @@ CONTAINS ! A subsequent check (atom_in_group) ensures that the gradients of these dummy atoms are correct IF (cdft_control%save_pot .OR. & becke_control%cavity_confine .OR. & - becke_control%should_skip) & + becke_control%should_skip) THEN is_constraint(catom(i)) = .TRUE. + END IF END DO bo = group(1)%weight%pw_grid%bounds_local dvol = group(1)%weight%pw_grid%dvol @@ -333,7 +335,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(iatom) == 0.0_dp) THEN r = becke_control%vector_buffer%position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) becke_control%vector_buffer%distance_vecs(:, iatom) = dist_vec becke_control%vector_buffer%distances(iatom) = dist1 ELSE @@ -346,7 +348,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -367,7 +369,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(jatom) == 0.0_dp) THEN r1 = becke_control%vector_buffer%position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) becke_control%vector_buffer%distance_vecs(:, jatom) = dist_vec becke_control%vector_buffer%distances(jatom) = dist2 ELSE @@ -380,7 +382,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) END IF IF (in_memory) THEN IF (becke_control%vector_buffer%store_vectors) THEN @@ -562,8 +564,9 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) & + IF (ALLOCATED(is_constraint)) THEN DEALLOCATE (is_constraint) + END IF DEALLOCATE (catom) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) @@ -1186,8 +1189,9 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN CPABORT("Becke control has not been allocated.") + END IF group => cdft_control%group ! Initialize nvar = SIZE(cdft_control%target) @@ -1228,9 +1232,10 @@ CONTAINS IF (is_becke .AND. (cdft_control%external_control .AND. becke_control%cavity_confine)) THEN ! With external control, we can use cavity_mat as a mask to kahan sum eps_cavity = becke_control%eps_cavity - IF (igroup /= 1) & + IF (igroup /= 1) THEN CALL cp_abort(__LOCATION__, & "Multiple constraints not yet supported by parallel mixed calculations.") + END IF dE(igroup) = dE(igroup) + sign*accurate_dot_product(group(igroup)%weight%array, rho_r(i)%array, & becke_control%cavity_mat, eps_cavity)*dvol ELSE @@ -1254,9 +1259,10 @@ CONTAINS END IF IF (dft_control%qs_control%gapw) THEN ! GAPW: add core charges (rho_hard - rho_soft) - IF (cdft_control%fragment_density) & + IF (cdft_control%fragment_density) THEN CALL cp_abort(__LOCATION__, & "Fragment constraints not yet compatible with GAPW.") + END IF ALLOCATE (gapw_offset(nvar, dft_control%nspins)) gapw_offset = 0.0_dp CALL get_qs_env(qs_env, rho0_mpole=rho0_mpole) @@ -1622,18 +1628,21 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN CPABORT("Becke control has not been allocated.") + END IF group => cdft_control%group dvol = group(1)%weight%pw_grid%dvol ! Fragment densities are meaningful only for some calculation types - IF (.NOT. qs_env%single_point_run) & + IF (.NOT. qs_env%single_point_run) THEN CALL cp_abort(__LOCATION__, & "CDFT fragment constraints are only compatible with single "// & "point calculations (run_type ENERGY or ENERGY_FORCE).") - IF (dft_control%qs_control%gapw) & + END IF + IF (dft_control%qs_control%gapw) THEN CALL cp_abort(__LOCATION__, & "CDFT fragment constraint not compatible with GAPW.") + END IF needs_spin_density = .FALSE. multiplier = 1.0_dp nfrag_spins = 1 @@ -1691,10 +1700,11 @@ CONTAINS CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, nelectron_total=nelectron_total) nelectron_frag = pw_integrate_function(rho_frag(1)) - IF (NINT(nelectron_frag) /= nelectron_total) & + IF (NINT(nelectron_frag) /= nelectron_total) THEN CALL cp_abort(__LOCATION__, & "The number of electrons in the reference and interacting "// & "configurations does not match. Check your fragment cube files.") + END IF ! Update constraint target value i.e. perform integration w_i*rho_frag_{tot/spin}*dr cdft_control%target = 0.0_dp DO igroup = 1, SIZE(group) diff --git a/src/qs_cdft_opt_types.F b/src/qs_cdft_opt_types.F index 92cb004adb..4a3ed616c6 100644 --- a/src/qs_cdft_opt_types.F +++ b/src/qs_cdft_opt_types.F @@ -135,10 +135,12 @@ CONTAINS TYPE(cdft_opt_type), POINTER :: cdft_opt_control IF (ASSOCIATED(cdft_opt_control)) THEN - IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) & + IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) THEN DEALLOCATE (cdft_opt_control%jacobian_vector) - IF (ALLOCATED(cdft_opt_control%jacobian_step)) & + END IF + IF (ALLOCATED(cdft_opt_control%jacobian_step)) THEN DEALLOCATE (cdft_opt_control%jacobian_step) + END IF DEALLOCATE (cdft_opt_control) END IF @@ -188,22 +190,26 @@ CONTAINS CALL section_vals_val_get(cdft_opt_section, "FACTOR_LS", & r_val=cdft_opt_control%factor_ls) IF (cdft_opt_control%factor_ls <= 0.0_dp .OR. & - cdft_opt_control%factor_ls >= 1.0_dp) & + cdft_opt_control%factor_ls >= 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "Keyword FACTOR_LS must be between 0.0 and 1.0.") + END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", explicit=exists) IF (exists) THEN CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", & i_vals=tmplist) - IF (SIZE(tmplist) /= 2) & + IF (SIZE(tmplist) /= 2) THEN CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes exactly two input values.") - IF (ANY(tmplist < 0)) & + END IF + IF (ANY(tmplist < 0)) THEN CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes only positive values.") - IF (ALL(tmplist == 0)) & + END IF + IF (ALL(tmplist == 0)) THEN CALL cp_abort(__LOCATION__, & "Both values to keyword JACOBIAN_FREQ cannot be zero.") + END IF cdft_opt_control%jacobian_freq(:) = tmplist(1:2) END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_RESTART", & @@ -275,9 +281,10 @@ CONTAINS IF (cdft_opt_control%jacobian_freq(2) > 0) THEN WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(2), " energy evaluation" - IF (cdft_opt_control%jacobian_freq(1) > 0) & + IF (cdft_opt_control%jacobian_freq(1) > 0) THEN WRITE (output_unit, '(T29,A,I4,A)') & - "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" + "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" + END IF ELSE WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" diff --git a/src/qs_cdft_scf_utils.F b/src/qs_cdft_scf_utils.F index f70237f2de..c7b6bf59a1 100644 --- a/src/qs_cdft_scf_utils.F +++ b/src/qs_cdft_scf_utils.F @@ -80,11 +80,12 @@ CONTAINS dft_control=dft_control) IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= 1 .AND. & - SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) & + SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) THEN CALL cp_abort(__LOCATION__, & cp_to_string(SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step))// & " values passed to keyword JACOBIAN_STEP, expected 1 or "// & cp_to_string(SIZE(scf_env%outer_scf%variables, 1))) + END IF ALLOCATE (dh(SIZE(scf_env%outer_scf%variables, 1))) IF (SIZE(dh) /= SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step)) THEN @@ -229,8 +230,9 @@ CONTAINS use_md_history = .TRUE. ! Check that none of the history values are identical in which case we should try something different DO i = 1, nvar - IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) & + IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) THEN use_md_history = .FALSE. + END IF END DO IF (use_md_history) THEN ALLOCATE (jacobian(nvar, nvar)) @@ -238,8 +240,9 @@ CONTAINS jacobian(i, i) = (gradient_history(i, 2) - gradient_history(i, 1))/ & (variable_history(i, 2) - variable_history(i, 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -253,17 +256,19 @@ CONTAINS IF (ihistory >= 2 .AND. .NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ! Next, try history from current SCF procedure nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF must be greater than or equal "// & "to 3 for optimizers that build the Jacobian from SCF history.") + END IF ALLOCATE (jacobian(nvar, nvar)) DO i = 1, nvar jacobian(i, i) = (scf_env%outer_scf%gradient(i, ihistory) - scf_env%outer_scf%gradient(i, ihistory - 1))/ & (scf_env%outer_scf%variables(i, ihistory) - scf_env%outer_scf%variables(i, ihistory - 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -294,11 +299,13 @@ CONTAINS CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control%jacobian_vector)) nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) & + IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) THEN CALL cp_abort(__LOCATION__, & "Too many or too few values defined for restarting inverse Jacobian.") - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + END IF + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian iwork = 1 DO i = 1, nvar diff --git a/src/qs_cdft_types.F b/src/qs_cdft_types.F index 74672844ab..3841d78f60 100644 --- a/src/qs_cdft_types.F +++ b/src/qs_cdft_types.F @@ -315,31 +315,43 @@ CONTAINS TYPE(becke_constraint_type), INTENT(INOUT) :: becke_control IF (becke_control%vector_buffer%store_vectors) THEN - IF (ALLOCATED(becke_control%vector_buffer%distances)) & + IF (ALLOCATED(becke_control%vector_buffer%distances)) THEN DEALLOCATE (becke_control%vector_buffer%distances) - IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) THEN DEALLOCATE (becke_control%vector_buffer%distance_vecs) - IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) THEN DEALLOCATE (becke_control%vector_buffer%position_vecs) - IF (ALLOCATED(becke_control%vector_buffer%R12)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%R12)) THEN DEALLOCATE (becke_control%vector_buffer%R12) - IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) THEN DEALLOCATE (becke_control%vector_buffer%pair_dist_vecs) + END IF END IF - IF (ASSOCIATED(becke_control%cutoffs)) & + IF (ASSOCIATED(becke_control%cutoffs)) THEN DEALLOCATE (becke_control%cutoffs) - IF (ASSOCIATED(becke_control%cutoffs_tmp)) & + END IF + IF (ASSOCIATED(becke_control%cutoffs_tmp)) THEN DEALLOCATE (becke_control%cutoffs_tmp) - IF (ASSOCIATED(becke_control%radii_tmp)) & + END IF + IF (ASSOCIATED(becke_control%radii_tmp)) THEN DEALLOCATE (becke_control%radii_tmp) - IF (ASSOCIATED(becke_control%radii)) & + END IF + IF (ASSOCIATED(becke_control%radii)) THEN DEALLOCATE (becke_control%radii) - IF (ASSOCIATED(becke_control%aij)) & + END IF + IF (ASSOCIATED(becke_control%aij)) THEN DEALLOCATE (becke_control%aij) - IF (ASSOCIATED(becke_control%cavity_mat)) & + END IF + IF (ASSOCIATED(becke_control%cavity_mat)) THEN DEALLOCATE (becke_control%cavity_mat) - IF (becke_control%cavity_confine) & + END IF + IF (becke_control%cavity_confine) THEN CALL release_hirshfeld_type(becke_control%cavity_env) + END IF END SUBROUTINE becke_control_release @@ -435,44 +447,60 @@ CONTAINS INTEGER :: i ! Constraint settings - IF (ASSOCIATED(cdft_control%atoms)) & + IF (ASSOCIATED(cdft_control%atoms)) THEN DEALLOCATE (cdft_control%atoms) - IF (ASSOCIATED(cdft_control%strength)) & + END IF + IF (ASSOCIATED(cdft_control%strength)) THEN DEALLOCATE (cdft_control%strength) - IF (ASSOCIATED(cdft_control%target)) & + END IF + IF (ASSOCIATED(cdft_control%target)) THEN DEALLOCATE (cdft_control%target) - IF (ASSOCIATED(cdft_control%value)) & + END IF + IF (ASSOCIATED(cdft_control%value)) THEN DEALLOCATE (cdft_control%value) - IF (ASSOCIATED(cdft_control%charges_fragment)) & + END IF + IF (ASSOCIATED(cdft_control%charges_fragment)) THEN DEALLOCATE (cdft_control%charges_fragment) - IF (ASSOCIATED(cdft_control%fragments)) & + END IF + IF (ASSOCIATED(cdft_control%fragments)) THEN DEALLOCATE (cdft_control%fragments) - IF (ASSOCIATED(cdft_control%is_constraint)) & + END IF + IF (ASSOCIATED(cdft_control%is_constraint)) THEN DEALLOCATE (cdft_control%is_constraint) - IF (ASSOCIATED(cdft_control%charge)) & + END IF + IF (ASSOCIATED(cdft_control%charge)) THEN DEALLOCATE (cdft_control%charge) + END IF ! Constraint atom groups IF (ASSOCIATED(cdft_control%group)) THEN DO i = 1, SIZE(cdft_control%group) - IF (ASSOCIATED(cdft_control%group(i)%atoms)) & + IF (ASSOCIATED(cdft_control%group(i)%atoms)) THEN DEALLOCATE (cdft_control%group(i)%atoms) - IF (ASSOCIATED(cdft_control%group(i)%coeff)) & - DEALLOCATE (cdft_control%group(i)%coeff) - IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) & - DEALLOCATE (cdft_control%group(i)%d_sum_const_dR) - IF (cdft_control%type == outer_scf_becke_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients)) & - DEALLOCATE (cdft_control%group(i)%gradients) - ELSE IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) & - DEALLOCATE (cdft_control%group(i)%gradients_x) - IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) & - DEALLOCATE (cdft_control%group(i)%gradients_y) - IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) & - DEALLOCATE (cdft_control%group(i)%gradients_z) END IF - IF (ASSOCIATED(cdft_control%group(i)%integrated)) & + IF (ASSOCIATED(cdft_control%group(i)%coeff)) THEN + DEALLOCATE (cdft_control%group(i)%coeff) + END IF + IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) THEN + DEALLOCATE (cdft_control%group(i)%d_sum_const_dR) + END IF + IF (cdft_control%type == outer_scf_becke_constraint) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients)) THEN + DEALLOCATE (cdft_control%group(i)%gradients) + END IF + ELSE IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) THEN + DEALLOCATE (cdft_control%group(i)%gradients_x) + END IF + IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) THEN + DEALLOCATE (cdft_control%group(i)%gradients_y) + END IF + IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) THEN + DEALLOCATE (cdft_control%group(i)%gradients_z) + END IF + END IF + IF (ASSOCIATED(cdft_control%group(i)%integrated)) THEN DEALLOCATE (cdft_control%group(i)%integrated) + END IF END DO DEALLOCATE (cdft_control%group) END IF @@ -488,21 +516,27 @@ CONTAINS ! Release OUTER_SCF types CALL cdft_opt_type_release(cdft_control%ot_control%cdft_opt_control) CALL cdft_opt_type_release(cdft_control%constraint_control%cdft_opt_control) - IF (ASSOCIATED(cdft_control%constraint%variables)) & + IF (ASSOCIATED(cdft_control%constraint%variables)) THEN DEALLOCATE (cdft_control%constraint%variables) - IF (ASSOCIATED(cdft_control%constraint%count)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%count)) THEN DEALLOCATE (cdft_control%constraint%count) - IF (ASSOCIATED(cdft_control%constraint%gradient)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN DEALLOCATE (cdft_control%constraint%gradient) - IF (ASSOCIATED(cdft_control%constraint%energy)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%energy)) THEN DEALLOCATE (cdft_control%constraint%energy) - IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN DEALLOCATE (cdft_control%constraint%inv_jacobian) + END IF ! Storage for mixed CDFT calculations IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations) - IF (ASSOCIATED(cdft_control%occupations(i)%array)) & + IF (ASSOCIATED(cdft_control%occupations(i)%array)) THEN DEALLOCATE (cdft_control%occupations(i)%array) + END IF END DO DEALLOCATE (cdft_control%occupations) END IF @@ -543,8 +577,9 @@ CONTAINS SUBROUTINE hirshfeld_control_release(hirshfeld_control) TYPE(hirshfeld_constraint_type), INTENT(INOUT) :: hirshfeld_control - IF (ASSOCIATED(hirshfeld_control%radii)) & + IF (ASSOCIATED(hirshfeld_control%radii)) THEN DEALLOCATE (hirshfeld_control%radii) + END IF CALL release_hirshfeld_type(hirshfeld_control%hirshfeld_env) END SUBROUTINE hirshfeld_control_release diff --git a/src/qs_cdft_utils.F b/src/qs_cdft_utils.F index c82c9cddc3..a5d0de5020 100644 --- a/src/qs_cdft_utils.F +++ b/src/qs_cdft_utils.F @@ -163,10 +163,11 @@ CONTAINS IF (becke_control%adjust) THEN IF (.NOT. ASSOCIATED(becke_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF ALLOCATE (becke_control%radii(SIZE(atomic_kind_set))) becke_control%radii(:) = becke_control%radii_tmp(:) DEALLOCATE (becke_control%radii_tmp) @@ -180,10 +181,11 @@ CONTAINS CASE (becke_cutoff_global) becke_control%cutoffs(:) = becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does not "// & "match number of atomic kinds in the input coordinate file.") + END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -238,7 +240,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) ! Set up heteronuclear cell partitioning using user defined radii IF (build) THEN @@ -329,8 +331,9 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) & + IF (ASSOCIATED(radii_list)) THEN DEALLOCATE (radii_list) + END IF END IF ! Form cavity by summing isolated Gaussian densities over constraint atoms NULLIFY (rs_cavity) @@ -425,9 +428,10 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (para_env%is_source() .AND. unit_nr < 1) & + IF (para_env%is_source() .AND. unit_nr < 1) THEN CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") + END IF CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, particles=particles) CALL cp_pw_to_cube(becke_control%cavity, unit_nr, "CAVITY", particles=particles, stride=stride, mpi_io=mpi_io) @@ -435,8 +439,9 @@ CONTAINS DEALLOCATE (stride) END IF END IF - IF (ALLOCATED(is_constraint)) & + IF (ALLOCATED(is_constraint)) THEN DEALLOCATE (is_constraint) + END IF CALL timestop(handle) END SUBROUTINE becke_constraint_init @@ -497,9 +502,10 @@ CONTAINS CALL section_vals_val_get(becke_section, "IN_MEMORY", l_val=becke_control%in_memory) IF (cdft_control%becke_control%cavity_confine) THEN CALL section_vals_val_get(becke_section, "CAVITY_SHAPE", i_val=becke_control%cavity_shape) - IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) & + IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) THEN CALL cp_abort(__LOCATION__, & "Activate keyword ADJUST_SIZE to use cavity shape USER.") + END IF CALL section_vals_val_get(becke_section, "CAVITY_RADIUS", r_val=becke_control%rcavity) CALL section_vals_val_get(becke_section, "EPS_CAVITY", r_val=becke_control%eps_cavity) CALL section_vals_val_get(becke_section, "CAVITY_PRINT", l_val=becke_control%print_cavity) @@ -550,8 +556,9 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) & + IF (SIZE(tmplist) < 1) THEN CPABORT("Each ATOM_GROUP must contain at least 1 atom.") + END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (cdft_control%group(k)%atoms(natoms)) @@ -618,8 +625,9 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) & + IF (SIZE(tmplist) < 1) THEN CPABORT("DUMMY_ATOMS must contain at least 1 atom.") + END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (dummylist(natoms)) @@ -635,16 +643,18 @@ CONTAINS ! Check for duplicates DO j = 1, natoms DO i = j + 1, natoms - IF (dummylist(i) == dummylist(j)) & + IF (dummylist(i) == dummylist(j)) THEN CPABORT("Duplicate atoms defined in section DUMMY_ATOMS.") + END IF END DO END DO ! Check that a dummy atom is not included in any ATOM_GROUP DO j = 1, SIZE(atomlist) DO i = 1, SIZE(dummylist) - IF (dummylist(i) == atomlist(j)) & + IF (dummylist(i) == atomlist(j)) THEN CALL cp_abort(__LOCATION__, & "Duplicate atoms defined in sections ATOM_GROUP and DUMMY_ATOMS.") + END IF END DO END DO END IF @@ -671,22 +681,24 @@ CONTAINS ALLOCATE (cdft_control%value(nvar)) ALLOCATE (cdft_control%target(nvar)) CALL section_vals_val_get(cdft_control_section, "STRENGTH", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) & + IF (SIZE(rtmplist) /= nvar) THEN CALL cp_abort(__LOCATION__, & "The length of keyword STRENGTH is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") + END IF DO j = 1, nvar cdft_control%strength(j) = rtmplist(j) END DO CALL section_vals_val_get(cdft_control_section, "TARGET", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) & + IF (SIZE(rtmplist) /= nvar) THEN CALL cp_abort(__LOCATION__, & "The length of keyword TARGET is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") + END IF DO j = 1, nvar cdft_control%target(j) = rtmplist(j) END DO @@ -756,8 +768,9 @@ CONTAINS outer_scf_section => section_vals_get_subs_vals(cdft_control_section, "OUTER_SCF") CALL outer_scf_read_parameters(cdft_control%constraint_control, outer_scf_section) IF (cdft_control%constraint_control%have_scf) THEN - IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) & + IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) THEN CPABORT("Unsupported CDFT constraint.") + END IF ! Constraint definitions CALL read_constraint_definitions(cdft_control, cdft_control_section) ! Constraint-specific initializations @@ -1014,10 +1027,11 @@ CONTAINS nkind = SIZE(qs_kind_set) ! Parse atomic radii for setting up Gaussian shape function IF (ASSOCIATED(hirshfeld_control%radii)) THEN - IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF ALLOCATE (radii_list(SIZE(hirshfeld_control%radii))) DO ikind = 1, SIZE(hirshfeld_control%radii) @@ -1130,8 +1144,9 @@ CONTAINS CALL qs_scf_cdft_constraint_info(iw, cdft_control) ! Print weight function(s) to cube file(s) whenever weight is (re)built - IF (cdft_control%print_weight .AND. cdft_control%need_pot) & + IF (cdft_control%print_weight .AND. cdft_control%need_pot) THEN CALL cdft_print_weight_function(qs_env) + END IF ! Print atomic CDFT charges IF (iw > 0 .AND. cdft_control%atomic_charges) THEN @@ -1290,9 +1305,10 @@ CONTAINS extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) ! Note PROGRAM_RUN_INFO section neeeds to be active! - IF (para_env%is_source() .AND. unit_nr < 1) & + IF (para_env%is_source() .AND. unit_nr < 1) THEN CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print CDFT weight function.") + END IF CALL cp_pw_to_cube(cdft_control%group(igroup)%weight, & unit_nr, & diff --git a/src/qs_charge_mixing.F b/src/qs_charge_mixing.F index d4981f4b0a..7682698cfc 100644 --- a/src/qs_charge_mixing.F +++ b/src/qs_charge_mixing.F @@ -117,8 +117,9 @@ CONTAINS mixer_max_weight = tblite_mixer_max_weight_default IF (PRESENT(tblite_mixer_max_weight)) mixer_max_weight = tblite_mixer_max_weight IF (mixer_max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (mixer_max_weight < mixer_min_weight) & + IF (mixer_max_weight < mixer_min_weight) THEN CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") + END IF mixer_weight_factor = tblite_mixer_weight_factor_default IF (PRESENT(tblite_mixer_weight_factor)) mixer_weight_factor = tblite_mixer_weight_factor IF (mixer_weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") @@ -183,21 +184,21 @@ CONTAINS IF ((iter_count == 1) .OR. (iter_count + 1 <= mixing_store%nskip_mixing)) THEN ! skip mixing mixing_store%iter_method = "NoMix" - ELSEIF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN + ELSE IF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN CALL mix_charges_only(mixing_store, charges, alpha, imin, ns, para_env) mixing_store%iter_method = "Mixing" - ELSEIF (mixing_method == gspace_mixing_nr) THEN + ELSE IF (mixing_method == gspace_mixing_nr) THEN CPABORT("Kerker method not available for Charge Mixing") - ELSEIF (mixing_method == pulay_mixing_nr) THEN + ELSE IF (mixing_method == pulay_mixing_nr) THEN CPABORT("Pulay method not available for Charge Mixing") - ELSEIF (mixing_method == broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr) THEN CALL broyden_mixing(mixing_store, charges, imin, nvec, ns, para_env) mixing_store%iter_method = "Broy." - ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN + ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN CPABORT("Modified Broyden mixing is only available for DFT density mixing") - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN CPABORT("Multisecant_mixing method not available for Charge Mixing") - ELSEIF (mixing_method == new_pulay_mixing_nr) THEN + ELSE IF (mixing_method == new_pulay_mixing_nr) THEN CPABORT("New Pulay method not available for Charge Mixing") END IF diff --git a/src/qs_chargemol.F b/src/qs_chargemol.F index 32f7c50516..e26a09e4fb 100644 --- a/src/qs_chargemol.F +++ b/src/qs_chargemol.F @@ -604,7 +604,7 @@ CONTAINS DO imo = 1, mos(1)%homo IF (nspins == 1) THEN WRITE (iwfx, '(A15)') "Alpha and Beta" - ELSEIF (dft_control%uks) THEN + ELSE IF (dft_control%uks) THEN WRITE (iwfx, '(A6)') "Alpha" ELSE CALL cp_abort(__LOCATION__, "This wavefunction type is currently"// & diff --git a/src/qs_charges_types.F b/src/qs_charges_types.F index 7771cd0745..b72dd7d539 100644 --- a/src/qs_charges_types.F +++ b/src/qs_charges_types.F @@ -73,11 +73,13 @@ CONTAINS REAL(KIND=dp), INTENT(in), OPTIONAL :: total_rho_core_rspace, total_rho_gspace qs_charges%total_rho_core_rspace = 0.0_dp - IF (PRESENT(total_rho_core_rspace)) & + IF (PRESENT(total_rho_core_rspace)) THEN qs_charges%total_rho_core_rspace = total_rho_core_rspace + END IF qs_charges%total_rho_gspace = 0.0_dp - IF (PRESENT(total_rho_gspace)) & + IF (PRESENT(total_rho_gspace)) THEN qs_charges%total_rho_gspace = total_rho_gspace + END IF qs_charges%total_rho_soft_gspace = 0.0_dp qs_charges%total_rho0_hard_lebedev = 0.0_dp qs_charges%total_rho_soft_gspace = 0.0_dp diff --git a/src/qs_cneo_methods.F b/src/qs_cneo_methods.F index 43081fa9b5..3485e11369 100644 --- a/src/qs_cneo_methods.F +++ b/src/qs_cneo_methods.F @@ -185,9 +185,10 @@ CONTAINS CALL get_gto_basis_set(nuc_soft_basis, npgf=npgf_s, gcc=gcc_s) ! There is such a limitation because we rely on atomic code to build S, T and U. ! Usually l=5 is more than enough, suppoting PB6H basis. - IF (maxl > lmat) & + IF (maxl > lmat) THEN CALL cp_abort(__LOCATION__, "Nuclear basis with angular momentum higher than "// & "atom_types::lmat is not supported yet.") + END IF set_index = 0 shell_index = 0 @@ -1074,7 +1075,7 @@ CONTAINS ! initial guess of f is taken from the result of last iteration CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) ! test if zero initial guess is better - IF (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN + IF (NORM2(r) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN CALL atom_solve_cneo(fmat, [0.0_dp, 0.0_dp, 0.0_dp], utrans, wfn, & ener, pmat, r_tmp, distance, nsgf, nne) IF (DOT_PRODUCT(r_tmp, r_tmp) < DOT_PRODUCT(r, r)) THEN @@ -1085,7 +1086,7 @@ CONTAINS max_iter = 20 iter = 0 ! using Newton's method to solve for f - DO WHILE (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp) + DO WHILE (NORM2(r) > 1.e-12_dp) iter = iter + 1 ! construct numerical Jacobian with one-side finite difference DO i = 1, 3 @@ -1118,13 +1119,13 @@ CONTAINS CALL invert_matrix_3x3(jac, jac_inv, det, try_svd=.TRUE.) END IF df = -RESHAPE(MATMUL(jac_inv, RESHAPE(r, [3, 1])), [3]) - df_norm = SQRT(DOT_PRODUCT(df, df)) + df_norm = NORM2(df) f_tmp = f r_tmp = r - g0 = SQRT(DOT_PRODUCT(r_tmp, r_tmp)) + g0 = NORM2(r_tmp) f = f_tmp + df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = SQRT(DOT_PRODUCT(r, r)) + g1 = NORM2(r) step = 1.0_dp DO WHILE (g1 >= g0) ! line search @@ -1136,7 +1137,7 @@ CONTAINS step = step*MAX(-g0p/(2.0_dp*(g1 - g0 - g0p)), 0.1_dp) f = f_tmp + step*df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = SQRT(DOT_PRODUCT(r, r)) + g1 = NORM2(r) END DO IF (iter >= max_iter) THEN CALL cp_warn(__LOCATION__, "CNEO nuclear position constraint solver failed to "// & diff --git a/src/qs_cneo_types.F b/src/qs_cneo_types.F index 40dd2fb323..f5661286f4 100644 --- a/src/qs_cneo_types.F +++ b/src/qs_cneo_types.F @@ -121,32 +121,45 @@ CONTAINS TYPE(rhoz_cneo_type), POINTER :: rhoz_cneo IF (ASSOCIATED(rhoz_cneo)) THEN - IF (ASSOCIATED(rhoz_cneo%pmat)) & + IF (ASSOCIATED(rhoz_cneo%pmat)) THEN DEALLOCATE (rhoz_cneo%pmat) - IF (ASSOCIATED(rhoz_cneo%core)) & + END IF + IF (ASSOCIATED(rhoz_cneo%core)) THEN DEALLOCATE (rhoz_cneo%core) - IF (ASSOCIATED(rhoz_cneo%vmat)) & + END IF + IF (ASSOCIATED(rhoz_cneo%vmat)) THEN DEALLOCATE (rhoz_cneo%vmat) - IF (ASSOCIATED(rhoz_cneo%fmat)) & + END IF + IF (ASSOCIATED(rhoz_cneo%fmat)) THEN DEALLOCATE (rhoz_cneo%fmat) - IF (ASSOCIATED(rhoz_cneo%wfn)) & + END IF + IF (ASSOCIATED(rhoz_cneo%wfn)) THEN DEALLOCATE (rhoz_cneo%wfn) - IF (ASSOCIATED(rhoz_cneo%cpc_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%cpc_h)) THEN DEALLOCATE (rhoz_cneo%cpc_h) - IF (ASSOCIATED(rhoz_cneo%cpc_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%cpc_s)) THEN DEALLOCATE (rhoz_cneo%cpc_s) - IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) THEN DEALLOCATE (rhoz_cneo%rho_rad_h) - IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) THEN DEALLOCATE (rhoz_cneo%rho_rad_s) - IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) THEN DEALLOCATE (rhoz_cneo%vrho_rad_h) - IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) THEN DEALLOCATE (rhoz_cneo%vrho_rad_s) - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) THEN DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_h) - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) THEN DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_s) + END IF END IF END SUBROUTINE deallocate_rhoz_cneo @@ -181,8 +194,9 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential - IF (ASSOCIATED(potential)) & + IF (ASSOCIATED(potential)) THEN CALL deallocate_cneo_potential(potential) + END IF ALLOCATE (potential) @@ -197,36 +211,51 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential IF (ASSOCIATED(potential)) THEN - IF (ASSOCIATED(potential%elec_conf)) & + IF (ASSOCIATED(potential%elec_conf)) THEN DEALLOCATE (potential%elec_conf) - IF (ASSOCIATED(potential%my_gcc_h)) & + END IF + IF (ASSOCIATED(potential%my_gcc_h)) THEN DEALLOCATE (potential%my_gcc_h) - IF (ASSOCIATED(potential%my_gcc_s)) & + END IF + IF (ASSOCIATED(potential%my_gcc_s)) THEN DEALLOCATE (potential%my_gcc_s) - IF (ASSOCIATED(potential%ovlp)) & + END IF + IF (ASSOCIATED(potential%ovlp)) THEN DEALLOCATE (potential%ovlp) - IF (ASSOCIATED(potential%kin)) & + END IF + IF (ASSOCIATED(potential%kin)) THEN DEALLOCATE (potential%kin) - IF (ASSOCIATED(potential%utrans)) & + END IF + IF (ASSOCIATED(potential%utrans)) THEN DEALLOCATE (potential%utrans) - IF (ASSOCIATED(potential%distance)) & + END IF + IF (ASSOCIATED(potential%distance)) THEN DEALLOCATE (potential%distance) - IF (ASSOCIATED(potential%harmonics)) & + END IF + IF (ASSOCIATED(potential%harmonics)) THEN CALL deallocate_harmonics_atom(potential%harmonics) - IF (ASSOCIATED(potential%Qlm_gg)) & + END IF + IF (ASSOCIATED(potential%Qlm_gg)) THEN DEALLOCATE (potential%Qlm_gg) - IF (ASSOCIATED(potential%gg)) & + END IF + IF (ASSOCIATED(potential%gg)) THEN DEALLOCATE (potential%gg) - IF (ASSOCIATED(potential%vgg)) & + END IF + IF (ASSOCIATED(potential%vgg)) THEN DEALLOCATE (potential%vgg) - IF (ASSOCIATED(potential%n2oindex)) & + END IF + IF (ASSOCIATED(potential%n2oindex)) THEN DEALLOCATE (potential%n2oindex) - IF (ASSOCIATED(potential%o2nindex)) & + END IF + IF (ASSOCIATED(potential%o2nindex)) THEN DEALLOCATE (potential%o2nindex) - IF (ASSOCIATED(potential%rad2l)) & + END IF + IF (ASSOCIATED(potential%rad2l)) THEN DEALLOCATE (potential%rad2l) - IF (ASSOCIATED(potential%oorad2l)) & + END IF + IF (ASSOCIATED(potential%oorad2l)) THEN DEALLOCATE (potential%oorad2l) + END IF DEALLOCATE (potential) END IF @@ -356,8 +385,9 @@ CONTAINS IF (PRESENT(z)) THEN potential%z = z potential%zeff = REAL(z, dp) - IF (ASSOCIATED(potential%elec_conf)) & + IF (ASSOCIATED(potential%elec_conf)) THEN CPABORT("elec_conf is already associated") + END IF ALLOCATE (potential%elec_conf(0:3)) potential%elec_conf(0:3) = ptable(z)%e_conv(0:3) CPASSERT(potential%mass == 0.0_dp) diff --git a/src/qs_collocate_density.F b/src/qs_collocate_density.F index 57925e0e86..c0df7d1eaf 100644 --- a/src/qs_collocate_density.F +++ b/src/qs_collocate_density.F @@ -1245,9 +1245,10 @@ CONTAINS CALL transfer_rs2pw(rs_rho, rhoc_r) - IF (PRESENT(total_rho_metal)) & + IF (PRESENT(total_rho_metal)) THEN !minus sign: account for the fact that rho_metal has opposite sign total_rho_metal = pw_integrate_function(rhoc_r, isign=-1) + END IF CALL pw_transfer(rhoc_r, rho_metal) CALL auxbas_pw_pool%give_back_pw(rhoc_r) @@ -1569,7 +1570,7 @@ CONTAINS IF (PRESENT(soft_valid)) my_soft_valid = soft_valid IF (PRESENT(task_list_external)) THEN task_list => task_list_external - ELSEIF (my_soft_valid) THEN + ELSE IF (my_soft_valid) THEN CALL get_ks_env(ks_env, task_list_soft=task_list) ELSE CALL get_ks_env(ks_env, task_list=task_list) @@ -2358,44 +2359,48 @@ CONTAINS END SELECT IF (iatom <= jatom) THEN - IF (iatom == lambda) & + IF (iatom == lambda) THEN CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - IF (jatom == lambda) & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF + IF (jatom == lambda) THEN CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF ELSE rab_inv = -rab - IF (jatom == lambda) & + IF (jatom == lambda) THEN CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - IF (iatom == lambda) & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF + IF (iatom == lambda) THEN CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF END IF END DO loop_tasks diff --git a/src/qs_core_hamiltonian.F b/src/qs_core_hamiltonian.F index ff5dfb464e..2ab3d7e09c 100644 --- a/src/qs_core_hamiltonian.F +++ b/src/qs_core_hamiltonian.F @@ -230,9 +230,10 @@ CONTAINS IF (dft_control%tddfpt2_control%enabled) THEN nders = 1 IF (dft_control%do_admm) THEN - IF (dft_control%admm_control%purification_method /= do_admm_purify_none) & + IF (dft_control%admm_control%purification_method /= do_admm_purify_none) THEN CALL cp_abort(__LOCATION__, & "Only purification method NONE is possible with TDDFT at the moment") + END IF END IF END IF @@ -336,9 +337,10 @@ CONTAINS nkind = SIZE(atomic_kind_set) CALL allocate_oce_set(oce, nkind) eps_fit = dft_control%qs_control%gapw_control%eps_fit - IF (ASSOCIATED(sap_oce)) & + IF (ASSOCIATED(sap_oce)) THEN CALL build_oce_matrices(oce%intac, calculate_forces, nder, qs_kind_set, particle_set, & sap_oce, eps_fit) + END IF END IF ! *** KG atomic potentials for nonadditive kinetic energy diff --git a/src/qs_core_matrices.F b/src/qs_core_matrices.F index 8ee4e78031..b57e8fd83c 100644 --- a/src/qs_core_matrices.F +++ b/src/qs_core_matrices.F @@ -567,7 +567,7 @@ CONTAINS END IF IF (PRESENT(matrixkp_t)) THEN CALL build_atomic_relmat(matrixkp_t(1, ic)%matrix, atomic_kind_set, qs_kind_set) - ELSEIF (PRESENT(matrix_t)) THEN + ELSE IF (PRESENT(matrix_t)) THEN CALL build_atomic_relmat(matrix_t(1)%matrix, atomic_kind_set, qs_kind_set) END IF ELSE diff --git a/src/qs_dcdr_utils.F b/src/qs_dcdr_utils.F index 9de800d1c3..9c83bf24e0 100644 --- a/src/qs_dcdr_utils.F +++ b/src/qs_dcdr_utils.F @@ -778,8 +778,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(dcdr_section, "REFERENCE_POINT", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) & + IF (reference == use_mom_ref_user) THEN CPABORT("User-defined reference point should be given explicitly") + END IF END IF CALL get_reference_point(rpoint=dcdr_env%ref_point, qs_env=qs_env, & diff --git a/src/qs_dftb_parameters.F b/src/qs_dftb_parameters.F index 35c95324c7..60d7083667 100644 --- a/src/qs_dftb_parameters.F +++ b/src/qs_dftb_parameters.F @@ -204,10 +204,11 @@ CONTAINS CALL parser_release(parser) END BLOCK END IF - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "Failure in assigning KINDS <"//TRIM(iname)//"> and <"//TRIM(jname)// & "> to a DFTB interaction pair!") + END IF END DO END DO ! reading the files diff --git a/src/qs_dftb_utils.F b/src/qs_dftb_utils.F index 79a4972d93..43440135a1 100644 --- a/src/qs_dftb_utils.F +++ b/src/qs_dftb_utils.F @@ -62,8 +62,9 @@ CONTAINS TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - IF (ASSOCIATED(dftb_parameter)) & + IF (ASSOCIATED(dftb_parameter)) THEN CALL deallocate_dftb_atom_param(dftb_parameter) + END IF ALLOCATE (dftb_parameter) diff --git a/src/qs_dispersion_cnum.F b/src/qs_dispersion_cnum.F index 9d5d96d71a..2632a12933 100644 --- a/src/qs_dispersion_cnum.F +++ b/src/qs_dispersion_cnum.F @@ -1261,9 +1261,9 @@ CONTAINS rcut = rcut + 0.1_dp IF (cnfun == 1) THEN CALL cnparam_d3(rcut, rcov, dispersion_env%k1, cnab, dcnab) - ELSEIF (cnfun == 2) THEN + ELSE IF (cnfun == 2) THEN CALL modcn_d3(rcut, rcov, cnab, dcnab) - ELSEIF (cnfun == 3) THEN + ELSE IF (cnfun == 3) THEN den = 0.0_dp CALL cn_d4per(rcut, rcov, den, cnab, dcnab) ELSE @@ -1367,9 +1367,9 @@ CONTAINS rcovab = dispersion_env%rcov(za) + dispersion_env%rcov(zb) IF (cnfun == 1) THEN CALL cnparam_d3(rcc, rcovab, dispersion_env%k1, cnab, dcnab) - ELSEIF (cnfun == 2) THEN + ELSE IF (cnfun == 2) THEN CALL modcn_d3(rcc, rcovab, cnab, dcnab) - ELSEIF (cnfun == 3) THEN + ELSE IF (cnfun == 3) THEN den = ABS(dispersion_env%eneg(za) - dispersion_env%eneg(zb)) CALL cn_d4per(rcc, rcovab, den, cnab, dcnab) ELSE diff --git a/src/qs_dispersion_d3.F b/src/qs_dispersion_d3.F index 83f2a1ed5d..0afac622bf 100644 --- a/src/qs_dispersion_d3.F +++ b/src/qs_dispersion_d3.F @@ -984,7 +984,7 @@ CONTAINS IF (rab >= ru) THEN fcc = 0._dp dfcc = 0._dp - ELSEIF (rab <= rl) THEN + ELSE IF (rab <= rl) THEN fcc = 1._dp dfcc = 0._dp ELSE diff --git a/src/qs_dispersion_nonloc.F b/src/qs_dispersion_nonloc.F index fa63eaf80f..e4cce04a17 100644 --- a/src/qs_dispersion_nonloc.F +++ b/src/qs_dispersion_nonloc.F @@ -583,7 +583,7 @@ CONTAINS COMPLEX(KIND=dp) :: uu COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: theta - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw(:, :) + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw INTEGER :: handle, ig, iq, l, m, nl_type, nqs, & q1_i, q2_i LOGICAL :: use_virial diff --git a/src/qs_dispersion_pairpot.F b/src/qs_dispersion_pairpot.F index 3f68b76445..26d6bff01b 100644 --- a/src/qs_dispersion_pairpot.F +++ b/src/qs_dispersion_pairpot.F @@ -188,11 +188,12 @@ CONTAINS disp%defined = .FALSE. END IF ! Check if the parameter is defined - IF (.NOT. disp%defined) & + IF (.NOT. disp%defined) THEN CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") + END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO CASE (vdw_pairpot_dftd3, vdw_pairpot_dftd3bj) @@ -274,11 +275,12 @@ CONTAINS ELSE disp%defined = .FALSE. END IF - IF (.NOT. disp%defined) & + IF (.NOT. disp%defined) THEN CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") + END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO @@ -479,11 +481,11 @@ CONTAINS IF (dispersion_env%pp_type == vdw_pairpot_dftd2) THEN CALL calculate_dispersion_d2_pairpot(qs_env, dispersion_env, evdw, calculate_forces, atevdw) - ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & - dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN + ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & + dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN CALL calculate_dispersion_d3_pairpot(qs_env, dispersion_env, evdw, calculate_forces, & unit_nr, atevdw) - ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN + ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN IF (dispersion_env%lrc) THEN CPABORT("Long range correction with DFTD4 not implemented") END IF diff --git a/src/qs_efield_berry.F b/src/qs_efield_berry.F index 48de8e24b0..bf69918821 100644 --- a/src/qs_efield_berry.F +++ b/src/qs_efield_berry.F @@ -263,7 +263,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -296,8 +296,9 @@ CONTAINS END IF END IF IF (use_virial) THEN - IF (para_env%mepos == 0) & + IF (para_env%mepos == 0) THEN CALL virial_pair_force(virial%pv_virial, 1.0_dp, forcea, ria) + END IF END IF END DO qi = AIMAG(LOG(zi)) @@ -752,7 +753,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/qs_electric_field_gradient.F b/src/qs_electric_field_gradient.F index c706d01b8e..31adb830c8 100644 --- a/src/qs_electric_field_gradient.F +++ b/src/qs_electric_field_gradient.F @@ -153,7 +153,7 @@ CONTAINS smoothing = .FALSE. ecut = 1.e10_dp ! not used, just to have vars defined sigma = 1._dp ! not used, just to have vars defined - ELSEIF (ecut == -1._dp .AND. sigma == -1._dp) THEN + ELSE IF (ecut == -1._dp .AND. sigma == -1._dp) THEN smoothing = .TRUE. CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL auxbas_pw_pool%create_pw(dvr2rs) diff --git a/src/qs_energy.F b/src/qs_energy.F index 9ef6f0d88a..2c83157a0d 100644 --- a/src/qs_energy.F +++ b/src/qs_energy.F @@ -167,8 +167,9 @@ CONTAINS END IF IF (dft_control%tddfpt2_control%do_smearing) THEN - IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) & + IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) THEN CPABORT("Smearing occupation not associated.") + END IF CALL deallocate_fermi_params(dft_control%tddfpt2_control%smeared_occup) END IF IF (dft_control%qs_control%lrigpw) THEN diff --git a/src/qs_energy_init.F b/src/qs_energy_init.F index 7e82c28f28..48655f12db 100644 --- a/src/qs_energy_init.F +++ b/src/qs_energy_init.F @@ -283,12 +283,14 @@ CONTAINS CALL set_kpoint_info(kpoints, sab_nl_nosym=sab_nl_nosym) END IF IF (dft_control%qs_control%cdft) THEN - IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) & + IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) THEN dft_control%qs_control%cdft_control%need_pot = .TRUE. + END IF IF (ASSOCIATED(dft_control%qs_control%cdft_control%group)) THEN ! In case CDFT weight function was built beforehand (in mixed force_eval) - IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) & + IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) THEN dft_control%qs_control%cdft_control%need_pot = .FALSE. + END IF END IF END IF @@ -300,13 +302,13 @@ CONTAINS CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.FALSE.) CALL get_qs_env(qs_env=qs_env, dispersion_env=dispersion_env, energy=energy) CALL calculate_dispersion_pairpot(qs_env, dispersion_env, energy%dispersion, calc_forces) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL qs_env_update_s_mstruct(qs_env) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.FALSE.) ELSE diff --git a/src/qs_energy_window.F b/src/qs_energy_window.F index 6c41baed36..5e782d11cf 100644 --- a/src/qs_energy_window.F +++ b/src/qs_energy_window.F @@ -88,7 +88,7 @@ CONTAINS INTEGER :: handle, i, lanzcos_max_iter, last, nao, & nelectron_total, newton_schulz_order, & next, nwindows, print_unit, unit_nr - INTEGER, DIMENSION(:), POINTER :: stride(:) + INTEGER, DIMENSION(:), POINTER :: stride LOGICAL :: mpi_io, print_cube, restrict_range REAL(KIND=dp) :: bin_width, density_ewindow_total, density_total, energy_range, fermi_level, & filter_eps, frob_norm, lanzcos_threshold, lower_bound, occupation, upper_bound diff --git a/src/qs_environment.F b/src/qs_environment.F index bf7ae4766d..08194e09b6 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -417,14 +417,17 @@ CONTAINS do_tddfpt_unsupported_kpoints = tddfpt_kernel /= tddfpt_kernel_none IF (.NOT. do_tddfpt_unsupported_kpoints) THEN CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) & + IF (use_real_wfn) THEN CALL cp_abort(__LOCATION__, "K-point TDDFPT requires complex wavefunctions.") + END IF END IF CALL section_vals_val_get(tddfpt_section, "DO_BSE", l_val=do_bse) - IF (.NOT. do_bse) & + IF (.NOT. do_bse) THEN CALL section_vals_val_get(tddfpt_section, "DO_BSE_W_ONLY", l_val=do_bse) - IF (.NOT. do_bse) & + END IF + IF (.NOT. do_bse) THEN CALL section_vals_val_get(tddfpt_section, "DO_BSE_GW_ONLY", l_val=do_bse) + END IF END IF do_active_space = .FALSE. active_space_section => section_vals_get_subs_vals(qs_env%input, "DFT%ACTIVE_SPACE") @@ -471,10 +474,11 @@ CONTAINS l_val=do_wfc_low_scaling) CALL section_vals_val_get(qs_env%input, "DFT%XC%WF_CORRELATION%LOW_SCALING%DO_KPOINTS", & l_val=do_wfc_low_scaling_kpoints) - IF (.NOT. do_bse) & + IF (.NOT. do_bse) THEN CALL section_vals_val_get(qs_env%input, & "DFT%XC%WF_CORRELATION%RI_RPA%GW%BSE%_SECTION_PARAMETERS_", & l_val=do_bse) + END IF END IF CALL restrict_unsupported_atomic_kpoint_symmetry(kpoints, method_id, do_hfx, do_exx, do_gw, & do_tddfpt_unsupported_kpoints, & @@ -534,8 +538,9 @@ CONTAINS ! more kpoint stuff CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints, blacs_env=blacs_env) IF (do_kpoints) THEN - IF (dft_control%qs_control%do_ls_scf) & + IF (dft_control%qs_control%do_ls_scf) THEN CPABORT("DFT%KPOINTS are not implemented with QS/LS_SCF; use a real-space supercell instead.") + END IF CALL kpoint_env_initialize(kpoints, para_env, blacs_env, with_aux_fit=dft_control%do_admm) CALL kpoint_initialize_mos(kpoints, qs_env%mos) CALL get_qs_env(qs_env=qs_env, wf_history=wf_history) @@ -1189,7 +1194,7 @@ CONTAINS CALL ewald_pw_create(ewald_pw, ewald_env, cell, cell_ref, print_section=print_section) CALL set_qs_env(qs_env, ewald_env=ewald_env, ewald_pw=ewald_pw) END IF - ELSEIF (dft_control%qs_control%method_id == do_method_xtb) THEN + ELSE IF (dft_control%qs_control%method_id == do_method_xtb) THEN ! Read xTB parameter file xtb_control => dft_control%qs_control%xtb_control CALL get_qs_env(qs_env, nkind=nkind) @@ -1623,11 +1628,13 @@ CONTAINS IF (.NOT. dft_control%qs_control%do_ls_scf) THEN SELECT CASE (dft_control%qs_control%method_id) CASE (do_method_dftb) - IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & + IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN scf_control%max_scf = dft_control%qs_control%dftb_control%tblite_mixer_iterations + END IF CASE (do_method_xtb) - IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & + IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN scf_control%max_scf = dft_control%qs_control%xtb_control%tblite_mixer_iterations + END IF END SELECT END IF @@ -1873,7 +1880,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN + ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd3bj dispersion_env%eps_cn = dftb_control%epscn @@ -1889,7 +1896,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN + ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd2 dispersion_env%exp_pre = dftb_control%exp_pre @@ -2217,10 +2224,11 @@ CONTAINS n_mo(1) = n_mo(1) + scf_control%added_mos(1) IF (dft_control%nspins == 2) THEN - IF (n_mo(2) > n_mo(1)) & + IF (n_mo(2) > n_mo(1)) THEN CALL cp_warn(__LOCATION__, & "More beta than alpha MOs requested. "// & "The number of beta MOs will be reduced to the number alpha MOs.") + END IF n_mo(2) = MIN(n_mo(1), n_mo(2)) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2230,10 +2238,11 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) IF (do_kpoints .AND. dft_control%nspins == 2) THEN ! we need equal number of calculated states - IF (n_mo(2) /= n_mo(1)) & + IF (n_mo(2) /= n_mo(1)) THEN CALL cp_warn(__LOCATION__, & "Kpoints: Different number of MOs requested. "// & "The number of beta MOs will be set to the number alpha MOs.") + END IF n_mo(2) = n_mo(1) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2480,7 +2489,7 @@ CONTAINS "- Orbital basis functions: ", maxlgto, & "- Local part of the GTH pseudopotential: ", maxlppl, & "- Non-local part of the GTH pseudopotential: ", maxlppnl - ELSEIF (maxlppl > -1) THEN + ELSE IF (maxlppl > -1) THEN WRITE (UNIT=output_unit, FMT="(/,T3,A,(T30,A,T75,I6))") & "Maximum angular momentum of the", & "- Orbital basis functions: ", maxlgto, & diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index a7391d5956..68fb602d1c 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -744,20 +744,27 @@ CONTAINS ! Resp charges IF (PRESENT(rhs)) rhs => qs_env%rhs - IF (PRESENT(local_rho_set)) & + IF (PRESENT(local_rho_set)) THEN local_rho_set => qs_env%local_rho_set - IF (PRESENT(rho_atom_set)) & + END IF + IF (PRESENT(rho_atom_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rho_atom_set=rho_atom_set) - IF (PRESENT(rho0_atom_set)) & + END IF + IF (PRESENT(rho0_atom_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_atom_set=rho0_atom_set) - IF (PRESENT(rho0_mpole)) & + END IF + IF (PRESENT(rho0_mpole)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_mpole) - IF (PRESENT(rhoz_set)) & + END IF + IF (PRESENT(rhoz_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rhoz_set=rhoz_set) - IF (PRESENT(rhoz_cneo_set)) & + END IF + IF (PRESENT(rhoz_cneo_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rhoz_cneo_set=rhoz_cneo_set) - IF (PRESENT(ecoul_1c)) & + END IF + IF (PRESENT(ecoul_1c)) THEN CALL get_hartree_local(qs_env%hartree_local, ecoul_1c=ecoul_1c) + END IF IF (PRESENT(rho0_s_rs)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_m) IF (ASSOCIATED(rho0_m)) THEN @@ -1488,10 +1495,12 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) & + IF (ASSOCIATED(qs_env%gradient_history)) THEN DEALLOCATE (qs_env%gradient_history) - IF (ASSOCIATED(qs_env%variable_history)) & + END IF + IF (ASSOCIATED(qs_env%variable_history)) THEN DEALLOCATE (qs_env%variable_history) + END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1722,10 +1731,12 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) & + IF (ASSOCIATED(qs_env%gradient_history)) THEN DEALLOCATE (qs_env%gradient_history) - IF (ASSOCIATED(qs_env%variable_history)) & + END IF + IF (ASSOCIATED(qs_env%variable_history)) THEN DEALLOCATE (qs_env%variable_history) + END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) diff --git a/src/qs_external_potential.F b/src/qs_external_potential.F index ec813c6695..e77b4b3655 100644 --- a/src/qs_external_potential.F +++ b/src/qs_external_potential.F @@ -91,7 +91,7 @@ CONTAINS qs_env%sim_step, qs_env%sim_time, & scaling_factor) dft_control%eval_external_potential = .FALSE. - ELSEIF (dft_control%expot_control%read_from_cube) THEN + ELSE IF (dft_control%expot_control%read_from_cube) THEN scaling_factor = dft_control%expot_control%scaling_factor CALL cp_cube_to_pw(v_ee, 'pot.cube', scaling_factor) dft_control%eval_external_potential = .FALSE. diff --git a/src/qs_fb_env_types.F b/src/qs_fb_env_types.F index 3b580c1ac1..0b0173c14b 100644 --- a/src/qs_fb_env_types.F +++ b/src/qs_fb_env_types.F @@ -266,24 +266,33 @@ CONTAINS CPASSERT(ASSOCIATED(fb_env%obj)) CPASSERT(fb_env%obj%ref_count > 0) - IF (PRESENT(rcut)) & + IF (PRESENT(rcut)) THEN rcut => fb_env%obj%rcut - IF (PRESENT(filter_temperature)) & + END IF + IF (PRESENT(filter_temperature)) THEN filter_temperature = fb_env%obj%filter_temperature - IF (PRESENT(auto_cutoff_scale)) & + END IF + IF (PRESENT(auto_cutoff_scale)) THEN auto_cutoff_scale = fb_env%obj%auto_cutoff_scale - IF (PRESENT(eps_default)) & + END IF + IF (PRESENT(eps_default)) THEN eps_default = fb_env%obj%eps_default - IF (PRESENT(atomic_halos)) & + END IF + IF (PRESENT(atomic_halos)) THEN CALL fb_atomic_halo_list_associate(atomic_halos, fb_env%obj%atomic_halos) - IF (PRESENT(trial_fns)) & + END IF + IF (PRESENT(trial_fns)) THEN CALL fb_trial_fns_associate(trial_fns, fb_env%obj%trial_fns) - IF (PRESENT(collective_com)) & + END IF + IF (PRESENT(collective_com)) THEN collective_com = fb_env%obj%collective_com - IF (PRESENT(local_atoms)) & + END IF + IF (PRESENT(local_atoms)) THEN local_atoms => fb_env%obj%local_atoms - IF (PRESENT(nlocal_atoms)) & + END IF + IF (PRESENT(nlocal_atoms)) THEN nlocal_atoms = fb_env%obj%nlocal_atoms + END IF END SUBROUTINE fb_env_get ! ********************************************************************** @@ -329,32 +338,38 @@ CONTAINS END IF fb_env%obj%rcut => rcut END IF - IF (PRESENT(filter_temperature)) & + IF (PRESENT(filter_temperature)) THEN fb_env%obj%filter_temperature = filter_temperature - IF (PRESENT(auto_cutoff_scale)) & + END IF + IF (PRESENT(auto_cutoff_scale)) THEN fb_env%obj%auto_cutoff_scale = auto_cutoff_scale - IF (PRESENT(eps_default)) & + END IF + IF (PRESENT(eps_default)) THEN fb_env%obj%eps_default = eps_default + END IF IF (PRESENT(atomic_halos)) THEN CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) CALL fb_atomic_halo_list_associate(fb_env%obj%atomic_halos, atomic_halos) END IF IF (PRESENT(trial_fns)) THEN - IF (fb_trial_fns_has_data(trial_fns)) & + IF (fb_trial_fns_has_data(trial_fns)) THEN CALL fb_trial_fns_retain(trial_fns) + END IF CALL fb_trial_fns_release(fb_env%obj%trial_fns) CALL fb_trial_fns_associate(fb_env%obj%trial_fns, trial_fns) END IF - IF (PRESENT(collective_com)) & + IF (PRESENT(collective_com)) THEN fb_env%obj%collective_com = collective_com + END IF IF (PRESENT(local_atoms)) THEN IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE (fb_env%obj%local_atoms) END IF fb_env%obj%local_atoms => local_atoms END IF - IF (PRESENT(nlocal_atoms)) & + IF (PRESENT(nlocal_atoms)) THEN fb_env%obj%nlocal_atoms = nlocal_atoms + END IF END SUBROUTINE fb_env_set END MODULE qs_fb_env_types diff --git a/src/qs_fb_filter_matrix_methods.F b/src/qs_fb_filter_matrix_methods.F index 1be7bcdc2a..5b94b8fdc0 100644 --- a/src/qs_fb_filter_matrix_methods.F +++ b/src/qs_fb_filter_matrix_methods.F @@ -480,7 +480,7 @@ CONTAINS INTEGER :: handle, handle_mpi, iatom_global, iatom_in_halo, ind, ipair, ipe, itrial, & jatom_global, jatom_in_halo, jkind, natoms_global, natoms_in_halo, ncols_atmatrix, & - ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode, stat + ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs_recv, pairs_send INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data, ind_in_halo, & @@ -583,9 +583,7 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_H_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -603,9 +601,7 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_S_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -797,7 +793,7 @@ CONTAINS INTEGER :: handle, iatom_global, iatom_in_halo, itrial, jatom_global, jatom_in_halo, jkind, & natoms_global, natoms_in_halo, ncols_atmatrix, ncols_blk, ncols_blk_max, nrows_atmatrix, & - nrows_blk, nrows_blk_max, stat + nrows_blk, nrows_blk_max INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data INTEGER, DIMENSION(:), POINTER :: halo_atoms, ntfns, row_block_size_data @@ -841,9 +837,7 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_H_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -859,9 +853,7 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_S_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -906,9 +898,6 @@ CONTAINS nrows_blk = row_block_size_data(iatom_global) ncols_blk = ntfns(jkind) - ! ALLOCATE(mat_blk(nrows_blk,ncols_blk) STAT=stat) - ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) - ! do it column-wise one trial function at a time DO itrial = 1, ntfns(jkind) CALL dgemv("N", & diff --git a/src/qs_force.F b/src/qs_force.F index 3bf365e4c1..ab1f8d5ece 100644 --- a/src/qs_force.F +++ b/src/qs_force.F @@ -227,8 +227,9 @@ CONTAINS CALL calc_c_mat_force(qs_env) IF (dft_control%do_admm) CALL rt_admm_force(qs_env) - IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) & + IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) THEN CALL velocity_gauge_nl_force(qs_env, particle_set) + END IF END IF ! from an eventual Mulliken restraint IF (dft_control%qs_control%mulliken_restraint) THEN @@ -286,18 +287,18 @@ CONTAINS CALL build_se_core_matrix(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.TRUE.) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.TRUE.) ELSE CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) END IF - ELSEIF (perform_ec) THEN + ELSE IF (perform_ec) THEN ! Calculates core and grid based forces CALL energy_correction(qs_env, ec_init=.FALSE., calculate_forces=.TRUE.) ELSE @@ -305,10 +306,12 @@ CONTAINS CALL build_core_hamiltonian_matrix(qs_env=qs_env, calculate_forces=.TRUE.) ! The above line reset the core H, which should be re-updated in case a TD field is applied: IF (qs_env%run_rtp) THEN - IF (dft_control%apply_efield_field) & + IF (dft_control%apply_efield_field) THEN CALL efield_potential_lengh_gauge(qs_env) - IF (dft_control%rtp_control%velocity_gauge) & + END IF + IF (dft_control%rtp_control%velocity_gauge) THEN CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) + END IF END IF CALL calculate_ecore_self(qs_env) @@ -368,9 +371,9 @@ CONTAINS t3=dummy_real) END IF END IF - ELSEIF (perform_ec) THEN + ELSE IF (perform_ec) THEN ! energy correction forces postponed - ELSEIF (qs_env%harris_method) THEN + ELSE IF (qs_env%harris_method) THEN ! Harris method forces already done in harris_energy_correction ELSE ! Compute grid-based forces diff --git a/src/qs_fxc.F b/src/qs_fxc.F index 6fe283637e..1380dc5c1d 100644 --- a/src/qs_fxc.F +++ b/src/qs_fxc.F @@ -371,8 +371,9 @@ CONTAINS END DO ! Create fields for mGGA functionals. This implementation is not ready yet! IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) & + IF (.NOT. ASSOCIATED(tau1_r)) THEN CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") + END IF ALLOCATE (fxc_tau(spindim), gxc_tau(nspins)) DO ispin = 1, spindim CALL pw_pool%create_pw(fxc_tau(ispin)) diff --git a/src/qs_gapw_densities.F b/src/qs_gapw_densities.F index 567c7e99bb..2aaa407afc 100644 --- a/src/qs_gapw_densities.F +++ b/src/qs_gapw_densities.F @@ -158,10 +158,11 @@ CONTAINS END IF !Calculate rho0_h and rho0_s on the radial grids centered on the atomic position - IF (my_do_rho0) & + IF (my_do_rho0) THEN CALL calculate_rho0_atom(gapw_control, rho_atom_set, rhoz_cneo_set, rho0_atom_set, & rho0_mpole, atom_list, natom, ikind, my_kind_set(ikind), & rho0_h_tot) + END IF END DO !Do not mess with charges if using a non-default kind_set diff --git a/src/qs_gspace_mixing.F b/src/qs_gspace_mixing.F index eb64b2fbfa..e88926315d 100644 --- a/src/qs_gspace_mixing.F +++ b/src/qs_gspace_mixing.F @@ -164,25 +164,25 @@ CONTAINS CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSEIF (mixing_method == gspace_mixing_nr) THEN + ELSE IF (mixing_method == gspace_mixing_nr) THEN CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSEIF (mixing_method == pulay_mixing_nr) THEN + ELSE IF (mixing_method == pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Pulay" - ELSEIF (mixing_method == new_pulay_mixing_nr) THEN + ELSE IF (mixing_method == new_pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "NPulay" - ELSEIF (mixing_method == broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr) THEN CALL cite_reference(Broyden1965) CALL broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Broy." - ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN + ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN CALL cite_reference(Johnson1988) CALL modified_broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "MBroy" - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN CPASSERT(.NOT. gapw) CALL multisecant_mixing(mixing_store, rho, para_env) mixing_store%iter_method = "MSec." @@ -1446,7 +1446,7 @@ CONTAINS DO jb = 1, nb + 1 IF (jb < ib) THEN kb = jb - ELSEIF (jb > ib) THEN + ELSE IF (jb > ib) THEN kb = jb - 1 ELSE CYCLE @@ -1564,7 +1564,7 @@ CONTAINS AIMAG(pgn(ig))*AIMAG(pgn(ig)) END DO CALL para_env%sum(pgn_norm) - ELSEIF (use_zgemm_rev) THEN + ELSE IF (use_zgemm_rev) THEN CALL zgemv("N", nb, ng_global, cone, a_matrix(1, 1), & nb, gn_global(1), 1, czero, tmp_vec(1), 1) diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index 5c5acca6c7..0df0b262a5 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -330,8 +330,9 @@ CONTAINS IF (j /= 0) THEN filename = TRIM(file_name)//".bak-"//ADJUSTL(cp_to_string(j)) END IF - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN INQUIRE (FILE=filename, exist=exist) + END IF CALL para_env%bcast(exist) IF ((.NOT. exist) .AND. (i < not_read)) THEN not_read = i @@ -417,7 +418,7 @@ CONTAINS IF (has_unit_metric) THEN CALL make_basis_simple(mo_coeff, nmo) - ELSEIF (dft_control%smear) THEN + ELSE IF (dft_control%smear) THEN CALL make_basis_lowdin(vmatrix=mo_coeff, ncol=nmo, & matrix_s=s_sparse(1)%matrix) ELSE @@ -937,11 +938,11 @@ CONTAINS WRITE (ounit, *) 'wrong', i, SUM(buff**2) END IF END IF - length = SQRT(DOT_PRODUCT(buff(:, 1), buff(:, 1))) + length = NORM2(buff(:, 1)) buff(:, :) = buff(:, :)/length DO j = i + 1, nmo CALL cp_fm_get_submatrix(mo_coeff, buff2, 1, j, nao, 1) - length = SQRT(DOT_PRODUCT(buff2(:, 1), buff2(:, 1))) + length = NORM2(buff2(:, 1)) buff2(:, :) = buff2(:, :)/length IF (ABS(DOT_PRODUCT(buff(:, 1), buff2(:, 1)) - 1.0_dp) < 1E-10_dp) THEN IF (ounit > 0) THEN @@ -1289,10 +1290,10 @@ CONTAINS lmax=maxll, occupation=edftb) maxll = MIN(maxll, maxl) econf(0:maxl) = edftb(0:maxl) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, z=z, natorb=nsgf, nao=naox, lao=laox, occupation=occupation) - ELSEIF (has_pot) THEN + ELSE IF (has_pot) THEN CALL get_atomic_kind(atomic_kind_set(ikind), z=z) CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff) maxll = MIN(SIZE(elec_conf) - 1, maxl) @@ -1334,7 +1335,7 @@ CONTAINS END SELECT END DO END DO - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN DO iatom = 1, natom atom_a = atom_list(iatom) isgfa = first_sgf(atom_a) @@ -1351,7 +1352,7 @@ CONTAINS END DO END IF END DO - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN yy = REAL(dft_control%charge, KIND=dp)/REAL(nao, KIND=dp) DO iatom = 1, natom atom_a = atom_list(iatom) diff --git a/src/qs_integrate_potential_product.F b/src/qs_integrate_potential_product.F index decbe53525..e99302334e 100644 --- a/src/qs_integrate_potential_product.F +++ b/src/qs_integrate_potential_product.F @@ -417,54 +417,58 @@ CONTAINS END IF IF (iatom <= jatom) THEN - IF (iatom == lambda) & + IF (iatom == lambda) THEN CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) - IF (jatom == lambda) & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) + END IF + IF (jatom == lambda) THEN CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) + END IF ELSE rab_inv = -rab - IF (iatom == lambda) & + IF (iatom == lambda) THEN CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) - IF (jatom == lambda) & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) + END IF + IF (jatom == lambda) THEN CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) + END IF END IF new_set_pair_coming = .FALSE. diff --git a/src/qs_kind_types.F b/src/qs_kind_types.F index 8928bc4553..3367d1ec57 100644 --- a/src/qs_kind_types.F +++ b/src/qs_kind_types.F @@ -1008,7 +1008,7 @@ CONTAINS IF (PRESENT(maxlppl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nexp_ppl=n) maxlppl = MAX(maxlppl, 2*(n - 1)) - ELSEIF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSE IF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nrloc=nrloc, ecp_semi_local=ecp_semi_local) n = MAXVAL(nrloc) - 2 maxlppl = MAX(maxlppl, 2*(n - 1)) @@ -1023,7 +1023,7 @@ CONTAINS IF (PRESENT(maxlppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, lprj_ppnl_max=imax) maxlppnl = MAX(maxlppnl, imax) - ELSEIF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSE IF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, lmax=imax) maxlppnl = MAX(maxlppnl, imax) END IF @@ -1046,7 +1046,7 @@ CONTAINS IF (PRESENT(maxppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) - ELSEIF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSE IF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) END IF @@ -1327,7 +1327,7 @@ CONTAINS IF (ASSOCIATED(qs_kind%gth_potential)) THEN CALL init_potential(qs_kind%gth_potential) - ELSEIF (ASSOCIATED(qs_kind%sgp_potential)) THEN + ELSE IF (ASSOCIATED(qs_kind%sgp_potential)) THEN CALL init_potential(qs_kind%sgp_potential) END IF @@ -1790,12 +1790,12 @@ CONTAINS basis_set_type(i) = "ORB" basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(1) - ELSEIF (SIZE(tmpstringlist) == 2) THEN + ELSE IF (SIZE(tmpstringlist) == 2) THEN ! default is GTO basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(2) - ELSEIF (SIZE(tmpstringlist) == 3) THEN + ELSE IF (SIZE(tmpstringlist) == 3) THEN basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = tmpstringlist(2) basis_set_name(i) = tmpstringlist(3) @@ -1876,7 +1876,7 @@ CONTAINS potential_type = potential_name END IF END IF - ELSEIF (SIZE(tmpstringlist) == 2) THEN + ELSE IF (SIZE(tmpstringlist) == 2) THEN potential_type = tmpstringlist(1) potential_name = tmpstringlist(2) ELSE @@ -1930,19 +1930,22 @@ CONTAINS CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RHO0_EXP_RADIUS", r_val=qs_kind%hard0_radius) END IF - IF (qs_kind%hard_radius < qs_kind%hard0_radius) & + IF (qs_kind%hard_radius < qs_kind%hard0_radius) THEN CPABORT("rc0 should be <= rc") + END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="MAX_RAD_LOCAL", r_val=qs_kind%max_rad_local) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="LEBEDEV_GRID", i_val=qs_kind%ngrid_ang) - IF (qs_kind%ngrid_ang <= 0) & + IF (qs_kind%ngrid_ang <= 0) THEN CPABORT("# point lebedev grid < 0") + END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RADIAL_GRID", i_val=qs_kind%ngrid_rad) - IF (qs_kind%ngrid_rad <= 0) & + IF (qs_kind%ngrid_rad <= 0) THEN CPABORT("# point radial grid < 0") + END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="GPW_TYPE", l_val=qs_kind%gpw_type_forced) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & @@ -2146,21 +2149,25 @@ CONTAINS keyword_name="ORBITALS", & i_vals=orbitals) norbitals = SIZE(orbitals) - IF (norbitals <= 0 .OR. norbitals > 2*l + 1) & + IF (norbitals <= 0 .OR. norbitals > 2*l + 1) THEN CALL cp_abort(__LOCATION__, "DFT+U| Invalid number of ORBITALS specified: "// & "1 to 2*L+1 integer numbers are expected") + END IF ALLOCATE (qs_kind%dft_plus_u%orbitals(norbitals)) qs_kind%dft_plus_u%orbitals(:) = orbitals(:) NULLIFY (orbitals) DO m = 1, norbitals - IF (qs_kind%dft_plus_u%orbitals(m) > l) & + IF (qs_kind%dft_plus_u%orbitals(m) > l) THEN CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m > l") - IF (qs_kind%dft_plus_u%orbitals(m) < -l) & + END IF + IF (qs_kind%dft_plus_u%orbitals(m) < -l) THEN CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m < -l") + END IF DO j = 1, norbitals IF (j /= m) THEN - IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) & + IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) THEN CPABORT("DFT+U| An orbital magnetic quantum number was specified twice") + END IF END IF END DO END DO @@ -2254,16 +2261,18 @@ CONTAINS qs_kind%se_parameter%zeff = qs_kind%se_parameter%zeff - zeff_correction check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF CASE (do_method_dftb) ! Allocate all_potential @@ -2287,16 +2296,18 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF CASE (do_method_xtb) ! Allocate all_potential @@ -2320,16 +2331,18 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF CASE (do_method_pw) ! PW DFT @@ -2645,8 +2658,9 @@ CONTAINS CALL atom_release_upf(upfpot) CALL atom_sgp_release(sgppot) CASE ("CNEO") - IF (zeff_correction /= 0.0_dp) & + IF (zeff_correction /= 0.0_dp) THEN CPABORT("CORE_CORRECTION is not compatible with CNEO") + END IF CALL allocate_cneo_potential(qs_kind%cneo_potential) CALL set_cneo_potential(qs_kind%cneo_potential, z=z) mass = 0.0_dp @@ -2773,14 +2787,17 @@ CONTAINS CALL get_qs_kind(qs_kind, name=name, gth_potential=gth_potential, basis_set=basis_set) npp = -1; nbs = -1 - IF (ASSOCIATED(gth_potential)) & + IF (ASSOCIATED(gth_potential)) THEN npp = parse_valence_electrons(gth_potential%aliases) - IF (ASSOCIATED(basis_set)) & + END IF + IF (ASSOCIATED(basis_set)) THEN nbs = parse_valence_electrons(basis_set%aliases) + END IF - IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) & + IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) THEN CALL cp_abort(__LOCATION__, "Basis-set and pseudo-potential of atomic kind '"//TRIM(name)//"'"// & " were optimized for different valence electron numbers.") + END IF END SUBROUTINE check_potential_basis_compatibility @@ -3986,7 +4003,7 @@ CONTAINS IF (ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nlcc_present=nlcc_present) nlcc = nlcc .OR. nlcc_present - ELSEIF (ASSOCIATED(sgp_potential)) THEN + ELSE IF (ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, has_nlcc=nlcc_present) nlcc = nlcc .OR. nlcc_present END IF diff --git a/src/qs_kinetic.F b/src/qs_kinetic.F index b743911176..e9926351ad 100644 --- a/src/qs_kinetic.F +++ b/src/qs_kinetic.F @@ -220,7 +220,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSEIF (PRESENT(matrixkp_t)) THEN + ELSE IF (PRESENT(matrixkp_t)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -279,7 +279,7 @@ CONTAINS ELSE IF (PRESENT(matrix_p)) THEN matp => matrix_p - ELSEIF (PRESENT(matrixkp_p)) THEN + ELSE IF (PRESENT(matrixkp_p)) THEN matp => matrixkp_p(1, 1)%matrix ELSE CPABORT("Missing density matrix") diff --git a/src/qs_kpp1_env_methods.F b/src/qs_kpp1_env_methods.F index 2ff3fe8229..504224f6c8 100644 --- a/src/qs_kpp1_env_methods.F +++ b/src/qs_kpp1_env_methods.F @@ -200,8 +200,9 @@ CONTAINS poisson_env=poisson_env) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) & + IF (gapw .OR. gapw_xc) THEN CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) + END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -454,7 +455,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=my_calc_forces, tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_ks_apply_restraints.F b/src/qs_ks_apply_restraints.F index d2d9c792c7..79524ca9f1 100644 --- a/src/qs_ks_apply_restraints.F +++ b/src/qs_ks_apply_restraints.F @@ -83,22 +83,25 @@ CONTAINS CALL auxbas_pw_pool%create_pw(cdft_control%group(igroup)%weight) ! Sanity check IF (cdft_control%group(igroup)%constraint_type /= cdft_charge_constraint & - .AND. dft_control%nspins == 1) & + .AND. dft_control%nspins == 1) THEN CALL cp_abort(__LOCATION__, & "Spin constraints require a spin polarized calculation.") + END IF END DO IF (cdft_control%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control%charge)) & + IF (.NOT. ASSOCIATED(cdft_control%charge)) THEN ALLOCATE (cdft_control%charge(cdft_control%natoms)) + END IF DO iatom = 1, cdft_control%natoms CALL auxbas_pw_pool%create_pw(cdft_control%charge(iatom)) END DO END IF ! Another sanity check CALL get_qs_env(qs_env, natom=natom) - IF (natom < cdft_control%natoms) & + IF (natom < cdft_control%natoms) THEN CALL cp_abort(__LOCATION__, & "The number of constraint atoms exceeds the total number of atoms.") + END IF ELSE DO igroup = 1, SIZE(cdft_control%group) inv_vol = 1.0_dp/cdft_control%group(igroup)%weight%pw_grid%dvol diff --git a/src/qs_ks_atom.F b/src/qs_ks_atom.F index fbf62a1fe3..891c94351b 100644 --- a/src/qs_ks_atom.F +++ b/src/qs_ks_atom.F @@ -649,14 +649,14 @@ CONTAINS 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (dista) THEN + ELSE IF (dista) THEN CALL DGEMM('N', 'T', nsp, ncontb, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_b(:, :, 1), SIZE(C_hh_b, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, ncontb, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & C_ss_b(:, :, 1), SIZE(C_ss_b, 1), 1.0_dp, coc, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & coc, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (distb) THEN + ELSE IF (distb) THEN CALL DGEMM('N', 'N', nconta, nsp, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, nconta) CALL DGEMM('N', 'N', nconta, nsp, nsp, -factor, C_ss_a(:, :, 1), SIZE(C_ss_a, 1), & @@ -692,14 +692,14 @@ CONTAINS CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, coc, nsp, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', ncontb, nconta, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (dista) THEN + ELSE IF (dista) THEN CALL DGEMM('N', 'N', ncontb, nsp, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, ncontb) CALL DGEMM('N', 'N', ncontb, nsp, nsp, -factor, C_ss_b(:, :, 1), SIZE(C_ss_b, 1), & int_soft, SIZE(int_soft, 1), 1.0_dp, coc, ncontb) CALL DGEMM('N', 'T', ncontb, nconta, nsp, 1.0_dp, coc, ncontb, & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (distb) THEN + ELSE IF (distb) THEN CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, nconta, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index 9f6a420799..a2cf906d65 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -577,7 +577,7 @@ CONTAINS CALL admm_mo_calc_rho_aux(qs_env) END IF END IF - ELSEIF (dft_control%do_admm_dm) THEN + ELSE IF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF @@ -1093,7 +1093,7 @@ CONTAINS ELSE CALL admm_mo_merge_ks_matrix(qs_env) END IF - ELSEIF (dft_control%do_admm_dm) THEN + ELSE IF (dft_control%do_admm_dm) THEN CALL admm_dm_merge_ks_matrix(qs_env) END IF @@ -1171,8 +1171,9 @@ CONTAINS IF (native_skala_restore_exc) energy%total = native_skala_total_scf - IF (abnormal_value(energy%total)) & + IF (abnormal_value(energy%total)) THEN CPABORT("KS energy is an abnormal value (NaN/Inf).") + END IF ! Print detailed energy IF (my_print) THEN @@ -1448,8 +1449,9 @@ CONTAINS END IF ! kinetic energy - IF (ASSOCIATED(matrixkp_t)) & + IF (ASSOCIATED(matrixkp_t)) THEN CALL calculate_ptrace(matrixkp_t, rho_ao_kp, energy%kinetic, dft_control%nspins) + END IF CALL timestop(handle) END SUBROUTINE evaluate_core_matrix_traces @@ -1482,12 +1484,12 @@ CONTAINS calculate_forces=calculate_forces, & just_energy=just_energy) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL build_dftb_ks_matrix(qs_env, & calculate_forces=calculate_forces, & just_energy=just_energy) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, & calculate_forces=calculate_forces, & diff --git a/src/qs_ks_types.F b/src/qs_ks_types.F index 73e953562b..0f6c029414 100644 --- a/src/qs_ks_types.F +++ b/src/qs_ks_types.F @@ -621,8 +621,9 @@ CONTAINS IF (PRESENT(potential_changed)) ks_env%potential_changed = potential_changed IF (PRESENT(forces_up_to_date)) ks_env%forces_up_to_date = forces_up_to_date IF (PRESENT(complex_ks)) ks_env%complex_ks = complex_ks - IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) & + IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) THEN ks_env%forces_up_to_date = .FALSE. + END IF IF (PRESENT(exc_accint)) ks_env%exc_accint = exc_accint IF (PRESENT(v_hartree_rspace)) ks_env%v_hartree_rspace => v_hartree_rspace @@ -763,10 +764,12 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) & + IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & + END IF + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) + END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -775,12 +778,15 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%distribution_2d)) & + IF (ASSOCIATED(ks_env%distribution_2d)) THEN CALL distribution_2d_release(ks_env%distribution_2d) - IF (ASSOCIATED(ks_env%task_list)) & + END IF + IF (ASSOCIATED(ks_env%task_list)) THEN CALL deallocate_task_list(ks_env%task_list) - IF (ASSOCIATED(ks_env%task_list_soft)) & + END IF + IF (ASSOCIATED(ks_env%task_list_soft)) THEN CALL deallocate_task_list(ks_env%task_list_soft) + END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() @@ -869,10 +875,12 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) & + IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & + END IF + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) + END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -881,10 +889,12 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%task_list)) & + IF (ASSOCIATED(ks_env%task_list)) THEN CALL deallocate_task_list(ks_env%task_list) - IF (ASSOCIATED(ks_env%task_list_soft)) & + END IF + IF (ASSOCIATED(ks_env%task_list_soft)) THEN CALL deallocate_task_list(ks_env%task_list_soft) + END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index 98755af9bf..aa83ab16a1 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -789,8 +789,9 @@ CONTAINS IF (dft_control%sic_method_id == sic_none) RETURN IF (dft_control%sic_method_id == sic_eo) RETURN - IF (dft_control%qs_control%gapw) & + IF (dft_control%qs_control%gapw) THEN CPABORT("sic and GAPW not yet compatible") + END IF ! OK, right now we like two spins to do sic, could be relaxed for AD CPASSERT(dft_control%nspins == 2) @@ -1131,18 +1132,22 @@ CONTAINS "Integral of the (density * v_xc): ", energy%exc END IF - IF (energy%e_hartree /= 0.0_dp) & + IF (energy%e_hartree /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Coulomb (electron-electron) energy: ", energy%e_hartree - IF (energy%dispersion /= 0.0_dp) & + "Coulomb (electron-electron) energy: ", energy%e_hartree + END IF + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Dispersion energy: ", energy%dispersion - IF (energy%efield /= 0.0_dp) & + "Dispersion energy: ", energy%dispersion + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Electric field interaction energy: ", energy%efield - IF (energy%gcp /= 0.0_dp) & + "Electric field interaction energy: ", energy%efield + END IF + IF (energy%gcp /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "gCP energy: ", energy%gcp + "gCP energy: ", energy%gcp + END IF IF (dft_control%qs_control%gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T61,F20.10))") & "GAPW| Exc from hard and soft atomic rho1: ", energy%exc1 + energy%exc1_aux_fit, & @@ -1530,7 +1535,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1634,7 +1639,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1672,7 +1677,7 @@ CONTAINS IF (calculate_forces) THEN CALL calculate_lri_forces(lri_env, lri_density, qs_env, rho_ao_kp, atomic_kind_set) END IF - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN CALL get_qs_env(qs_env, matrix_s=smat) DO ispin = 1, nspins CALL calculate_ri_ks_matrix(lri_env, lri_v_int, ks_matrix(ispin, 1)%matrix, & diff --git a/src/qs_kubo_transport.F b/src/qs_kubo_transport.F index 8ec3525d01..68825aecb2 100644 --- a/src/qs_kubo_transport.F +++ b/src/qs_kubo_transport.F @@ -193,7 +193,7 @@ CONTAINS END IF IF (ALL(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "CP2K canonical MOs" - ELSEIF (ANY(reused_mos)) THEN + ELSE IF (ANY(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "mixed canonical/internal" ELSE WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "internal diagonalization" @@ -708,7 +708,7 @@ CONTAINS x = (eig - mu)/kT IF (x > 80.0_dp) THEN occ = 0.0_dp - ELSEIF (x < -80.0_dp) THEN + ELSE IF (x < -80.0_dp) THEN occ = maxocc ELSE occ = maxocc/(1.0_dp + EXP(x)) diff --git a/src/qs_linres_atom_current.F b/src/qs_linres_atom_current.F index 43eee3ff8c..a258a30e77 100644 --- a/src/qs_linres_atom_current.F +++ b/src/qs_linres_atom_current.F @@ -266,16 +266,11 @@ CONTAINS NULLIFY (basis_1c_set, jp_RARnu, jp2_RARnu) ALLOCATE (a_block(nspins), b_block(nspins), c_block(nspins), d_block(nspins), & - jp_RARnu(nspins), jp2_RARnu(nspins), & - STAT=istat) - CPASSERT(istat == 0) + jp_RARnu(nspins), jp2_RARnu(nspins)) ALLOCATE (a_matrix(max_nsgf, max_nsgf), b_matrix(max_nsgf, max_nsgf), & - c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf), & - STAT=istat) - CPASSERT(istat == 0) - ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC), STAT=istat) - CPASSERT(istat == 0) + c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf)) + ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC)) !$OMP SINGLE !$ ALLOCATE (alloc_lock(natom)) @@ -602,8 +597,9 @@ CONTAINS END IF CALL para_env%sum(tmp_coeff) - IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) & + IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) THEN nbr_dbl = nbr_dbl + 8.0_dp*REAL(SIZE(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef), dp) + END IF END DO ! ispin END DO ! iat diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index 400cc30712..a0f155514c 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -1024,8 +1024,9 @@ CONTAINS IF (do_igaim) CALL dbcsr_get_block_p(matrix=deltajp_d(1)%matrix, row=brow, col=bcol, & block=jp_block_d, found=den_found) - IF (.NOT. ASSOCIATED(jp_block_a)) & + IF (.NOT. ASSOCIATED(jp_block_a)) THEN CPABORT("p_block not associated in deltap") + END IF iatom_old = iatom jatom_old = jatom diff --git a/src/qs_linres_current_utils.F b/src/qs_linres_current_utils.F index b31ce717f5..49c842e78f 100644 --- a/src/qs_linres_current_utils.F +++ b/src/qs_linres_current_utils.F @@ -794,8 +794,9 @@ CONTAINS current_env%do_selected_states = n_rep > 0 ! ! for the moment selected states doesnt work with the preconditioner FULL_ALL - IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) & + IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) THEN CPABORT("Selected states doesnt work with the preconditioner FULL_ALL") + END IF ! ! NULLIFY (current_env%selected_states_on_atom_list) @@ -1160,7 +1161,7 @@ CONTAINS REPEAT(' ', 20 - LEN_TRIM(current_env%orb_center_name))//TRIM(current_env%orb_center_name) IF (current_env%orb_center == current_orb_center_common) THEN WRITE (output_unit, "(T2,A,T50,3F10.6)") "CURRENT| Common center", common_center(1:3) - ELSEIF (current_env%orb_center == current_orb_center_box) THEN + ELSE IF (current_env%orb_center == current_orb_center_box) THEN WRITE (output_unit, "(T2,A,T60,3I5)") "CURRENT| Nbr boxes in each direction", nbox(1:3) END IF ! diff --git a/src/qs_linres_epr_nablavks.F b/src/qs_linres_epr_nablavks.F index 9a571ba003..6761fb1794 100644 --- a/src/qs_linres_epr_nablavks.F +++ b/src/qs_linres_epr_nablavks.F @@ -631,7 +631,7 @@ CONTAINS rap(1) = MODULO(rap(1), cell%hmat(1, 1)) - cell%hmat(1, 1)/2._dp rap(2) = MODULO(rap(2), cell%hmat(2, 2)) - cell%hmat(2, 2)/2._dp rap(3) = MODULO(rap(3), cell%hmat(3, 3)) - cell%hmat(3, 3)/2._dp - sqrt_rap = SQRT(DOT_PRODUCT(rap, rap)) + sqrt_rap = NORM2(rap) exp_rap = EXP(-alpha*sqrt_rap**2) sqrt_rap = MAX(sqrt_rap, 1.e-10_dp) ! d_x diff --git a/src/qs_linres_issc_utils.F b/src/qs_linres_issc_utils.F index c02149d74f..44ed32e9f2 100644 --- a/src/qs_linres_issc_utils.F +++ b/src/qs_linres_issc_utils.F @@ -200,11 +200,8 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) - !CALL cp_fm_to_fm(p_psi0(ispin,ijdir)%matrix, psi1(ispin)) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! - !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(efg_psi0(ispin, ijdir), h1_psi0(ispin)) END DO @@ -223,18 +220,6 @@ CONTAINS chk = chk + fro END DO ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_efg',& - ! idir=ijdir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -281,18 +266,6 @@ CONTAINS chk = chk + fro END DO ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -314,11 +287,8 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) - !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! - !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(fc_psi0(ispin), h1_psi0(ispin)) END DO @@ -337,18 +307,6 @@ CONTAINS chk = chk + fro END DO ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -394,20 +352,6 @@ CONTAINS fro = cp_fm_frobenius_norm(psi1(ispin)) chk = chk + fro END DO - ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! - ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" END IF @@ -600,27 +544,6 @@ CONTAINS ! !>>>>> for debugging we compute here the polarizability and NOT the DSO term! IF (do_dso .AND. iatom == natom .AND. jatom == natom) THEN - ! - ! build the integral for the jatom - !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(4)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(5)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(6)%matrix,0.0_dp) - !CALL build_dso_matrix(qs_env,matrix_dso,r_i,r_j) - !DO ixyz = 1,6 - ! CALL cp_sm_fm_multiply(matrix_dso(ixyz)%matrix,mo_coeff,& - ! & fc_psi0(ispin),ncol=nmo,& ! fc_psi0 a buffer - ! & alpha=1.0_dp,beta=0.0_dp) - ! CALL cp_fm_trace(fc_psi0(ispin),mo_coeff,buf) - ! issc_dso = 2.0_dp * maxocc * facdso * buf - ! issc(ixyz,jxyz,iatom,jatom,4) = issc_dso - !ENDDO - !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) - !CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1) DO ixyz = 1, 3 CALL cp_dbcsr_sm_fm_multiply(matrix_dso(ixyz)%matrix, mo_coeff, & fc_psi0(ispin), ncol=nmo,& ! fc_psi0 a buffer @@ -779,9 +702,9 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_env_init' - INTEGER :: handle, iatom, idir, ini, ir, ispin, & - istat, m, n, n_rep, nao, natom, & - nspins, output_unit + INTEGER :: handle, iatom, idir, ini, ir, ispin, m, & + n, n_rep, nao, natom, nspins, & + output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf INTEGER, DIMENSION(:), POINTER :: list, row_blk_sizes LOGICAL :: gapw @@ -841,9 +764,10 @@ CONTAINS natom = SIZE(particle_set, 1) ! ! check that the psi0 are localized and you have all the centers - IF (.NOT. linres_control%localized_psi0) & + IF (.NOT. linres_control%localized_psi0) THEN CALL cp_warn(__LOCATION__, 'To get indirect spin-spin coupling parameters within '// & 'PBC you need to localize zero order orbitals') + END IF ! ! ! read terms need to be calculated @@ -876,8 +800,7 @@ CONTAINS END DO ! IF (.NOT. ASSOCIATED(issc_env%issc_on_atom_list)) THEN - ALLOCATE (issc_env%issc_on_atom_list(natom), STAT=istat) - CPASSERT(istat == 0) + ALLOCATE (issc_env%issc_on_atom_list(natom)) DO iatom = 1, natom issc_env%issc_on_atom_list(iatom) = iatom END DO @@ -887,20 +810,15 @@ CONTAINS ! ! Initialize the issc tensor ALLOCATE (issc_env%issc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & - issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & - STAT=istat) - CPASSERT(istat == 0) + issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4)) issc_env%issc(:, :, :, :, :) = 0.0_dp issc_env%issc_loc(:, :, :, :, :) = 0.0_dp ! ! allocation ALLOCATE (issc_env%efg_psi0(nspins, 6), issc_env%pso_psi0(nspins, 3), issc_env%fc_psi0(nspins), & issc_env%psi1_efg(nspins, 6), issc_env%psi1_pso(nspins, 3), issc_env%psi1_fc(nspins), & - issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3), & - STAT=istat) - CPASSERT(istat == 0) + issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3)) DO ispin = 1, nspins - !mo_coeff => current_env%psi0_order(ispin)%matrix CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff, ncol_global=m, nrow_global=nao) diff --git a/src/qs_linres_kernel.F b/src/qs_linres_kernel.F index c9ac0c1255..a8d15ea670 100644 --- a/src/qs_linres_kernel.F +++ b/src/qs_linres_kernel.F @@ -142,9 +142,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Linear response not available with SE methods") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("Linear response not available with DFTB") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL apply_op_2_xtb(qs_env, p_env) ELSE CALL apply_op_2_dft(qs_env, p_env) @@ -278,8 +278,9 @@ CONTAINS CALL auxbas_pw_pool%create_pw(v_hartree_gspace) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) & + IF (gapw .OR. gapw_xc) THEN CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) + END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -444,8 +445,9 @@ CONTAINS END IF IF (lrigpw) THEN - IF (ASSOCIATED(v_xc_tau)) & + IF (ASSOCIATED(v_xc_tau)) THEN CPABORT("metaGGA-functionals not supported with LRI!") + END IF lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind) @@ -506,7 +508,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=.FALSE., tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index f730cfc2cf..ad5d4d0c72 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -642,7 +642,7 @@ CONTAINS CALL qs_rho_update_rho(rho, qs_env=qs_env) ! that could be called before IF (dft_control%qs_control%gapw) THEN CALL prepare_gapw_den(qs_env) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL prepare_gapw_den(qs_env, do_rho0=.FALSE.) END IF diff --git a/src/qs_linres_module.F b/src/qs_linres_module.F index 4da28f2d80..ff4d100b67 100644 --- a/src/qs_linres_module.F +++ b/src/qs_linres_module.F @@ -202,8 +202,9 @@ CONTAINS vcd_env%apt_total_nvpt(:, :, vcd_env%dcdr_env%lambda) = & vcd_env%apt_el_nvpt(:, :, vcd_env%dcdr_env%lambda) + vcd_env%apt_nuc_nvpt(:, :, vcd_env%dcdr_env%lambda) - IF (vcd_env%do_mfp) & + IF (vcd_env%do_mfp) THEN vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda) = vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda)*4._dp + END IF END DO !lambda diff --git a/src/qs_linres_op.F b/src/qs_linres_op.F index ad52669b40..ed9e9fe2b8 100644 --- a/src/qs_linres_op.F +++ b/src/qs_linres_op.F @@ -1276,7 +1276,7 @@ CONTAINS IF ((b == a + 1 .OR. b == a - 2) .AND. (c == b + 1 .OR. c == b - 2)) THEN factor = 1.0_dp - ELSEIF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN + ELSE IF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN factor = -1.0_dp END IF @@ -1298,9 +1298,9 @@ CONTAINS l(1:3) = 0 IF (ii == 0) THEN l(iii) = 1 - ELSEIF (iii == 0) THEN + ELSE IF (iii == 0) THEN l(ii) = 1 - ELSEIF (ii == iii) THEN + ELSE IF (ii == iii) THEN l(ii) = 2 i = coset(l(1), l(2), l(3)) - 1 ELSE @@ -1324,10 +1324,10 @@ CONTAINS IF (i1 == 1) THEN i2 = 2 i3 = 3 - ELSEIF (i1 == 2) THEN + ELSE IF (i1 == 2) THEN i2 = 3 i3 = 1 - ELSEIF (i1 == 3) THEN + ELSE IF (i1 == 3) THEN i2 = 1 i3 = 2 ELSE @@ -1347,9 +1347,9 @@ CONTAINS IF ((i1 + i2) == 3) THEN i3 = 3 - ELSEIF ((i1 + i2) == 4) THEN + ELSE IF ((i1 + i2) == 4) THEN i3 = 2 - ELSEIF ((i1 + i2) == 5) THEN + ELSE IF ((i1 + i2) == 5) THEN i3 = 1 ELSE END IF diff --git a/src/qs_loc_main.F b/src/qs_loc_main.F index 356f10d813..f929aacda9 100644 --- a/src/qs_loc_main.F +++ b/src/qs_loc_main.F @@ -401,7 +401,7 @@ CONTAINS CALL cp_fm_release(tmp_fm) CALL cp_fm_release(tmp_fm_1) CALL cp_fm_struct_release(tmp_fm_struct) - ELSEIF (my_guess_wan) THEN + ELSE IF (my_guess_wan) THEN nguess = localized_wfn_control%nguess(myspin) ALLOCATE (tmp_mat(nao, nguess)) CALL cp_fm_get_submatrix(moloc_coeff(myspin), tmp_mat, 1, 1, nao, nguess) diff --git a/src/qs_loc_states.F b/src/qs_loc_states.F index 0c9d90a473..8163a283a2 100644 --- a/src/qs_loc_states.F +++ b/src/qs_loc_states.F @@ -133,16 +133,21 @@ CONTAINS IF (qs_loc_env%do_localize) THEN ! Do the Real localization.. - IF (output_unit > 0 .AND. do_homo) WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for OCCUPIED ORBITALS. Spin:", ispin - IF (output_unit > 0 .AND. do_mixed) WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & - "LOCALIZATION| Computing localization properties for OCCUPIED, ", & - "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin - IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) & + IF (output_unit > 0 .AND. do_homo) THEN WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for UNOCCUPIED ORBITALS. Spin:", ispin + "LOCALIZATION| Computing localization properties "// & + "for OCCUPIED ORBITALS. Spin:", ispin + END IF + IF (output_unit > 0 .AND. do_mixed) THEN + WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & + "LOCALIZATION| Computing localization properties for OCCUPIED, ", & + "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin + END IF + IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) THEN + WRITE (output_unit, "(/,T2,A,I3)") & + "LOCALIZATION| Computing localization properties "// & + "for UNOCCUPIED ORBITALS. Spin:", ispin + END IF scenter => qs_loc_env%localized_wfn_control%centers_set(ispin)%array diff --git a/src/qs_loc_types.F b/src/qs_loc_types.F index e22f26abb8..4da4fc2c07 100644 --- a/src/qs_loc_types.F +++ b/src/qs_loc_types.F @@ -196,8 +196,9 @@ CONTAINS INTEGER :: i, ii, j IF (ASSOCIATED(qs_loc_env%cell)) CALL cell_release(qs_loc_env%cell) - IF (ASSOCIATED(qs_loc_env%local_molecules)) & + IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN CALL distribution_1d_release(qs_loc_env%local_molecules) + END IF IF (ASSOCIATED(qs_loc_env%localized_wfn_control)) THEN CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control) END IF @@ -336,8 +337,9 @@ CONTAINS IF (PRESENT(cell)) cell => qs_loc_env%cell IF (PRESENT(moloc_coeff)) moloc_coeff => qs_loc_env%moloc_coeff IF (PRESENT(local_molecules)) local_molecules => qs_loc_env%local_molecules - IF (PRESENT(localized_wfn_control)) & + IF (PRESENT(localized_wfn_control)) THEN localized_wfn_control => qs_loc_env%localized_wfn_control + END IF IF (PRESENT(op_sm_set)) op_sm_set => qs_loc_env%op_sm_set IF (PRESENT(op_fm_set)) op_fm_set => qs_loc_env%op_fm_set IF (PRESENT(para_env)) para_env => qs_loc_env%para_env @@ -392,8 +394,9 @@ CONTAINS IF (PRESENT(local_molecules)) THEN CALL distribution_1d_retain(local_molecules) - IF (ASSOCIATED(qs_loc_env%local_molecules)) & + IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN CALL distribution_1d_release(qs_loc_env%local_molecules) + END IF qs_loc_env%local_molecules => local_molecules END IF diff --git a/src/qs_loc_utils.F b/src/qs_loc_utils.F index 988b9b6212..3a8cd53d04 100644 --- a/src/qs_loc_utils.F +++ b/src/qs_loc_utils.F @@ -340,10 +340,11 @@ CONTAINS IF (localized_wfn_control%do_homo) THEN occ_imo = occupations(imo) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) & + IF (localized_wfn_control%localization_method /= do_loc_none) THEN CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") + END IF END IF END IF ! Take the imo vector from the full set and copy in the imoloc vector of the subset @@ -357,10 +358,11 @@ CONTAINS my_occ = occupations(lb) occ_imo = occupations(ub) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) & + IF (localized_wfn_control%localization_method /= do_loc_none) THEN CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") + END IF END IF nmosub = localized_wfn_control%nloc_states(ispin) @@ -414,7 +416,7 @@ CONTAINS END DO END DO - ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN natoms = SIZE(qs_loc_env%particle_set, 1) ALLOCATE (qs_loc_env%op_fm_set(natoms, 1)) CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=natoms) @@ -439,7 +441,7 @@ CONTAINS CALL get_berry_operator(qs_loc_env, qs_env) - ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN !! here we don't have to do anything !! CALL get_pipek_mezey_operator ( qs_loc_env, qs_env ) @@ -757,7 +759,7 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSEIF (my_do_mixed) THEN + ELSE IF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -872,12 +874,13 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN fname_key = "LOCHOMO_RESTART_FILE_NAME" - ELSEIF (my_do_mixed) THEN + ELSE IF (my_do_mixed) THEN fname_key = "LOCMIXD_RESTART_FILE_NAME" ELSE fname_key = "LOCLUMO_RESTART_FILE_NAME" - IF (.NOT. PRESENT(evals)) & + IF (.NOT. PRESENT(evals)) THEN CPABORT("Missing argument to localize unoccupied states.") + END IF END IF file_exists = .FALSE. @@ -889,7 +892,7 @@ CONTAINS print_key => section_vals_get_subs_vals(section2, "LOC_RESTART") IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSEIF (my_do_mixed) THEN + ELSE IF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -914,8 +917,10 @@ CONTAINS READ (rst_unit) qs_loc_env%localized_wfn_control%nloc_states END IF ELSE - IF (output_unit > 0) WRITE (output_unit, "(/,T10,A)") & - "Restart file not available filename=<"//TRIM(filename)//'>' + IF (output_unit > 0) THEN + WRITE (output_unit, "(/,T10,A)") & + "Restart file not available filename=<"//TRIM(filename)//'>' + END IF END IF CALL para_env%bcast(file_exists) @@ -956,14 +961,16 @@ CONTAINS eig_read = 0.0_dp READ (rst_unit) eig_read(1:nmo_read) END IF - IF (nmo_read < nmo) & + IF (nmo_read < nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. ") - IF (nmo_read > nmo) & + END IF + IF (nmo_read > nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") + END IF nmo = MIN(nmo, nmo_read) IF (do_homo .OR. do_mixed) THEN @@ -1186,7 +1193,6 @@ CONTAINS maxocc=maxocc) ! Get eigenstates (only needed if not already calculated before) IF ((.NOT. my_do_mo_cubes) & - ! .OR. section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO")==0)& .AND. my_do_homo .AND. ASSOCIATED(qs_env%scf_env) & .AND. qs_env%scf_env%method == ot_method_nr .AND. (.NOT. dft_control%restricted)) THEN CALL make_mo_eig(mos, nspin, ks_rmpv, scf_control, mo_derivs) @@ -1207,11 +1213,12 @@ CONTAINS localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = ilast_intocc IF (nmoloc(ispin) /= n_mo(ispin)) THEN - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - ilast_intocc, " occupied orbitals are localized,", " with energies from ", & - mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." + "LOCALIZATION| Spin ", ispin, " The first ", & + ilast_intocc, " occupied orbitals are localized,", " with energies from ", & + mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." + END IF END IF ELSE IF (localized_wfn_control%set_of_states == energy_loc_range .AND. my_do_homo) THEN ilow = 0 @@ -1243,11 +1250,12 @@ CONTAINS nmoloc(ispin) = n_mo(ispin) - homo localized_wfn_control%lu_bound_states(1, ispin) = homo + 1 localized_wfn_control%lu_bound_states(2, ispin) = n_mo(ispin) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & - mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & + mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." + END IF ELSE IF (localized_wfn_control%set_of_states == state_loc_mixed) THEN nextra = localized_wfn_control%nextra nocc = homo @@ -1262,14 +1270,15 @@ CONTAINS nmoloc(ispin) = nocc + nextra localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = nmoloc(ispin) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,I6,/,T15,A,I6,/,T15,A,I6,/,T15,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " orbitals are localized.", & - "Number of fully occupied MOs: ", nocc, & - "Number of partially occupied MOs: ", npocc, & - "Number of extra degrees of freedom: ", nextra, & - "Excess charge: ", my_tot_zeff_corr, " electrons" + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " orbitals are localized.", & + "Number of fully occupied MOs: ", nocc, & + "Number of partially occupied MOs: ", npocc, & + "Number of extra degrees of freedom: ", nextra, & + "Excess charge: ", my_tot_zeff_corr, " electrons" + END IF ELSE nmoloc(ispin) = MIN(localized_wfn_control%nloc_states(1), n_mo(ispin)) IF (output_unit > 0 .AND. my_do_homo) WRITE (output_unit, "(/,T2,A,I4,A,I6,A)") "LOCALIZATION| Spin ", ispin, & diff --git a/src/qs_local_rho_types.F b/src/qs_local_rho_types.F index 2efbf1089a..97b456cf64 100644 --- a/src/qs_local_rho_types.F +++ b/src/qs_local_rho_types.F @@ -156,12 +156,9 @@ CONTAINS nkind = SIZE(rhoz_set) DO ikind = 1, nkind - IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) & - DEALLOCATE (rhoz_set(ikind)%r_coef) - IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) & - DEALLOCATE (rhoz_set(ikind)%dr_coef) - IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) & - DEALLOCATE (rhoz_set(ikind)%vr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) DEALLOCATE (rhoz_set(ikind)%r_coef) + IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) DEALLOCATE (rhoz_set(ikind)%dr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) DEALLOCATE (rhoz_set(ikind)%vr_coef) END DO DEALLOCATE (rhoz_set) diff --git a/src/qs_localization_methods.F b/src/qs_localization_methods.F index 97b0e6c4b8..6cc9eebe2f 100644 --- a/src/qs_localization_methods.F +++ b/src/qs_localization_methods.F @@ -162,7 +162,6 @@ CONTAINS END DO END DO CALL C%matrix_struct%para_env%sum(f2) - !write(*,*) 'qs_localize: f_2=',f2 !------------------------------------------------------------------- ! compute the derivative of f_2 ! f_2(x)=(x^2+eps)^1/2 @@ -179,7 +178,6 @@ CONTAINS !------------------------------------------------------------------- ! gnorm = cp_fm_frobenius_norm(G) - !write(*,*) 'qs_localize: norm(G)=',gnorm ! ! rescale for steepest descent CALL cp_fm_scale(-alpha, G) @@ -191,7 +189,6 @@ CONTAINS expfactor = 1.0_dp CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, G) tnorm = cp_fm_frobenius_norm(G) - !write(*,*) 'Taylor expansion i=',1,' norm(X^i)/i!=',tnorm IF (tnorm > 1.0E-10_dp) THEN ! other orders CALL cp_fm_to_fm(G, Gp1) @@ -203,7 +200,6 @@ CONTAINS expfactor = expfactor/REAL(i, KIND=dp) CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, Gp1) tnorm = cp_fm_frobenius_norm(Gp1) - !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',tnorm*expfactor IF (tnorm*expfactor < 1.0E-10_dp) EXIT END DO END IF @@ -219,7 +215,6 @@ CONTAINS ! ! Are we done? sweeps = istep - !IF(gnorm<=grad_thresh.AND.ABS((f2-f2old)/f2)<=f2_thresh.AND.istep>1) THEN IF (ABS((f2 - f2old)/f2) <= eps .AND. istep > 1) THEN converged = .TRUE. EXIT @@ -231,23 +226,6 @@ CONTAINS ! ! Print the final result IF (output_unit > 0) WRITE (output_unit, '(A,E16.10)') ' sparseness function f2 = ', f2 - ! - ! sparsity - !DO i=1,size(thresh,1) - ! gnorm = 0.0_dp - ! DO o=1,ncol_local - ! DO p=1,nrow_local - ! IF(ABS(C%local_data(p,o))>thresh(i)) THEN - ! gnorm = gnorm + 1.0_dp - ! ENDIF - ! ENDDO - ! ENDDO - ! CALL C%matrix_struct%para_env%sum(gnorm) - ! IF(output_unit>0) THEN - ! WRITE(output_unit,*) 'qs_localize: ratio2=',gnorm / ( REAL(k,KIND=dp)*REAL(n,KIND=dp) ),thresh(i) - ! ENDIF - !ENDDO - ! ! deallocate CALL cp_fm_struct_release(fm_struct_k_k) CALL cp_fm_release(CTmp) @@ -689,7 +667,7 @@ CONTAINS IF (do_cinit_random) THEN icinit = 1 do_U_guess_mo = .FALSE. - ELSEIF (do_cinit_mo) THEN + ELSE IF (do_cinit_mo) THEN icinit = 2 do_U_guess_mo = .TRUE. END IF @@ -1161,7 +1139,7 @@ CONTAINS IF ((ABS(ds) < 1.0E-10_dp) .AND. (lsl == 1)) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha - ELSEIF (ABS(ds) > 10.0_dp) THEN + ELSE IF (ABS(ds) > 10.0_dp) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha ELSE @@ -1349,7 +1327,7 @@ CONTAINS IF (ABS(b12) > 1.e-10_dp) THEN ratio = -a12/b12 theta = 0.25_dp*ATAN(ratio) - ELSEIF (ABS(b12) < 1.e-10_dp) THEN + ELSE IF (ABS(b12) < 1.e-10_dp) THEN b12 = 0.0_dp theta = 0.0_dp ELSE @@ -1997,14 +1975,6 @@ CONTAINS IF (new_direction) THEN ! energy converged up to machine precision ? line_searches = line_searches + 1 - ! DO i=1,line_search_count - ! write(15,*) pos(i),energy(i) - ! ENDDO - ! write(15,*) "" - ! CALL m_flush(15) - !write(16,*) evals(:) - !write(17,*) matrix_A%local_data(:,:) - !write(18,*) matrix_G%local_data(:,:) IF (output_unit > 0) THEN WRITE (output_unit, '(T5,I10,T18,I10,T31,2F20.6,F10.3)') line_searches, Iterations, Omega, tol, ds_min CALL m_flush(output_unit) @@ -2513,9 +2483,9 @@ CONTAINS COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: c_array_me, c_array_partner COMPLEX(KIND=dp), POINTER :: mii(:), mij(:), mjj(:) INTEGER :: i, idim, ii, ik, il1, il2, il_recv, il_recv_partner, ilow1, ilow2, ip, ip_has_i, & - ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istat, istate, iu1, iu2, iup1, & - iup2, j, jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, & - ns_recv_from, ns_recv_partner + ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istate, iu1, iu2, iup1, iup2, j, & + jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, ns_recv_from, & + ns_recv_partner INTEGER, ALLOCATABLE, DIMENSION(:) :: rcount, rdispl INTEGER, ALLOCATABLE, DIMENSION(:, :) :: list_pair LOGICAL :: should_stop @@ -2532,8 +2502,8 @@ CONTAINS ALLOCATE (mii(dim2), mij(dim2), mjj(dim2)) - ALLOCATE (rcount(para_env%num_pe), STAT=istat) - ALLOCATE (rdispl(para_env%num_pe), STAT=istat) + ALLOCATE (rcount(para_env%num_pe)) + ALLOCATE (rdispl(para_env%num_pe)) tolerance = 1.0e10_dp sweeps = 0 @@ -2705,7 +2675,6 @@ CONTAINS IF (ilow1 < ilow2) THEN ! no longer compiles in official sdgb: - !CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1, k), nstate, rmat_loc(1 + n1, 1), n1 + n2, 0.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, rmat_loc(1 + n1:, 1:n1), & n2, 0.0_dp, gmat(:, :), nstate) @@ -2715,7 +2684,6 @@ CONTAINS CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, & rmat_loc(1:, n2 + 1:), n1 + n2, 0.0_dp, gmat(:, :), nstate) ! no longer compiles in official sdgb: - !CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1, 1), nstate, rmat_loc(n2 + 1, n2 + 1), n1 + n2, 1.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1:, 1:), nstate, rmat_loc(n2 + 1:, n2 + 1:), & n1, 1.0_dp, gmat(:, :), nstate) @@ -2993,7 +2961,7 @@ CONTAINS list_pair(JJ, II) = i END DO IF (MOD(para_env%num_pe, 2) == 1) list_pair(2, npair) = -1 - ELSEIF (MOD(iperm, 2) == 0) THEN + ELSE IF (MOD(iperm, 2) == 0) THEN !..a type shift jj = list_pair(1, npair) DO I = npair, 3, -1 diff --git a/src/qs_mixing_utils.F b/src/qs_mixing_utils.F index d5869da8f0..b61e5251e4 100644 --- a/src/qs_mixing_utils.F +++ b/src/qs_mixing_utils.F @@ -188,7 +188,7 @@ CONTAINS CPASSERT(.NOT. mixing_store%gmix_p) IF (dft_control%qs_control%dftb) THEN max_shell = max_dftb_scc_vars - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN max_shell = max_xtb_scc_vars ELSE CPABORT('UNKNOWN METHOD') @@ -219,7 +219,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%pulay_matrix)) DEALLOCATE (mixing_store%pulay_matrix) ALLOCATE (mixing_store%pulay_matrix(nbuffer, nbuffer, nspins)) mixing_store%pulay_matrix = 0.0_dp - ELSEIF (mixing_method == broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr) THEN IF (ASSOCIATED(mixing_store%abroy)) DEALLOCATE (mixing_store%abroy) ALLOCATE (mixing_store%abroy(nbuffer, nbuffer)) mixing_store%abroy = 0.0_dp @@ -232,7 +232,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%ubroy)) DEALLOCATE (mixing_store%ubroy) ALLOCATE (mixing_store%ubroy(na, max_shell, nbuffer)) mixing_store%ubroy = 0.0_dp - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN CPABORT("multisecant_mixing not available") END IF ELSE @@ -588,7 +588,7 @@ CONTAINS END IF IF (mixing_method == gspace_mixing_nr) THEN - ELSEIF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN + ELSE IF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN IF (mixing_store%gmix_p .AND. PRESENT(rho_atom)) THEN DO ispin = 1, nspin DO iat = 1, natom @@ -613,7 +613,7 @@ CONTAINS END DO END DO END IF - ELSEIF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN DO ispin = 1, nspin IF (.NOT. ASSOCIATED(mixing_store%rhoin_old(ispin)%cc)) THEN ALLOCATE (mixing_store%rhoin_old(ispin)%cc(ng)) @@ -685,7 +685,7 @@ CONTAINS END DO IF (rho_g(1)%pw_grid%have_g0) mixing_store%p_metric(1) = bconst END IF - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN IF (.NOT. ASSOCIATED(mixing_store%ig_global_index)) THEN ALLOCATE (mixing_store%ig_global_index(ng)) END IF diff --git a/src/qs_mo_io.F b/src/qs_mo_io.F index 4504787e02..55c77ef141 100644 --- a/src/qs_mo_io.F +++ b/src/qs_mo_io.F @@ -346,7 +346,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -383,7 +383,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 @@ -754,8 +754,9 @@ CONTAINS IF (nao_read /= nao) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) & " READ RESTART : WARNING : DIFFERENT # AOs ", nao, nao_read - IF (PRESENT(rt_mos)) & + IF (PRESENT(rt_mos)) THEN CPABORT("To change basis is not possible. ") + END IF END IF READ (rst_unit) nset_info @@ -810,14 +811,16 @@ CONTAINS occ_read = 0.0_dp nmo = MIN(nmo, nmo_read) - IF (nmo_read < nmo) & + IF (nmo_read < nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. The MO set will be padded with zeros!") - IF (nmo_read > nmo) & + END IF + IF (nmo_read > nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") + END IF READ (rst_unit) eig_read(1:nmo_read), occ_read(1:nmo_read) mos(ispin)%eigenvalues(1:nmo) = eig_read(1:nmo) @@ -878,7 +881,7 @@ CONTAINS nshell=nshell, & l=l) minbas = .FALSE. - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset = 1 minbas = .TRUE. @@ -1326,14 +1329,16 @@ CONTAINS name = TRIM(energy_str)//", OCCUPATION NUMBERS, AND "// & TRIM(orbital_str)//" "//TRIM(vector_str) - IF (.NOT. my_final) & + IF (.NOT. my_final) THEN WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step + END IF ELSE IF (print_occup .OR. print_eigvals) THEN name = TRIM(energy_str)//" AND OCCUPATION NUMBERS" - IF (.NOT. my_final) & + IF (.NOT. my_final) THEN WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step + END IF END IF ! print_eigvecs ! Print headline diff --git a/src/qs_mo_occupation.F b/src/qs_mo_occupation.F index 38d815e707..dcd2c88e4f 100644 --- a/src/qs_mo_occupation.F +++ b/src/qs_mo_occupation.F @@ -155,10 +155,11 @@ CONTAINS CPWARN_IF(is_large, TRIM(method_label)//" smearing includes the first MO") is_large = ABS(all_occ(all_nmo)) > smear%eps_fermi_dirac - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF IF (.NOT. do_gce) THEN ! check that the total electron count is accurate is_large = (ABS(all_nelec - accurate_sum(all_occ(:))) > smear%eps_fermi_dirac*all_nelec) @@ -342,13 +343,15 @@ CONTAINS multiplicity_old = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (mo_array(1)%nelectron >= mo_array(1)%nmo) & + IF (mo_array(1)%nelectron >= mo_array(1)%nmo) THEN CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") - IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) & + END IF + IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) THEN CALL cp_warn(__LOCATION__, "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") + END IF eigval_a => mo_array(1)%eigenvalues eigval_b => mo_array(2)%eigenvalues @@ -367,20 +370,22 @@ CONTAINS lumo_b = lumo_b + 1 END IF IF (lumo_a > mo_array(1)%nmo) THEN - IF (i /= nelec) & + IF (i /= nelec) THEN CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") + END IF IF (i < nelec) THEN lumo_a = lumo_a - 1 lumo_b = lumo_b + 1 END IF END IF IF (lumo_b > mo_array(2)%nmo) THEN - IF (lumo_b < lumo_a) & + IF (lumo_b < lumo_a) THEN CALL cp_warn(__LOCATION__, & "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") + END IF IF (i < nelec) THEN lumo_a = lumo_a + 1 lumo_b = lumo_b - 1 @@ -406,11 +411,12 @@ CONTAINS mo_array(2)%nelectron = mo_array(2)%homo multiplicity_new = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (multiplicity_new /= multiplicity_old) & + IF (multiplicity_new /= multiplicity_old) THEN CALL cp_warn(__LOCATION__, & "Multiplicity changed from "// & TRIM(ADJUSTL(cp_to_string(multiplicity_old)))//" to "// & TRIM(ADJUSTL(cp_to_string(multiplicity_new)))) + END IF IF (PRESENT(probe)) THEN CALL set_mo_occupation_1(mo_array(1), smear=smear, probe=probe) @@ -496,8 +502,9 @@ CONTAINS mo_set%occupation_numbers(1:nomo) = mo_set%maxocc IF (xas_estate > 0) mo_set%occupation_numbers(xas_estate) = occ_estate el_count = SUM(mo_set%occupation_numbers(1:nomo)) - IF (el_count > xas_nelectron) & + IF (el_count > xas_nelectron) THEN mo_set%occupation_numbers(nomo) = mo_set%occupation_numbers(nomo) - (el_count - xas_nelectron) + END IF el_count = SUM(mo_set%occupation_numbers(1:nomo)) is_large = ABS(el_count - xas_nelectron) > xas_nelectron*EPSILON(el_count) CPASSERT(.NOT. is_large) @@ -586,13 +593,13 @@ CONTAINS END DO nomo = nomo - irmo IF (mo_set%occupation_numbers(nomo) == 0.0_dp) nomo = nomo - 1 - ELSEIF (delectron < 0.0_dp) THEN + ELSE IF (delectron < 0.0_dp) THEN mo_set%occupation_numbers(nomo) = -delectron ELSE mo_set%occupation_numbers(nomo) = 0.0_dp nomo = nomo - 1 END IF - ELSEIF (total_zeff_corr > 0.0_dp) THEN + ELSE IF (total_zeff_corr > 0.0_dp) THEN ! add electron density to the mos delectron = total_zeff_corr - REAL(mo_set%maxocc, KIND=dp) IF (delectron > 0.0_dp) THEN @@ -655,8 +662,9 @@ CONTAINS END DO is_large = ABS(MAXVAL(mo_set%occupation_numbers) - mo_set%maxocc) > probe(1)%eps_hp ! this is not a real problem, but the temperature might be a bit large - IF (is_large) & + IF (is_large) THEN CPWARN("Hair-probes occupancy distribution includes the first MO") + END IF ! Find the highest (fractional) occupied MO which will be now the HOMO DO imo = nmo, mo_set%lfomo, -1 @@ -666,15 +674,17 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > probe(1)%eps_hp - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & "Hair-probes occupancy distribution includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > probe(1)%eps_hp*nelec) - IF (is_large) & + IF (is_large) THEN CPWARN("Total number of electrons is not accurate") + END IF END IF @@ -750,10 +760,11 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > smear%eps_fermi_dirac - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & "Fermi-Dirac smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -806,10 +817,11 @@ CONTAINS END IF END DO is_large = ABS(mo_set%occupation_numbers(nmo)) > smear%eps_fermi_dirac - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! Check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -826,10 +838,11 @@ CONTAINS END IF e2 = mo_set%eigenvalues(mo_set%homo) + 0.5_dp*smear%window_size - IF (e2 >= mo_set%eigenvalues(nmo)) & + IF (e2 >= mo_set%eigenvalues(nmo)) THEN CALL cp_warn(__LOCATION__, & "Energy window for smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! Find the lowest fractional occupied MO (LFOMO) DO imo = i_first, nomo diff --git a/src/qs_mom_methods.F b/src/qs_mom_methods.F index 29544e3795..9d5921eaab 100644 --- a/src/qs_mom_methods.F +++ b/src/qs_mom_methods.F @@ -89,8 +89,9 @@ CONTAINS ! Ensure that all orbital indices are positive integers. ! A special value '0' means 'disabled keyword', ! it must appear once to be interpreted in such a way - IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) & + IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) THEN CPABORT("MOM: all molecular orbital indices must be positive integer numbers") + END IF DEALLOCATE (tmp_iarr) END IF @@ -265,9 +266,10 @@ CONTAINS (mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccA) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccB) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occA) .AND. & - mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) & + mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) THEN CALL cp_abort(__LOCATION__, & "Duplicate orbital indices were found in the MOM section") + END IF ! ignore beta orbitals for spin-unpolarized calculations IF (nspins == 1 .AND. (scf_control%diagonalization%mom_deoccB(1) /= 0 & @@ -308,16 +310,18 @@ CONTAINS END DO ! proceed alpha orbitals - IF (nspins >= 1) & + IF (nspins >= 1) THEN CALL mom_reoccupy_orbitals(mos(1), & scf_control%diagonalization%mom_deoccA, & scf_control%diagonalization%mom_occA, 'alpha') + END IF ! proceed beta orbitals (if any) - IF (nspins >= 2) & + IF (nspins >= 2) THEN CALL mom_reoccupy_orbitals(mos(2), & scf_control%diagonalization%mom_deoccB, & scf_control%diagonalization%mom_occB, 'beta') + END IF ! recompute the density matrix if the molecular orbitals are here; ! otherwise do nothing to prevent zeroing out the density matrix @@ -392,9 +396,10 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. scf_control%diagonalization%mom_didguess) & + IF (.NOT. scf_control%diagonalization%mom_didguess) THEN CALL cp_abort(__LOCATION__, & "The current implementation of the maximum overlap method is incompatible with the initial SCF guess") + END IF ! number of spins == dft_control%nspins nspins = SIZE(matrix_ks) diff --git a/src/qs_moments.F b/src/qs_moments.F index 6a8ac14ccf..c434f3ca8b 100644 --- a/src/qs_moments.F +++ b/src/qs_moments.F @@ -3361,8 +3361,9 @@ CONTAINS kpnts => section_vals_get_subs_vals(qs_env%input, "DFT%PRINT%MOMENTS%KPOINTS") CALL section_vals_get(kpset, explicit=explicit_kpset) CALL section_vals_get(kpnts, explicit=explicit_kpnts) - IF (explicit_kpset .AND. explicit_kpnts) & + IF (explicit_kpset .AND. explicit_kpnts) then CPABORT("Both KPOINT_SET and KPOINTS present in MOMENTS section") + end if IF (explicit_kpset) THEN CALL get_qs_env(qs_env, cell=cell) @@ -4011,8 +4012,9 @@ CONTAINS IF (ABS(energy_diff) <= eps_degenerate) CYCLE CALL cp_fm_get_element(moment_re, m, n, creal) CALL cp_fm_get_element(moment_im, m, n, cimag) - IF (para_env%is_source()) & + IF (para_env%is_source()) then dipole(ispin, ikp, i_dir, n, m) = CMPLX(creal, cimag, KIND=dp)/energy_diff + end if END DO END DO END DO diff --git a/src/qs_neighbor_list_types.F b/src/qs_neighbor_list_types.F index c77afac074..f85df43651 100644 --- a/src/qs_neighbor_list_types.F +++ b/src/qs_neighbor_list_types.F @@ -358,8 +358,9 @@ CONTAINS TYPE(neighbor_list_set_p_type), DIMENSION(:), & POINTER :: nl - IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) & + IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) THEN CPABORT("Parallel iterator calls must include 'mepos'") + END IF IF (PRESENT(mepos)) THEN me = mepos @@ -461,10 +462,10 @@ CONTAINS IF (iterator%inode >= iterator%nnode) THEN ! end of loop istat = 1 - ELSEIF (iterator%inode == 0) THEN + ELSE IF (iterator%inode == 0) THEN iterator%inode = 1 iterator%neighbor_node => first_node(iterator%neighbor_list) - ELSEIF (iterator%inode > 0) THEN + ELSE IF (iterator%inode > 0) THEN ! we can be sure that there is another node in this list iterator%inode = iterator%inode + 1 iterator%neighbor_node => iterator%neighbor_node%next_neighbor_node diff --git a/src/qs_neighbor_lists.F b/src/qs_neighbor_lists.F index 4c8e38cf4f..b67e328c93 100644 --- a/src/qs_neighbor_lists.F +++ b/src/qs_neighbor_lists.F @@ -112,6 +112,10 @@ MODULE qs_neighbor_lists END TYPE local_atoms_type ! ************************************************************************************************** + TYPE local_lists + INTEGER, DIMENSION(:), POINTER :: list => NULL() + END TYPE local_lists + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_neighbor_lists' ! private counter, used to version qs neighbor lists @@ -430,7 +434,7 @@ CONTAINS IF (dokp) THEN ! no MIC for kpoints mic = .FALSE. - ELSEIF (nddo) THEN + ELSE IF (nddo) THEN ! enforce MIC for interaction lists in SE mic = .TRUE. END IF @@ -663,8 +667,9 @@ CONTAINS CALL pair_radius_setup(orb_present, orb_present, orb_radius, orb_radius, pair_radius_lb) DO jkind = 1, nkind DO ikind = 1, nkind - IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) & + IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) THEN pair_radius(ikind, jkind) = pair_radius_lb(ikind, jkind) - roperator + END IF END DO END DO ELSE @@ -947,7 +952,7 @@ CONTAINS qs_env%lri_env%soo_list => soo_list CALL write_neighbor_lists(soo_list, particle_set, cell, para_env, neighbor_list_section, & "/SOO_LIST", "soo_list", "ORBITAL ORBITAL (RI)") - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN ALLOCATE (ri_present(nkind), ri_radius(nkind)) ri_present = .FALSE. ri_radius = 0.0_dp @@ -1081,31 +1086,28 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'build_neighbor_lists' - TYPE local_lists - INTEGER, DIMENSION(:), POINTER :: list - END TYPE local_lists - - INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, & - iatom_subcell, icell, ikind, j, jatom, jatom_local, jcell, jkind, k, & - kcell, maxat, mol_a, mol_b, nkind, otype, natom, inode, nnode, nentry + INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, iatom_subcell, icell, ikind, & + inode, j, jatom, jatom_local, jcell, jkind, k, kcell, maxat, mol_a, mol_b, natom, nentry, & + nkind, nnode, otype + INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb INTEGER, DIMENSION(3) :: cell_b, ncell, nsubcell, periodic INTEGER, DIMENSION(:), POINTER :: index_list - LOGICAL :: include_ab, my_mic, & - my_molecular, my_symmetric, my_sort_atomb + LOGICAL :: include_ab, my_mic, my_molecular, & + my_sort_atomb, my_symmetric LOGICAL, ALLOCATABLE, DIMENSION(:) :: pres_a, pres_b - REAL(dp) :: rab2, rab2_max, rab_max, rabm, deth, subcell_scale - REAL(dp), DIMENSION(3) :: r, rab, ra, rb, sab_max, sb, & - sb_pbc, sb_min, sb_max, rab_pbc, pd, sab_max_guard - INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb + REAL(dp) :: deth, rab2, rab2_max, rab_max, rabm, & + subcell_scale + REAL(dp), DIMENSION(3) :: pd, r, ra, rab, rab_pbc, rb, sab_max, & + sab_max_guard, sb, sb_max, sb_min, & + sb_pbc + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: r_pbc TYPE(local_lists), DIMENSION(:), POINTER :: lista, listb - TYPE(neighbor_list_p_type), & - ALLOCATABLE, DIMENSION(:) :: kind_a - TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set - TYPE(subcell_type), DIMENSION(:, :, :), & - POINTER :: subcell - REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: r_pbc TYPE(neighbor_list_iterator_p_type), & DIMENSION(:), POINTER :: nl_iterator + TYPE(neighbor_list_p_type), ALLOCATABLE, & + DIMENSION(:) :: kind_a + TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set + TYPE(subcell_type), DIMENSION(:, :, :), POINTER :: subcell CALL timeset(routineN//"_"//TRIM(nlname), handle) diff --git a/src/qs_nonscf_utils.F b/src/qs_nonscf_utils.F index bc73ecfbd9..79bf5fd5e2 100644 --- a/src/qs_nonscf_utils.F +++ b/src/qs_nonscf_utils.F @@ -82,19 +82,22 @@ CONTAINS "Self energy of the core charge distribution: ", energy%core_self, & "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", energy%exc - IF (energy%dispersion /= 0.0_dp) & + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - IF (energy%gcp /= 0.0_dp) & + "Dispersion energy: ", energy%dispersion + END IF + IF (energy%gcp /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - IF (energy%efield /= 0.0_dp) & + "gCP energy: ", energy%gcp + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT("NONSCF not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPASSERT(energy%dftb3 == 0.0_dp) energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & @@ -103,10 +106,11 @@ CONTAINS "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Dispersion energy: ", energy%dispersion - IF (energy%efield /= 0.0_dp) & + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - ELSEIF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + END IF + ELSE IF (dft_control%qs_control%xtb) THEN energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & "Diagonalization", "Time:", tdiag, energy%total @@ -117,12 +121,14 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - IF (energy%efield /= 0.0_dp) & + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF ELSE CPABORT("NONSCF not available") END IF diff --git a/src/qs_ot.F b/src/qs_ot.F index 2b13565c51..598749bc9c 100644 --- a/src/qs_ot.F +++ b/src/qs_ot.F @@ -295,8 +295,9 @@ CONTAINS ! ! compute the P^(-1/2) DO i = 1, k - IF (eig(i) <= 0.0_dp) & + IF (eig(i) <= 0.0_dp) THEN CPABORT("P not positive definite") + END IF IF (eig(i) < 1.0E-8_dp) THEN fun(i) = 0.0_dp ELSE diff --git a/src/qs_ot_types.F b/src/qs_ot_types.F index d184e998fd..d301039af0 100644 --- a/src/qs_ot_types.F +++ b/src/qs_ot_types.F @@ -269,25 +269,31 @@ CONTAINS CALL dbcsr_set(qs_ot_env%matrix_gx, 0.0_dp) - IF (qs_ot_env%use_dx) & + IF (qs_ot_env%use_dx) THEN CALL dbcsr_set(qs_ot_env%matrix_dx, 0.0_dp) + END IF - IF (qs_ot_env%use_gx_old) & + IF (qs_ot_env%use_gx_old) THEN CALL dbcsr_set(qs_ot_env%matrix_gx_old, 0.0_dp) + END IF IF (qs_ot_env%settings%do_rotation) THEN CALL dbcsr_set(qs_ot_env%rot_mat_gx, 0.0_dp) - IF (qs_ot_env%use_dx) & + IF (qs_ot_env%use_dx) THEN CALL dbcsr_set(qs_ot_env%rot_mat_dx, 0.0_dp) - IF (qs_ot_env%use_gx_old) & + END IF + IF (qs_ot_env%use_gx_old) THEN CALL dbcsr_set(qs_ot_env%rot_mat_gx_old, 0.0_dp) + END IF END IF IF (qs_ot_env%settings%do_ener) THEN qs_ot_env%ener_gx(:) = 0.0_dp - IF (qs_ot_env%use_dx) & + IF (qs_ot_env%use_dx) THEN qs_ot_env%ener_dx(:) = 0.0_dp - IF (qs_ot_env%use_gx_old) & + END IF + IF (qs_ot_env%use_gx_old) THEN qs_ot_env%ener_gx_old(:) = 0.0_dp + END IF END IF END SUBROUTINE qs_ot_init diff --git a/src/qs_outer_scf.F b/src/qs_outer_scf.F index 1b4a93e52d..55d7d7b239 100644 --- a/src/qs_outer_scf.F +++ b/src/qs_outer_scf.F @@ -318,10 +318,11 @@ CONTAINS END IF IF (scf_control%outer_scf%cdft_opt_control%broyden_update) THEN ! Perform a Broyden update of the inverse Jacobian J^(-1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF "// & "must be greater than or equal to 3 for Broyden optimizers.") + END IF nvar = SIZE(scf_env%outer_scf%gradient, 1) ALLOCATE (f(nvar, 1), x(nvar, 1)) DO i = 1, nvar @@ -572,31 +573,37 @@ CONTAINS cdft_control%constraint%deallocate_jacobian = scf_env%outer_scf%deallocate_jacobian IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN nvariables = SIZE(scf_env%outer_scf%inv_jacobian, 1) - IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) & + IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN ALLOCATE (cdft_control%constraint%inv_jacobian(nvariables, nvariables)) + END IF cdft_control%constraint%inv_jacobian = scf_env%outer_scf%inv_jacobian END IF ! Now switch - IF (ASSOCIATED(scf_env%outer_scf%energy)) & + IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN DEALLOCATE (scf_env%outer_scf%energy) + END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%variables)) & + IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN DEALLOCATE (scf_env%outer_scf%variables) + END IF ALLOCATE (scf_env%outer_scf%variables(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%gradient)) & + IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN DEALLOCATE (scf_env%outer_scf%gradient) + END IF ALLOCATE (scf_env%outer_scf%gradient(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%count)) & + IF (ASSOCIATED(scf_env%outer_scf%count)) THEN DEALLOCATE (scf_env%outer_scf%count) + END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = 0 ! OT SCF does not need Jacobian scf_env%outer_scf%deallocate_jacobian = .TRUE. - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN DEALLOCATE (scf_env%outer_scf%inv_jacobian) + END IF CASE (ot2cdft) ! OT -> constraint scf_control%outer_scf%have_scf = cdft_control%constraint_control%have_scf @@ -610,27 +617,32 @@ CONTAINS CALL cdft_opt_type_copy(scf_control%outer_scf%cdft_opt_control, & cdft_control%constraint_control%cdft_opt_control) nvariables = SIZE(cdft_control%constraint%variables, 1) - IF (ASSOCIATED(scf_env%outer_scf%energy)) & + IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN DEALLOCATE (scf_env%outer_scf%energy) + END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = cdft_control%constraint%energy - IF (ASSOCIATED(scf_env%outer_scf%variables)) & + IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN DEALLOCATE (scf_env%outer_scf%variables) + END IF ALLOCATE (scf_env%outer_scf%variables(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = cdft_control%constraint%variables - IF (ASSOCIATED(scf_env%outer_scf%gradient)) & + IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN DEALLOCATE (scf_env%outer_scf%gradient) + END IF ALLOCATE (scf_env%outer_scf%gradient(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = cdft_control%constraint%gradient - IF (ASSOCIATED(scf_env%outer_scf%count)) & + IF (ASSOCIATED(scf_env%outer_scf%count)) THEN DEALLOCATE (scf_env%outer_scf%count) + END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = cdft_control%constraint%count scf_env%outer_scf%iter_count = cdft_control%constraint%iter_count scf_env%outer_scf%deallocate_jacobian = cdft_control%constraint%deallocate_jacobian IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN DEALLOCATE (scf_env%outer_scf%inv_jacobian) + END IF ALLOCATE (scf_env%outer_scf%inv_jacobian(nvariables, nvariables)) scf_env%outer_scf%inv_jacobian = cdft_control%constraint%inv_jacobian END IF diff --git a/src/qs_overlap.F b/src/qs_overlap.F index 857850a5bf..6007a9739d 100644 --- a/src/qs_overlap.F +++ b/src/qs_overlap.F @@ -235,7 +235,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSEIF (PRESENT(matrixkp_s)) THEN + ELSE IF (PRESENT(matrixkp_s)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -868,7 +868,7 @@ CONTAINS IF (PRESENT(matrix_p)) THEN dokp = .FALSE. use_cell_mapping = .FALSE. - ELSEIF (PRESENT(matrixkp_p)) THEN + ELSE IF (PRESENT(matrixkp_p)) THEN dokp = .TRUE. CALL get_ks_env(ks_env=ks_env, kpoints=kpoints) CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) diff --git a/src/qs_p_env_methods.F b/src/qs_p_env_methods.F index b7e2b9a78c..7fde38663a 100644 --- a/src/qs_p_env_methods.F +++ b/src/qs_p_env_methods.F @@ -224,8 +224,9 @@ CONTAINS END DO p_env%orthogonal_orbitals = .FALSE. - IF (PRESENT(orthogonal_orbitals)) & + IF (PRESENT(orthogonal_orbitals)) THEN p_env%orthogonal_orbitals = orthogonal_orbitals + END IF CALL fm_pools_create_fm_vect(ao_mo_fm_pools, elements=p_env%S_psi0, & name="p_env%S_psi0") @@ -265,7 +266,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, p_env%local_rho_set%rho0_mpole) CALL hartree_local_create(p_env%hartree_local) CALL init_coulomb_local(p_env%hartree_local, natom) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_pdos.F b/src/qs_pdos.F index 5a16f5b080..3f569ade73 100644 --- a/src/qs_pdos.F +++ b/src/qs_pdos.F @@ -579,8 +579,9 @@ CONTAINS eval_ref => mos_ref(ispin_ref)%eigenvalues occ_ref => mos_ref(ispin_ref)%occupation_numbers DO imo_ref = 1, nmo_ref - IF (occ_ref(imo_ref) > 1.0e-10_dp) & + IF (occ_ref(imo_ref) > 1.0e-10_dp) THEN hoco_ref(ispin_ref) = MAX(hoco_ref(ispin_ref), eval_ref(imo_ref)) + END IF IF (ABS(occ_ref(imo_ref) - REAL(NINT(occ_ref(imo_ref)), KIND=dp)) > & 1.0e-8_dp) fractional_occupation = .TRUE. END DO @@ -618,10 +619,12 @@ CONTAINS !Adjust energy range for r_ldos DO ildos = 1, n_r_ldos - IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) & + IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) THEN r_ldos_p(ildos)%ldos%eval_range(1) = eigenvalues(1) - IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) & + END IF + IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) THEN r_ldos_p(ildos)%ldos%eval_range(2) = eigenvalues(nmo + nvirt) + END IF END DO IF (output_unit > 0) WRITE (UNIT=output_unit, FMT='(/,(T15,A))') & diff --git a/src/qs_resp.F b/src/qs_resp.F index 971dd1768c..13843d37cc 100644 --- a/src/qs_resp.F +++ b/src/qs_resp.F @@ -396,9 +396,10 @@ CONTAINS r_val=resp_env%rheavies_strength) END IF CALL section_vals_val_get(resp_section, "STRIDE", i_vals=my_stride) - IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) & + IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 (the same for X,Y,Z) "// & "or 3 values. Correct your input file.") + END IF IF (SIZE(my_stride) == 1) THEN DO i = 1, 3 resp_env%stride(i) = my_stride(1) @@ -726,8 +727,9 @@ CONTAINS DO j = i + 1, num_atom atom_a = atom_list(i) atom_b = atom_list(j) - IF (atom_a == atom_b) & + IF (atom_a == atom_b) THEN CPABORT("There are atoms doubled in atom list for RESP.") + END IF END DO END DO diff --git a/src/qs_rho0_ggrid.F b/src/qs_rho0_ggrid.F index a6a8c57793..d3fa12931d 100644 --- a/src/qs_rho0_ggrid.F +++ b/src/qs_rho0_ggrid.F @@ -440,9 +440,10 @@ CONTAINS ! END IF !END IF - IF (PRESENT(local_rho_set)) & + IF (PRESENT(local_rho_set)) THEN CALL get_local_rho(local_rho_set, rho0_mpole=rho0_mpole, rho_atom_set=rho_atom_set, & rhoz_cneo_set=rhoz_cneo_set) + END IF ! Q from rho0_mpole of local_rho_set ! for TDDFT forces we need mixed potential / integral space ! potential stored on local_rho_set_2nd diff --git a/src/qs_rho_methods.F b/src/qs_rho_methods.F index 7cb0436876..f54d7afcd9 100644 --- a/src/qs_rho_methods.F +++ b/src/qs_rho_methods.F @@ -140,8 +140,9 @@ CONTAINS do_kpoints=do_kpoints, & pw_env=pw_env, & dft_control=dft_control) - IF (PRESENT(pw_env_external)) & + IF (PRESENT(pw_env_external)) THEN pw_env => pw_env_external + END IF nimg = dft_control%nimages @@ -182,8 +183,9 @@ CONTAINS ! rho_ao IF (my_rebuild_ao .OR. (.NOT. ASSOCIATED(rho_ao_kp))) THEN - IF (ASSOCIATED(rho_ao_kp)) & + IF (ASSOCIATED(rho_ao_kp)) THEN CALL dbcsr_deallocate_matrix_set(rho_ao_kp) + END IF ! Create a new density matrix set CALL dbcsr_allocate_matrix_set(rho_ao_kp, nspins, nimg) CALL qs_rho_set(rho, rho_ao_kp=rho_ao_kp) @@ -406,12 +408,12 @@ CONTAINS CALL calculate_harris_density(qs_env, harris_env%rhoin, rho_struct) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSEIF (dft_control%qs_control%semi_empirical .OR. & - dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%semi_empirical .OR. & + dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) - ELSEIF (dft_control%qs_control%lrigpw) THEN + ELSE IF (dft_control%qs_control%lrigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) @@ -427,7 +429,7 @@ CONTAINS CALL set_qs_env(qs_env, lri_density=lri_density) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSEIF (dft_control%qs_control%rigpw) THEN + ELSE IF (dft_control%qs_control%rigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL get_qs_env(qs_env, lri_env=lri_env) diff --git a/src/qs_scf.F b/src/qs_scf.F index 30865f773b..8c9eaf8760 100644 --- a/src/qs_scf.F +++ b/src/qs_scf.F @@ -278,8 +278,9 @@ CONTAINS scf_control%outer_scf%cdft_opt_control%ijacobian(2) = scf_control%outer_scf%cdft_opt_control%ijacobian(2) + 1 IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) .AND. & - scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) & + scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) THEN scf_env%outer_scf%deallocate_jacobian = .TRUE. + END IF END IF END IF ! *** add the converged wavefunction to the wavefunction history @@ -317,8 +318,9 @@ CONTAINS ! *** cleanup CALL scf_env_cleanup(scf_env) - IF (dft_control%qs_control%cdft) & + IF (dft_control%qs_control%cdft) THEN CALL cdft_control_cleanup(dft_control%qs_control%cdft_control) + END IF IF (PRESENT(has_converged)) THEN has_converged = converged @@ -474,10 +476,11 @@ CONTAINS CALL get_results(results, description=description, & values=res_val_3, n_entries=i_tmp) CPASSERT(i_tmp == 3) - IF (ALL(res_val_3(:) <= 0.0)) & + IF (ALL(res_val_3(:) <= 0.0)) THEN CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)// & ") which is not correctly stored.") + END IF CALL external_comm%set_handle(NINT(res_val_3(1))) END IF ext_master_id = NINT(res_val_3(2)) @@ -578,7 +581,7 @@ CONTAINS IF (tblite_native_mixer) THEN scf_env%iter_param = dft_control%qs_control%xtb_control%tblite_mixer_damping scf_env%iter_method = "TBLite/Diag" - ELSEIF (internal_tblite_mixer) THEN + ELSE IF (internal_tblite_mixer) THEN scf_env%iter_method = "TBLite/Diag" IF (dft_control%qs_control%dftb) THEN scf_env%iter_param = dft_control%qs_control%dftb_control%tblite_mixer_damping @@ -641,8 +644,9 @@ CONTAINS END IF IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) & + scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) THEN t1 = m_walltime() + END IF ! mixing methods have the new density matrix in p_mix_new IF (scf_env%mixing_method > 0) THEN @@ -691,9 +695,10 @@ CONTAINS converged = inner_loop_converged .AND. outer_loop_converged total_scf_steps = total_steps - IF (dft_control%qs_control%cdft) & + IF (dft_control%qs_control%cdft) THEN dft_control%qs_control%cdft_control%total_steps = & - dft_control%qs_control%cdft_control%total_steps + total_steps + dft_control%qs_control%cdft_control%total_steps + total_steps + END IF IF (.NOT. converged) THEN IF (scf_control%ignore_convergence_failure .OR. should_stop) THEN @@ -715,8 +720,10 @@ CONTAINS ! if needed copy mo_coeff dbcsr->fm for later use in post_scf!fm->dbcsr DO ispin = 1, SIZE(mos) !fm -> dbcsr IF (mos(ispin)%use_mo_coeff_b) THEN !fm->dbcsr - IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) & !fm->dbcsr - CPABORT("mo_coeff_b is not allocated") !fm->dbcsr + IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) THEN + !fm->dbcsr + CPABORT("mo_coeff_b is not allocated") + END IF !fm->dbcsr CALL copy_dbcsr_to_fm(mos(ispin)%mo_coeff_b, & !fm->dbcsr mos(ispin)%mo_coeff) !fm -> dbcsr END IF !fm->dbcsr @@ -921,10 +928,11 @@ CONTAINS IF (dft_control%restricted) THEN scf_env%qs_ot_env(1)%restricted = .TRUE. ! requires rotation - IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) & + IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) THEN CALL cp_abort(__LOCATION__, & "Restricted calculation with OT requires orbital rotation. Please "// & "activate the OT%ROTATION keyword!") + END IF ELSE scf_env%qs_ot_env(:)%restricted = .FALSE. END IF @@ -934,8 +942,9 @@ CONTAINS do_rotation = scf_env%qs_ot_env(1)%settings%do_rotation ! only full all needs rotation is_full_all = scf_env%qs_ot_env(1)%settings%preconditioner_type == ot_precond_full_all - IF (do_rotation .AND. is_full_all) & + IF (do_rotation .AND. is_full_all) THEN CPABORT('PRECONDITIONER FULL_ALL is not compatible with ROTATION.') + END IF ! might need the KS matrix to init properly CALL qs_ks_update_qs_env(qs_env, just_energy=.FALSE., & @@ -943,10 +952,11 @@ CONTAINS ! if an old preconditioner is still around (i.e. outer SCF is active), ! remove it if this could be worthwhile - IF (.NOT. reuse_precond) & + IF (.NOT. reuse_precond) THEN CALL restart_preconditioner(qs_env, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & dft_control%nspins) + END IF ! ! preconditioning still needs to be done correctly with has_unit_metric @@ -958,13 +968,14 @@ CONTAINS orthogonality_metric => matrix_s(1)%matrix END IF - IF (.NOT. reuse_precond) & + IF (.NOT. reuse_precond) THEN CALL prepare_preconditioner(qs_env, mos, matrix_ks, matrix_s, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & scf_env%qs_ot_env(1)%settings%precond_solver_type, & scf_env%qs_ot_env(1)%settings%energy_gap, dft_control%nspins, & has_unit_metric=has_unit_metric, & chol_type=scf_env%qs_ot_env(1)%settings%cholesky_type) + END IF IF (reuse_precond) reuse_precond = .FALSE. CALL ot_scf_init(mo_array=mos, matrix_s=orthogonality_metric, & @@ -1203,8 +1214,9 @@ CONTAINS ! usually this means that the electronic structure has already converged to the correct state ! but the constraint optimizer keeps jumping over the optimal solution IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count == 1 & - .AND. cdft_control%total_steps /= 1) & + .AND. cdft_control%total_steps /= 1) THEN cdft_control%nreused = cdft_control%nreused - 1 + END IF ! SCF converged in less than precond_freq steps IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count <= cdft_control%precond_freq .AND. & cdft_control%total_steps /= 1 .AND. cdft_control%nreused < cdft_control%max_reuse) THEN @@ -1356,17 +1368,22 @@ CONTAINS SUBROUTINE cdft_control_cleanup(cdft_control) TYPE(cdft_control_type), POINTER :: cdft_control - IF (ASSOCIATED(cdft_control%constraint%variables)) & + IF (ASSOCIATED(cdft_control%constraint%variables)) THEN DEALLOCATE (cdft_control%constraint%variables) - IF (ASSOCIATED(cdft_control%constraint%count)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%count)) THEN DEALLOCATE (cdft_control%constraint%count) - IF (ASSOCIATED(cdft_control%constraint%gradient)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN DEALLOCATE (cdft_control%constraint%gradient) - IF (ASSOCIATED(cdft_control%constraint%energy)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%energy)) THEN DEALLOCATE (cdft_control%constraint%energy) + END IF IF (ASSOCIATED(cdft_control%constraint%inv_jacobian) .AND. & - cdft_control%constraint%deallocate_jacobian) & + cdft_control%constraint%deallocate_jacobian) THEN DEALLOCATE (cdft_control%constraint%inv_jacobian) + END IF END SUBROUTINE cdft_control_cleanup @@ -1438,10 +1455,11 @@ CONTAINS IF (explicit_jacobian) THEN ! Build Jacobian with finite differences cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) & + IF (.NOT. ASSOCIATED(cdft_control)) THEN CALL cp_abort(__LOCATION__, & "Optimizers that need the explicit Jacobian can"// & " only be used together with a valid CDFT constraint.") + END IF ! Redirect output from Jacobian calculation to a new file by creating a temporary logger project_name = logger%iter_info%project_name CALL create_tmp_logger(para_env, project_name, "-JacobianInfo.out", output_unit, tmp_logger) @@ -1537,8 +1555,9 @@ CONTAINS jacobian(i, j) = jacobian(i, j)/dh(j) END DO END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) scf_control%outer_scf%cdft_opt_control%broyden_update = .FALSE. @@ -1629,22 +1648,25 @@ CONTAINS do_linesearch = .FALSE. CASE (broyden_type_1_ls, broyden_type_1_explicit_ls, broyden_type_2_ls, broyden_type_2_explicit_ls) cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) & + IF (.NOT. ASSOCIATED(cdft_control)) THEN CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + END IF + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN do_linesearch = .TRUE. + END IF END SELECT END SELECT IF (do_linesearch) THEN BLOCK TYPE(mo_set_type), DIMENSION(:), ALLOCATABLE :: mos_ls, mos_stashed cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) & + IF (.NOT. ASSOCIATED(cdft_control)) THEN CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") + END IF CPASSERT(ASSOCIATED(scf_env%outer_scf%inv_jacobian)) CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) alpha = scf_control%outer_scf%cdft_opt_control%newton_step_save @@ -1778,8 +1800,9 @@ CONTAINS IF (i == max_linesearch) continue_ls_exit = .TRUE. ! Exit if constraint target is satisfied to requested tolerance IF (SQRT(MAXVAL(scf_env%outer_scf%gradient(:, scf_env%outer_scf%iter_count + 1)**2)) < & - scf_control%outer_scf%eps_scf) & + scf_control%outer_scf%eps_scf) THEN continue_ls_exit = .TRUE. + END IF ! Exit if line search jumped over the optimal step length IF (sign_changed) continue_ls_exit = .TRUE. END IF @@ -1835,9 +1858,10 @@ CONTAINS "Line search did not converge. CDFT SCF proceeds with fixed step size.") scf_control%outer_scf%cdft_opt_control%newton_step = scf_control%outer_scf%cdft_opt_control%newton_step_save END IF - IF (reached_maxls) & + IF (reached_maxls) THEN CALL cp_warn(__LOCATION__, & "Line search did not converge. CDFT SCF proceeds with lasted iterated step size.") + END IF CALL cp_rm_default_logger() CALL cp_logger_release(tmp_logger) ! Release temporary storage diff --git a/src/qs_scf_csr_write.F b/src/qs_scf_csr_write.F index c92135f798..557ff151d3 100644 --- a/src/qs_scf_csr_write.F +++ b/src/qs_scf_csr_write.F @@ -594,8 +594,9 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN nomirror = nomirror + 1 + END IF END DO ! create the mirror imgs diff --git a/src/qs_scf_diagonalization.F b/src/qs_scf_diagonalization.F index 0c0619c93f..fc7973f9c5 100644 --- a/src/qs_scf_diagonalization.F +++ b/src/qs_scf_diagonalization.F @@ -223,7 +223,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1124,9 +1124,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(subspace_env%mixing_store) - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, para_env) @@ -1378,7 +1378,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1476,7 +1476,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/OTdiag." - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/OTdiag." END IF @@ -1695,7 +1695,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF @@ -1917,10 +1917,11 @@ CONTAINS CALL lanczos_refinement(scf_env%krylov_space, ks, c0, c1, mo_eigenvalues, & nao, eps_iter, ispin, check_moconv_only=my_check_moconv_only) t2 = m_walltime() - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(T8,I3,T16,I5,T24,I6,T33,E12.4,2x,E12.4,T60,F8.3)') & - ispin, iter, scf_env%krylov_space%nmo_conv, & - scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 + ispin, iter, scf_env%krylov_space%nmo_conv, & + scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 + END IF CYCLE ELSE @@ -2038,8 +2039,9 @@ CONTAINS output_unit = cp_print_key_unit_nr(logger, scf_section, "PRINT%DAVIDSON", & extension=".scfLog") - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/T15,A)") '<<<<<<<<< DAVIDSON ITERATIONS <<<<<<<<<<' + END IF IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha diff --git a/src/qs_scf_initialization.F b/src/qs_scf_initialization.F index 71bed6abc6..fd63e14991 100644 --- a/src/qs_scf_initialization.F +++ b/src/qs_scf_initialization.F @@ -349,13 +349,15 @@ CONTAINS NULLIFY (outer_scf_history, gradient_history, variable_history) CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) ! Test kpoints - IF (do_kpoints) & + IF (do_kpoints) THEN CPABORT("CDFT calculation not possible with kpoints") + END IF ! Check that OUTER_SCF section in DFT&SCF is active ! This section must always be active to facilitate ! switching of the CDFT and SCF control parameters in outer_loop_switch - IF (.NOT. scf_control%outer_scf%have_scf) & + IF (.NOT. scf_control%outer_scf%have_scf) THEN CPABORT("Section SCF&OUTER_SCF must be active for CDFT calculations.") + END IF ! Initialize CDFT and outer_loop variables (constraint settings active in scf_control) IF (dft_control%qs_control%cdft_control%constraint_control%have_scf) THEN nhistory = dft_control%qs_control%cdft_control%constraint_control%max_scf + 1 @@ -660,10 +662,12 @@ CONTAINS ! possible for OT gamma point calculations qs_env%requires_mo_derivs = .FALSE. END IF - IF (dft_control%do_xas_calculation) & + IF (dft_control%do_xas_calculation) THEN CPABORT("No XAS implemented with kpoints") - IF (qs_env%do_rixs) & + END IF + IF (qs_env%do_rixs) THEN CPABORT("RIXS not implemented with kpoints") + END IF DO ik = 1, SIZE(kpoints%kp_env) CALL mpools_get(kpoints%mpools, ao_mo_fm_pools=ao_mo_fm_pools) mos_k => kpoints%kp_env(ik)%kpoint_env%mos @@ -794,12 +798,14 @@ CONTAINS IF (scf_control%use_diag) THEN ! sanity check whether combinations are allowed - IF (dft_control%restricted) & + IF (dft_control%restricted) THEN CPABORT("OT only for restricted (ROKS)") + END IF SELECT CASE (scf_control%diagonalization%method) CASE (diag_ot, diag_block_krylov, diag_block_davidson) - IF (.NOT. not_se_or_tb) & + IF (.NOT. not_se_or_tb) THEN CPABORT("TB and SE not possible with OT diagonalization") + END IF END SELECT SELECT CASE (scf_control%diagonalization%method) ! Diagonalization: additional check whether we are in an orthonormal basis @@ -820,32 +826,39 @@ CONTAINS END IF ! OT Diagonalization: not possible with ROKS CASE (diag_ot) - IF (dft_control%roks) & + IF (dft_control%roks) THEN CPABORT("ROKS with OT diagonalization not possible") - IF (do_kpoints) & + END IF + IF (do_kpoints) THEN CPABORT("OT diagonalization not possible with kpoint calculations") + END IF scf_env%method = ot_diag_method_nr need_coeff_b = .TRUE. ! Block Krylov diagonlization: not possible with ROKS, ! allocation of additional matrices is needed CASE (diag_block_krylov) - IF (dft_control%roks) & + IF (dft_control%roks) THEN CPABORT("ROKS with block PF diagonalization not possible") - IF (do_kpoints) & + END IF + IF (do_kpoints) THEN CPABORT("Block Krylov diagonalization not possible with kpoint calculations") + END IF scf_env%method = block_krylov_diag_method_nr scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%krylov_space)) & + IF (.NOT. ASSOCIATED(scf_env%krylov_space)) THEN CALL krylov_space_create(scf_env%krylov_space, scf_section) + END IF CALL krylov_space_allocate(scf_env%krylov_space, scf_control, mos) ! Block davidson diagonlization: allocation of additional matrices is needed CASE (diag_block_davidson) - IF (do_kpoints) & + IF (do_kpoints) THEN CPABORT("Block Davidson diagonalization not possible with kpoint calculations") + END IF scf_env%method = block_davidson_diag_method_nr - IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) & + IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) THEN CALL block_davidson_env_create(scf_env%block_davidson_env, dft_control%nspins, & scf_section) + END IF DO ispin = 1, dft_control%nspins CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff, nao=nao, nmo=nmo) CALL block_davidson_allocate(scf_env%block_davidson_env(ispin), mo_coeff, nao, nmo) @@ -868,24 +881,29 @@ CONTAINS ! Check if subspace diagonlization is requested: allocation of additional matrices is needed IF (scf_control%do_diag_sub) THEN scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%subspace_env)) & + IF (.NOT. ASSOCIATED(scf_env%subspace_env)) THEN CALL diag_subspace_env_create(scf_env%subspace_env, scf_section, & dft_control%qs_control%cutoff) + END IF CALL diag_subspace_allocate(scf_env%subspace_env, qs_env, mos) - IF (do_kpoints) & + IF (do_kpoints) THEN CPABORT("No subspace diagonlization with kpoint calculation") + END IF END IF ! OT: check if OT is used instead of diagonalization. Not possible with added MOS at the moment - ELSEIF (scf_control%use_ot) THEN + ELSE IF (scf_control%use_ot) THEN scf_env%method = ot_method_nr need_coeff_b = .TRUE. - IF (SUM(ABS(scf_control%added_mos)) > 0) & + IF (SUM(ABS(scf_control%added_mos)) > 0) THEN CPABORT("OT with ADDED_MOS/=0 not implemented") - IF (dft_control%restricted .AND. dft_control%nspins /= 2) & + END IF + IF (dft_control%restricted .AND. dft_control%nspins /= 2) THEN CPABORT("nspin must be 2 for restricted (ROKS)") - IF (do_kpoints) & + END IF + IF (do_kpoints) THEN CPABORT("OT not possible with kpoint calculations") - ELSEIF (scf_env%method /= smeagol_method_nr) THEN + END IF + ELSE IF (scf_env%method /= smeagol_method_nr) THEN CPABORT("OT or DIAGONALIZATION have to be set") END IF DO ispin = 1, dft_control%nspins @@ -1289,9 +1307,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(scf_env%mixing_store) - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & diff --git a/src/qs_scf_loop_utils.F b/src/qs_scf_loop_utils.F index 9732a0c488..148d1bc942 100644 --- a/src/qs_scf_loop_utils.F +++ b/src/qs_scf_loop_utils.F @@ -172,13 +172,13 @@ CONTAINS "SCF%DIAGONALIZATION if "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE ") - ELSEIF (dft_control%roks) THEN + ELSE IF (dft_control%roks) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE "// & "is not implemented with ROKS") - ELSEIF (scf_control%diagonalization%mom) THEN + ELSE IF (scf_control%diagonalization%mom) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & @@ -342,8 +342,9 @@ CONTAINS scf_control%eps_diis = 0.0_dp END IF - IF (dft_control%roks) & + IF (dft_control%roks) THEN CPABORT("KP code: ROKS method not available: ") + END IF SELECT CASE (scf_env%method) CASE DEFAULT @@ -370,7 +371,7 @@ CONTAINS ELSE IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF diff --git a/src/qs_scf_methods.F b/src/qs_scf_methods.F index bfba4f2e90..cbb13c407d 100644 --- a/src/qs_scf_methods.F +++ b/src/qs_scf_methods.F @@ -197,14 +197,16 @@ CONTAINS CASE (cholesky_reduce) CALL cp_fm_cholesky_reduce(matrix_ks_fm, ortho) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF CASE (cholesky_restore) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -213,15 +215,17 @@ CONTAINS CALL cp_fm_cholesky_restore(work, nao, ortho, matrix_ks_fm, & "SOLVE", pos="LEFT", transa="T") - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF CASE (cholesky_inverse) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -231,17 +235,19 @@ CONTAINS CALL cp_fm_triangular_multiply(ortho, matrix_ks_fm, side="L", transpose_tr=.TRUE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nao, alpha=1.0_dp) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_triangular_multiply(ortho, work, side="L", transpose_tr=.FALSE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nmo, alpha=1.0_dp) CALL cp_fm_to_fm(work, mo_coeff, nmo, 1, 1) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF END SELECT @@ -426,9 +432,10 @@ CONTAINS CALL cp_fm_symm("L", "U", nao, nao_red, 1.0_dp, matrix_ks_fm, ortho_red, 0.0_dp, work_red) CALL parallel_gemm("T", "N", nao_red, nao_red, nao, 1.0_dp, ortho_red, work_red, 0.0_dp, matrix_ks_fm_red) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm_red, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm_red) + END IF CALL cp_fm_create(work_red2, matrix_ks_fm_red%matrix_struct) ALLOCATE (eigenvalues(nao_red)) @@ -440,16 +447,18 @@ CONTAINS ELSE CALL cp_fm_symm("L", "U", nao, nao, 1.0_dp, matrix_ks_fm, ortho, 0.0_dp, work) CALL parallel_gemm("T", "N", nao, nao, nao, 1.0_dp, ortho, work, 0.0_dp, matrix_ks_fm) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL parallel_gemm("N", "N", nao, nmo, nao, 1.0_dp, ortho, work, 0.0_dp, & mo_coeff) END IF - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF END IF @@ -519,8 +528,9 @@ CONTAINS END IF - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF CALL timestop(handle) diff --git a/src/qs_scf_output.F b/src/qs_scf_output.F index 203abdc458..60afbc842b 100644 --- a/src/qs_scf_output.F +++ b/src/qs_scf_output.F @@ -252,11 +252,13 @@ CONTAINS occup_stats_occ_threshold = 1e-6_dp IF (SIZE(tmpstringlist) > 0) THEN ! the lone_keyword_c_vals doesn't work as advertised, handle it manually print_occup_stats = .TRUE. - IF (LEN_TRIM(tmpstringlist(1)) > 0) & + IF (LEN_TRIM(tmpstringlist(1)) > 0) THEN READ (tmpstringlist(1), *) print_occup_stats + END IF END IF - IF (SIZE(tmpstringlist) > 1) & + IF (SIZE(tmpstringlist) > 1) THEN READ (tmpstringlist(2), *) occup_stats_occ_threshold + END IF logger => cp_get_default_logger() print_mo_info = (cp_print_key_should_output(logger%iter_info, dft_section, "PRINT%MO") /= 0) @@ -701,22 +703,25 @@ CONTAINS "Two-electron integral energy [eV]: ", energy%hartree*evolt, & "Electronic energy [eV]: ", & (energy%core + 0.5_dp*energy%hartree)*evolt - IF (energy%dispersion /= 0.0_dp) & + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy [eV]: ", energy%dispersion*evolt - ELSEIF (dft_control%qs_control%dftb) THEN + "Dispersion energy [eV]: ", energy%dispersion*evolt + END IF + ELSE IF (dft_control%qs_control%dftb) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "Dispersion energy: ", energy%dispersion - IF (energy%dftb3 /= 0.0_dp) & + IF (energy%dftb3 /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "DFTB3 3rd order energy: ", energy%dftb3 - IF (energy%efield /= 0.0_dp) & + "DFTB3 3rd order energy: ", energy%dftb3 + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - ELSEIF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + END IF + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & @@ -733,28 +738,31 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN + ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "DFTB3 3rd order energy: ", energy%dftb3, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) & + IF (dft_control%qs_control%xtb_control%xb_interaction) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN + "Correction for halogen bonding: ", energy%xtb_xb_inter + END IF + ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN CPABORT("gfn_typ 2 NYA") ELSE CPABORT("invalid gfn_typ") END IF END IF - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - IF (energy%efield /= 0.0_dp) & + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF ELSE IF (dft_control%do_admm) THEN exc_energy = energy%exc + energy%exc_aux_fit @@ -792,22 +800,27 @@ CONTAINS "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", exc_energy END IF - IF (energy%e_hartree /= 0.0_dp) & + IF (energy%e_hartree /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,/,T3,A,T56,F25.14)") & - "Coulomb Electron-Electron Interaction Energy ", & - "- Already included in the total Hartree term ", energy%e_hartree - IF (energy%ex /= 0.0_dp) & + "Coulomb Electron-Electron Interaction Energy ", & + "- Already included in the total Hartree term ", energy%e_hartree + END IF + IF (energy%ex /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Hartree-Fock Exchange energy: ", energy%ex - IF (energy%dispersion /= 0.0_dp) & + "Hartree-Fock Exchange energy: ", energy%ex + END IF + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - IF (energy%gcp /= 0.0_dp) & + "Dispersion energy: ", energy%dispersion + END IF + IF (energy%gcp /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - IF (energy%efield /= 0.0_dp) & + "gCP energy: ", energy%gcp + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF IF (gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "GAPW| Exc from hard and soft atomic rho1: ", exc1_energy, & @@ -1200,9 +1213,10 @@ CONTAINS WRITE (output_unit, '(A,L7)') & " Precompute gradients : ", cdft_control%becke_control%in_memory WRITE (output_unit, '(A)') " " - IF (cdft_control%becke_control%adjust) & + IF (cdft_control%becke_control%adjust) THEN WRITE (output_unit, '(A)') & - " Using atomic radii to generate a heteronuclear charge partitioning" + " Using atomic radii to generate a heteronuclear charge partitioning" + END IF WRITE (output_unit, '(A)') " " IF (.NOT. cdft_control%becke_control%cavity_confine) THEN WRITE (output_unit, '(A)') & diff --git a/src/qs_scf_post_gpw.F b/src/qs_scf_post_gpw.F index 16cd43613c..a4fe7a7a25 100644 --- a/src/qs_scf_post_gpw.F +++ b/src/qs_scf_post_gpw.F @@ -903,9 +903,9 @@ CONTAINS IF (p_loc_homo) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSEIF (dft_control%restricted & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN + ELSE IF (dft_control%restricted & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN CPABORT("ROKS works only with LOCALIZE METHOD NONE or JACOBI") ELSE ALLOCATE (occupied_orbs(dft_control%nspins)) @@ -1053,7 +1053,7 @@ CONTAINS IF (p_loc_mixed) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSEIF (dft_control%restricted) THEN + ELSE IF (dft_control%restricted) THEN IF (output_unit > 0) WRITE (output_unit, *) & " Unclear how we define MOs / localization in the restricted case... skipping" ELSE @@ -2277,7 +2277,7 @@ CONTAINS CALL section_vals_val_get(dft_section, "PRINT%DOS%NLUMO", i_val=nlumo_dos) IF (nlumo_dos == -1) THEN nlumo_required = -1 - ELSEIF (nlumo_required /= -1) THEN + ELSE IF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_dos) END IF END IF @@ -2285,7 +2285,7 @@ CONTAINS IF (defer_molden) THEN IF (nlumo_molden == -1) THEN nlumo_required = -1 - ELSEIF (nlumo_required /= -1) THEN + ELSE IF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_molden) END IF END IF @@ -3539,10 +3539,11 @@ CONTAINS IF (do_radius) THEN radius_type = radius_user CALL section_vals_val_get(input_section, "ATOMIC_RADII", r_vals=radii) - IF (.NOT. SIZE(radii) == nkind) & + IF (.NOT. SIZE(radii) == nkind) THEN CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF ELSE radius_type = radius_covalent END IF diff --git a/src/qs_scf_post_scf.F b/src/qs_scf_post_scf.F index 5287b69456..57ef526d5b 100644 --- a/src/qs_scf_post_scf.F +++ b/src/qs_scf_post_scf.F @@ -55,15 +55,15 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CALL scf_post_calculation_se(qs_env) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL wfn_localization_tb(qs_env, "DFTB") CALL scf_post_calculation_tb(qs_env, "DFTB", .FALSE.) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL wfn_localization_tb(qs_env, "xTB") CALL scf_post_calculation_tb(qs_env, "xTB", .FALSE.) - ELSEIF (dft_control%qs_control%ofgpw) THEN + ELSE IF (dft_control%qs_control%ofgpw) THEN CPWARN("No properties from PRINT section available for OFGPW methods") - ELSEIF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN + ELSE IF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN CALL optimize_lri_basis(qs_env) ELSE IF (PRESENT(wf_type)) THEN diff --git a/src/qs_scf_wfn_mix.F b/src/qs_scf_wfn_mix.F index 0830d2bd0a..5fa98ca6f2 100644 --- a/src/qs_scf_wfn_mix.F +++ b/src/qs_scf_wfn_mix.F @@ -193,10 +193,11 @@ CONTAINS ELSE IF (orig_type == wfn_mix_orig_external) THEN CALL section_vals_val_get(update_section, "ORIG_EXT_FILE_NAME", i_rep_section=i_rep, & c_val=read_file_name) - IF (read_file_name == "EMPTY") & + IF (read_file_name == "EMPTY") THEN CALL cp_abort(__LOCATION__, & "If ORIG_TYPE is set to EXTERNAL, a file name should be set in ORIG_EXT_FILE_NAME "// & "so that it can be used as the orginal MO.") + END IF ALLOCATE (mos_orig_ext(SIZE(mos))) DO ispin = 1, SIZE(mos) @@ -205,9 +206,10 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(read_file_name), exist=is_file) - IF (.NOT. is_file) & + IF (.NOT. is_file) THEN CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(read_file_name)) + END IF CALL open_file(file_name=read_file_name, & file_action="READ", & @@ -261,10 +263,12 @@ CONTAINS IF (my_for_rtp) THEN DO ispin = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) & + IF (mos_new(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) - IF (mos(1)%use_mo_coeff_b) & + END IF + IF (mos(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) + END IF END DO ELSE IF (scf_env%method == special_diag_method_nr) THEN @@ -283,11 +287,13 @@ CONTAINS DO ispin = 1, SIZE(mos_new) IF (overwrite_mos) THEN CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) & + IF (mos_new(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) + END IF END IF - IF (mos(1)%use_mo_coeff_b) & + IF (mos(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) + END IF END DO CALL write_mo_set_to_restart(mos_new, particle_set, dft_section=dft_section, & qs_kind_set=qs_kind_set) diff --git a/src/qs_subsys_types.F b/src/qs_subsys_types.F index 0787f1db4f..3fb4c80a20 100644 --- a/src/qs_subsys_types.F +++ b/src/qs_subsys_types.F @@ -77,12 +77,15 @@ CONTAINS CALL cp_subsys_release(subsys%cp_subsys) CALL cell_release(subsys%cell_ref) - IF (ASSOCIATED(subsys%qs_kind_set)) & + IF (ASSOCIATED(subsys%qs_kind_set)) THEN CALL deallocate_qs_kind_set(subsys%qs_kind_set) - IF (ASSOCIATED(subsys%energy)) & + END IF + IF (ASSOCIATED(subsys%energy)) THEN CALL deallocate_qs_energy(subsys%energy) - IF (ASSOCIATED(subsys%force)) & + END IF + IF (ASSOCIATED(subsys%force)) THEN CALL deallocate_qs_force(subsys%force) + END IF END SUBROUTINE qs_subsys_release diff --git a/src/qs_tddfpt2_densities.F b/src/qs_tddfpt2_densities.F index c9c283e13b..63ce4065f6 100644 --- a/src/qs_tddfpt2_densities.F +++ b/src/qs_tddfpt2_densities.F @@ -100,8 +100,9 @@ CONTAINS END DO ! take into account that all MOs are doubly occupied in spin-restricted case - IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) & + IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) THEN CALL dbcsr_scale(rho_ij_ao(1)%matrix, 2.0_dp) + END IF CALL get_qs_env(qs_env, dft_control=dft_control) @@ -112,7 +113,7 @@ CONTAINS task_list_external=sub_env%task_list_orb_soft, & para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, local_rho_set=sub_env%local_rho_set, pw_env_sub=sub_env%pw_env) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL qs_rho_update_rho(rho_orb_struct, qs_env, & rho_xc_external=rho_xc_struct, & local_rho_set=sub_env%local_rho_set, & diff --git a/src/qs_tddfpt2_eigensolver.F b/src/qs_tddfpt2_eigensolver.F index dcfa59166d..12900d5dbb 100644 --- a/src/qs_tddfpt2_eigensolver.F +++ b/src/qs_tddfpt2_eigensolver.F @@ -779,8 +779,9 @@ CONTAINS ! eref = e_virt - e_occ - lambda = e_virt - e_occ - (eref_scale*lambda + (1-eref_scale)*lambda); ! eref_new = e_virt - e_occ - eref_scale*lambda = eref + (1 - eref_scale)*lambda - IF (ABS(eref) < threshold) & + IF (ABS(eref) < threshold) THEN eref = eref + (1.0_dp - eref_scale)*lambda + END IF weights_ldata(irow_local, icol_local) = weights_ldata(irow_local, icol_local)/eref END DO @@ -930,8 +931,9 @@ CONTAINS conv = MAXVAL(ABS(evals_last(1:nstates) - evals(1:nstates))) nvects_exist = nvects_exist + nvects_new - IF (nvects_exist + nvects_new > max_krylov_vects) & + IF (nvects_exist + nvects_new > max_krylov_vects) THEN nvects_new = max_krylov_vects - nvects_exist + END IF IF (iter >= tddfpt_control%niters) nvects_new = 0 IF (conv > tddfpt_control%conv .AND. nvects_new > 0) THEN @@ -982,8 +984,9 @@ CONTAINS IF (iter_unit > 0) THEN nstates_conv = 0 DO istate = 1, nstates - IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) & + IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) THEN nstates_conv = nstates_conv + 1 + END IF END DO WRITE (iter_unit, '(T7,I8,T24,F7.1,T40,ES11.4,T66,I8)') iter, t2 - t1, conv, nstates_conv diff --git a/src/qs_tddfpt2_fhxc.F b/src/qs_tddfpt2_fhxc.F index 6c4ba207e8..a8b9dfbad0 100644 --- a/src/qs_tddfpt2_fhxc.F +++ b/src/qs_tddfpt2_fhxc.F @@ -201,8 +201,8 @@ CONTAINS para_env_external=sub_env%para_env, & tddfpt_lri_env=kernel_env%lri_env, & tddfpt_lri_density=kernel_env%lri_density) - ELSEIF (dft_control%qs_control%lrigpw .OR. & - dft_control%qs_control%rigpw) THEN + ELSE IF (dft_control%qs_control%lrigpw .OR. & + dft_control%qs_control%rigpw) THEN CALL qs_rho_update_tddfpt(work_matrices%rho_orb_struct_sub, qs_env, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb, & @@ -216,7 +216,7 @@ CONTAINS para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, work_matrices%local_rho_set, & do_rho0=(.NOT. is_rks_triplets), pw_env_sub=sub_env%pw_env) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL qs_rho_update_rho(work_matrices%rho_orb_struct_sub, qs_env, & rho_xc_external=work_matrices%rho_xc_struct_sub, & local_rho_set=work_matrices%local_rho_set, & @@ -447,7 +447,7 @@ CONTAINS qs_env=qs_env, calculate_forces=.FALSE., gapw=gapw, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb_soft) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN IF (.NOT. is_rks_triplets) THEN CALL integrate_v_rspace(v_rspace=work_matrices%A_ia_rspace_sub(ispin), & hmat=work_matrices%A_ia_munu_sub(ispin), & diff --git a/src/qs_tddfpt2_fhxc_forces.F b/src/qs_tddfpt2_fhxc_forces.F index 535be9af2e..2bc0d14fc9 100644 --- a/src/qs_tddfpt2_fhxc_forces.F +++ b/src/qs_tddfpt2_fhxc_forces.F @@ -612,7 +612,7 @@ CONTAINS CALL qs_fgxc_analytic(rho, rhox, xc_section, weights, auxbas_pw_pool, & fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) END IF - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, & weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) @@ -633,7 +633,7 @@ CONTAINS IF (gapw .OR. gapw_xc) THEN IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, ex_env%local_rho_set%rho_atom_set, & local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, & @@ -820,7 +820,7 @@ CONTAINS END IF IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd derivatives of EXC not available") - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, & is_rks_triplets, weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau) @@ -909,7 +909,7 @@ CONTAINS IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, rho_atom_set, & rho_atom_set_f, rho_atom_set_g, & diff --git a/src/qs_tddfpt2_forces.F b/src/qs_tddfpt2_forces.F index 35fc7b95f1..af37574cee 100644 --- a/src/qs_tddfpt2_forces.F +++ b/src/qs_tddfpt2_forces.F @@ -907,7 +907,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole) CALL hartree_local_create(hartree_local) CALL init_coulomb_local(hartree_local, natom) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_tddfpt2_fprint.F b/src/qs_tddfpt2_fprint.F index 8f89d0a44a..4eb8f2ab0e 100644 --- a/src/qs_tddfpt2_fprint.F +++ b/src/qs_tddfpt2_fprint.F @@ -225,9 +225,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=debug_forces) ELSE CALL response_force(qs_env=qs_env, vh_rspace=ex_env%vh_rspace, & @@ -330,9 +330,9 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT| SE not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT| DFTB not available") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) CALL build_xtb_ks_matrix(qs_env, calculate_forces=.TRUE., just_energy=.FALSE.) ELSE diff --git a/src/qs_tddfpt2_methods.F b/src/qs_tddfpt2_methods.F index 9ca62a9333..0d5e1af192 100644 --- a/src/qs_tddfpt2_methods.F +++ b/src/qs_tddfpt2_methods.F @@ -285,12 +285,15 @@ CONTAINS CALL kernel_info(log_unit, dft_control, tddfpt_control, xc_section) IF (do_kpoints) THEN - IF (calc_forces) & + IF (calc_forces) THEN CPABORT("TDDFPT forces are not implemented for k-points") - IF (do_rixs) & + END IF + IF (do_rixs) THEN CPABORT("RIXS/TDDFPT is not implemented for k-points") - IF (do_soc) & + END IF + IF (do_soc) THEN CPABORT("TDDFPT-SOC is not implemented for k-points") + END IF CALL tddfpt_kpoint_independent_particle(qs_env, logger, tddfpt_control) CALL cp_print_key_finished_output(log_unit, & logger, & @@ -341,8 +344,9 @@ CONTAINS ! multiplicity of molecular system IF (nspins > 1) THEN mult = ABS(SIZE(gs_mos(1)%evals_occ) - SIZE(gs_mos(2)%evals_occ)) + 1 - IF (mult > 2) & + IF (mult > 2) THEN CALL cp_warn(__LOCATION__, "There is a convergence issue for multiplicity >= 3") + END IF ELSE IF (tddfpt_control%rks_triplets) THEN mult = 3 @@ -511,7 +515,7 @@ CONTAINS state_change = .FALSE. IF (ex_env%state > 0) THEN my_state = ex_env%state - ELSEIF (ex_env%state < 0) THEN + ELSE IF (ex_env%state < 0) THEN ! state following ALLOCATE (my_mos(nspins)) DO ispin = 1, nspins @@ -634,8 +638,9 @@ CONTAINS END DO DEALLOCATE (gs_mos) - IF (ASSOCIATED(matrix_ks_oep)) & + IF (ASSOCIATED(matrix_ks_oep)) THEN CALL dbcsr_deallocate_matrix_set(matrix_ks_oep) + END IF CALL timestop(handle) @@ -681,21 +686,27 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control, input=input, kpoints=kpoints) IF (dft_control%nimages > 1) THEN - IF (tddfpt_control%kernel /= tddfpt_kernel_none) & + IF (tddfpt_control%kernel /= tddfpt_kernel_none) THEN CPABORT("TDDFPT with k-points currently supports only KERNEL NONE") + END IF CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) & + IF (use_real_wfn) THEN CPABORT("K-point TDDFPT requires complex wavefunctions") - IF (tddfpt_control%spinflip /= no_sf_tddfpt) & + END IF + IF (tddfpt_control%spinflip /= no_sf_tddfpt) THEN CPABORT("Spin-flip TDDFPT is not implemented for k-points") - IF (tddfpt_control%do_smearing) & + END IF + IF (tddfpt_control%do_smearing) THEN CPABORT("Smeared-occupation TDDFPT is not implemented for k-points") - IF (tddfpt_control%oe_corr /= oe_none) & + END IF + IF (tddfpt_control%oe_corr /= oe_none) THEN CPABORT("Orbital-energy-corrected TDDFPT is not implemented for k-points") + END IF IF (tddfpt_control%dipole_form /= 0 .AND. & tddfpt_control%dipole_form /= tddfpt_dipole_velocity .AND. & - tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) & + tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) THEN CPABORT("K-point TDDFPT supports only velocity-form or SCF_MOMENT transition dipoles") + END IF END IF IF (tddfpt_control%nstates <= 0) THEN @@ -710,8 +721,9 @@ CONTAINS IF (dft_control%nimages > 1) THEN IF (tddfpt_control%do_exciton_descriptors .OR. & - tddfpt_control%do_directional_exciton_descriptors) & + tddfpt_control%do_directional_exciton_descriptors) THEN CPABORT("Exciton descriptors are not implemented for k-point TDDFPT") + END IF print_sub => section_vals_get_subs_vals(tddfpt_print_section, "NTO_ANALYSIS") CALL section_vals_get(print_sub, explicit=explicit) IF (explicit) CPABORT("NTO analysis is not implemented for k-point TDDFPT") @@ -1074,13 +1086,15 @@ CONTAINS ntrans_kpoint = 0 DO ispin = 1, nspins nvirt_spin(ispin) = nmo_spin(ispin) - homo_spin(ispin) - IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) & + IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) THEN CPABORT("At least one occupied and one unoccupied MO are required for k-point TDDFPT") + END IF ntrans_kpoint = ntrans_kpoint + homo_spin(ispin)*nvirt_spin(ispin) END DO ntrans_total = nkp*ntrans_kpoint - IF (ntrans_total <= 0) & + IF (ntrans_total <= 0) THEN CPABORT("No independent-particle k-point transitions available") + END IF ALLOCATE (transition_energy(ntrans_total), transition_dipole_re(ntrans_total, nderivs), & transition_dipole_im(ntrans_total, nderivs), oscillator_strength(ntrans_total), & @@ -1143,8 +1157,9 @@ CONTAINS IF (my_kpgrp) THEN CALL get_mo_set(mos_kp(1, ispin), eigenvalues=eigenvalues) CPASSERT(ASSOCIATED(eigenvalues)) - IF (para_env_kp%is_source()) & + IF (para_env_kp%is_source()) THEN eigenvalues_kp(1:nmo_spin(ispin)) = eigenvalues(1:nmo_spin(ispin)) + END IF IF (.NOT. use_scf_moment_dipoles) THEN CALL get_mo_set(mos_kp(1, ispin), mo_coeff=mo_coeff_re) CALL get_mo_set(mos_kp(2, ispin), mo_coeff=mo_coeff_im) @@ -1206,8 +1221,9 @@ CONTAINS trans_index = (ikp - 1)*ntrans_kpoint + spin_offset + & (iocc - 1)*nvirt_spin(ispin) + ivirt - homo_spin(ispin) gap = eigenvalues_kp(ivirt) - eigenvalues_kp(iocc) - IF (gap <= 0.0_dp) & + IF (gap <= 0.0_dp) THEN CPABORT("K-point TDDFPT requires positive occupied-virtual energy gaps") + END IF IF (use_scf_moment_dipoles) THEN oscillator_factor = SQRT(spin_factor*wkp(ikp)) dipole_re = REAL(kpoint_dipole(ispin, ikp, ideriv, iocc, ivirt), KIND=dp) @@ -1245,8 +1261,9 @@ CONTAINS END DO END DO - IF (ANY(transition_energy <= 0.0_dp)) & + IF (ANY(transition_energy <= 0.0_dp)) THEN CPABORT("K-point TDDFPT KERNEL NONE requires positive occupied-virtual energy gaps") + END IF CALL sort(transition_energy, ntrans_total, inds) nstates = MIN(tddfpt_control%nstates, ntrans_total) @@ -1971,7 +1988,7 @@ CONTAINS DO ispin = 1, nspins CPASSERT(.NOT. ASSOCIATED(gs_mos(ispin)%evals_occ_matrix)) END DO - ELSEIF (ewcut) THEN + ELSE IF (ewcut) THEN ! Filter orbitals wrt energy window DO ispin = 1, nspins DO i = 1, gs_mos(ispin)%nmo_occ diff --git a/src/qs_tddfpt2_properties.F b/src/qs_tddfpt2_properties.F index 0ea5e1abef..3f32e85a70 100644 --- a/src/qs_tddfpt2_properties.F +++ b/src/qs_tddfpt2_properties.F @@ -835,8 +835,9 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc - 1 /= para_env%mepos) & + IF (iproc - 1 /= para_env%mepos) THEN CALL recv_handlers(iproc)%wait() + END IF END DO ! compute total number of non-negligible excitations @@ -936,8 +937,9 @@ CONTAINS END IF ! deallocate temporary arrays - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN DEALLOCATE (weights_recv, weights_neg_abs_recv, inds_recv, inds) + END IF END DO DEALLOCATE (weights_local, inds_local) @@ -1525,7 +1527,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(a4,I3.3,I2.2,a11)') "NTO_STATE", istate, i, "_Hole_State" - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (filename, '(a4,I3.3,I2.2,a15)') "NTO_STATE", istate, i, "_Particle_State" END IF mpi_io = .TRUE. @@ -1534,7 +1536,7 @@ CONTAINS log_filename=.FALSE., ignore_should_output=.TRUE., mpi_io=mpi_io) IF (iset == 1) THEN WRITE (title, *) "Natural Transition Orbital Hole State", i - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/qs_tddfpt2_restart.F b/src/qs_tddfpt2_restart.F index 8ed2934237..4c2e0a02f5 100644 --- a/src/qs_tddfpt2_restart.F +++ b/src/qs_tddfpt2_restart.F @@ -294,8 +294,9 @@ CONTAINS END DO END DO - IF (para_env_global%is_source()) & + IF (para_env_global%is_source()) THEN CALL close_file(unit_number=iunit) + END IF CALL timestop(handle) @@ -634,11 +635,13 @@ CONTAINS sum_sign_array(icol_global) = sum_sign_array(icol_global) + sign_int IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) & + IF (minrow_pos_array(icol_global) > irow_global) THEN minrow_pos_array(icol_global) = irow_global + END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) & + IF (minrow_neg_array(icol_global) > irow_global) THEN minrow_neg_array(icol_global) = irow_global + END IF END IF END DO diff --git a/src/qs_tddfpt2_stda_types.F b/src/qs_tddfpt2_stda_types.F index 333da363e7..c175409e56 100644 --- a/src/qs_tddfpt2_stda_types.F +++ b/src/qs_tddfpt2_stda_types.F @@ -277,8 +277,9 @@ CONTAINS TYPE(stda_kind_type), POINTER :: kind_param - IF (ASSOCIATED(kind_param)) & + IF (ASSOCIATED(kind_param)) THEN CALL deallocate_stda_kind_param(kind_param) + END IF ALLOCATE (kind_param) diff --git a/src/qs_tddfpt2_stda_utils.F b/src/qs_tddfpt2_stda_utils.F index 68840bfd85..c98d3e93ef 100644 --- a/src/qs_tddfpt2_stda_utils.F +++ b/src/qs_tddfpt2_stda_utils.F @@ -252,7 +252,7 @@ CONTAINS IF (dr < 1.e-6) THEN ! on site terms gblock(:, :) = gblock(:, :) + eta - ELSEIF (dr > rcut) THEN + ELSE IF (dr > rcut) THEN ! do nothing ELSE IF (dr < rcut - rsmooth) THEN @@ -408,10 +408,11 @@ CONTAINS CALL cp_fm_struct_release(fmstruct=fmstruct) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) & + IF (ndep /= 0) THEN CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") + END IF CALL copy_fm_to_dbcsr(fm_s_half, sm_h) CALL cp_fm_release(fm_s_half) CALL cp_fm_release(fm_work1) diff --git a/src/qs_tddfpt2_subgroups.F b/src/qs_tddfpt2_subgroups.F index 009f80a27c..6097231eb9 100644 --- a/src/qs_tddfpt2_subgroups.F +++ b/src/qs_tddfpt2_subgroups.F @@ -302,8 +302,9 @@ CONTAINS NULLIFY (sub_env%task_list_orb_soft, sub_env%task_list_aux_fit_soft) IF (sub_env%is_mgrid) THEN - IF (tddfpt_control%mgrid_is_explicit) & + IF (tddfpt_control%mgrid_is_explicit) THEN CALL init_tddfpt_mgrid(qs_control, tddfpt_control, mgrid_saved) + END IF IF (ASSOCIATED(weights)) THEN CPABORT('Redefining MGRID and integration weights not compatible') @@ -344,8 +345,9 @@ CONTAINS END IF END IF - IF (tddfpt_control%mgrid_is_explicit) & + IF (tddfpt_control%mgrid_is_explicit) THEN CALL restore_qs_mgrid(qs_control, mgrid_saved) + END IF ELSE CALL pw_env_retain(pw_env_global) sub_env%pw_env => pw_env_global @@ -380,7 +382,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, sub_env%local_rho_set%rho0_mpole) CALL hartree_local_create(sub_env%hartree_local) CALL init_coulomb_local(sub_env%hartree_local, natom) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -448,17 +450,21 @@ CONTAINS CALL timeset(routineN, handle) IF (sub_env%is_mgrid) THEN - IF (ASSOCIATED(sub_env%task_list_aux_fit)) & + IF (ASSOCIATED(sub_env%task_list_aux_fit)) THEN CALL deallocate_task_list(sub_env%task_list_aux_fit) + END IF - IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) & + IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) THEN CALL deallocate_task_list(sub_env%task_list_aux_fit_soft) + END IF - IF (ASSOCIATED(sub_env%task_list_orb)) & + IF (ASSOCIATED(sub_env%task_list_orb)) THEN CALL deallocate_task_list(sub_env%task_list_orb) + END IF - IF (ASSOCIATED(sub_env%task_list_orb_soft)) & + IF (ASSOCIATED(sub_env%task_list_orb_soft)) THEN CALL deallocate_task_list(sub_env%task_list_orb_soft) + END IF CALL release_neighbor_list_sets(sub_env%sab_aux_fit) CALL release_neighbor_list_sets(sub_env%sab_orb) @@ -468,8 +474,9 @@ CONTAINS DEALLOCATE (sub_env%dbcsr_dist) END IF - IF (ASSOCIATED(sub_env%dist_2d)) & + IF (ASSOCIATED(sub_env%dist_2d)) THEN CALL distribution_2d_release(sub_env%dist_2d) + END IF END IF ! GAPW @@ -512,8 +519,9 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) & + IF (ALLOCATED(sub_env%group_distribution)) THEN DEALLOCATE (sub_env%group_distribution) + END IF sub_env%is_split = .FALSE. @@ -578,8 +586,9 @@ CONTAINS END DO ! igrid == 0 if qs_control%cutoff is larger than the largest manually provided cutoff value; ! use the largest actual value - IF (igrid <= 0) & + IF (igrid <= 0) THEN qs_control%cutoff = qs_control%e_cutoff(1) + END IF ELSE qs_control%e_cutoff(1) = qs_control%cutoff DO igrid = 2, ngrids @@ -607,8 +616,9 @@ CONTAINS CALL timeset(routineN, handle) - IF (ASSOCIATED(qs_control%e_cutoff)) & + IF (ASSOCIATED(qs_control%e_cutoff)) THEN DEALLOCATE (qs_control%e_cutoff) + END IF qs_control%commensurate_mgrids = mgrid_saved%commensurate_mgrids qs_control%realspace_mgrids = mgrid_saved%realspace_mgrids diff --git a/src/qs_tddfpt2_types.F b/src/qs_tddfpt2_types.F index 0a9790800e..19ea44ddac 100644 --- a/src/qs_tddfpt2_types.F +++ b/src/qs_tddfpt2_types.F @@ -465,7 +465,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, work_matrices%local_rho_set%rho0_mpole) CALL hartree_local_create(work_matrices%hartree_local) CALL init_coulomb_local(work_matrices%hartree_local, natom) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -939,8 +939,9 @@ CONTAINS CALL cp_fm_release(work_matrices%slambda) DEALLOCATE (work_matrices%slambda) END IF - IF (ASSOCIATED(work_matrices%S_eigenvalues)) & + IF (ASSOCIATED(work_matrices%S_eigenvalues)) THEN DEALLOCATE (work_matrices%S_eigenvalues) + END IF ! Ewald IF (ASSOCIATED(work_matrices%ewald_env)) THEN CALL ewald_env_release(work_matrices%ewald_env) diff --git a/src/qs_tddfpt2_utils.F b/src/qs_tddfpt2_utils.F index 4a98dbc280..814d6db052 100644 --- a/src/qs_tddfpt2_utils.F +++ b/src/qs_tddfpt2_utils.F @@ -297,12 +297,14 @@ CONTAINS CALL section_vals_val_get(print_section, "NAMD_PRINT%PRINT_PHASES", l_val=print_phases) nmo_virt = nao - nmo_occ - IF (nlumo >= 0) & + IF (nlumo >= 0) THEN nmo_virt = MIN(nmo_virt, nlumo) + END IF - IF (nmo_virt <= 0) & + IF (nmo_virt <= 0) THEN CALL cp_abort(__LOCATION__, & 'At least one unoccupied molecular orbital is required to calculate excited states.') + END IF do_eigen = .FALSE. ! diagonalise the Kohn-Sham matrix one more time if the number of available unoccupied states are too small @@ -426,11 +428,13 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) & + IF (minrow_pos_array(icol_global) > irow_global) THEN minrow_pos_array(icol_global) = irow_global + END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) & + IF (minrow_neg_array(icol_global) > irow_global) THEN minrow_neg_array(icol_global) = irow_global + END IF END IF END DO END DO @@ -508,11 +512,13 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) & + IF (minrow_pos_array(icol_global) > irow_global) THEN minrow_pos_array(icol_global) = irow_global + END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) & + IF (minrow_neg_array(icol_global) > irow_global) THEN minrow_neg_array(icol_global) = irow_global + END IF END IF END DO END DO @@ -570,20 +576,25 @@ CONTAINS CALL timeset(routineN, handle) - IF (ALLOCATED(gs_mos%phases_occ)) & + IF (ALLOCATED(gs_mos%phases_occ)) THEN DEALLOCATE (gs_mos%phases_occ) + END IF - IF (ALLOCATED(gs_mos%evals_virt)) & + IF (ALLOCATED(gs_mos%evals_virt)) THEN DEALLOCATE (gs_mos%evals_virt) + END IF - IF (ALLOCATED(gs_mos%evals_occ)) & + IF (ALLOCATED(gs_mos%evals_occ)) THEN DEALLOCATE (gs_mos%evals_occ) + END IF - IF (ALLOCATED(gs_mos%phases_virt)) & + IF (ALLOCATED(gs_mos%phases_virt)) THEN DEALLOCATE (gs_mos%phases_virt) + END IF - IF (ALLOCATED(gs_mos%index_active)) & + IF (ALLOCATED(gs_mos%index_active)) THEN DEALLOCATE (gs_mos%index_active) + END IF IF (ASSOCIATED(gs_mos%evals_occ_matrix)) THEN CALL cp_fm_release(gs_mos%evals_occ_matrix) @@ -686,9 +697,9 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT with SE not possible") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT with DFTB not possible") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., & ext_ks_matrix=matrix_ks_oep) @@ -1132,9 +1143,10 @@ CONTAINS DO istate = 1, nstates IF (ASSOCIATED(evects(1, istate)%matrix_struct)) THEN ! Initial guess vector read from restart file - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(T7,I8,T28,A19,T60,F14.5)') & - istate, "*** restarted ***", evals(istate)*evolt + istate, "*** restarted ***", evals(istate)*evolt + END IF ELSE ! New initial guess vector ! @@ -1166,9 +1178,10 @@ CONTAINS ! Assign initial guess for excitation energy evals(istate) = e_virt_minus_occ(istate) - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(T7,I8,T24,I8,T37,A5,T45,I8,T54,A5,T60,F14.5)') & - istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt + istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt + END IF DO jspin = 1, SIZE(evects, 1) ! .NOT. ASSOCIATED(evects(jspin, istate)%matrix_struct)) diff --git a/src/qs_tensors.F b/src/qs_tensors.F index ca92892f16..01298654b6 100644 --- a/src/qs_tensors.F +++ b/src/qs_tensors.F @@ -713,7 +713,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -722,7 +722,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1030,7 +1030,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1039,7 +1039,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1262,7 +1262,7 @@ CONTAINS IF (do_kpoints_prv) THEN prefac = 0.5_dp - ELSEIF (nl_3c%sym == symmetric_jk) THEN + ELSE IF (nl_3c%sym == symmetric_jk) THEN IF (jatom == katom) THEN prefac = 0.5_dp ELSE @@ -1548,7 +1548,7 @@ CONTAINS END DO END DO - ELSEIF (nl_3c%sym == symmetric_jk) THEN + ELSE IF (nl_3c%sym == symmetric_jk) THEN !Add the transpose of t3c_der_j to t3c_der_k to get the fully populated tensor CALL dbt_create(t3c_der_k(1, 1, 1), t3c_tmp) DO i_xyz = 1, 3 @@ -1567,7 +1567,7 @@ CONTAINS END DO CALL dbt_destroy(t3c_tmp) - ELSEIF (nl_3c%sym == symmetric_none) THEN + ELSE IF (nl_3c%sym == symmetric_none) THEN DO i_xyz = 1, 3 DO kcell = 1, ncell_RI DO jcell = 1, nimg @@ -1701,7 +1701,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1710,7 +1710,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2238,7 +2238,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2247,7 +2247,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2454,7 +2454,7 @@ CONTAINS ELSE prefac = 1.0_dp END IF - ELSEIF (nl_3c%sym == symmetric_ij) THEN + ELSE IF (nl_3c%sym == symmetric_ij) THEN IF (iatom == jatom) THEN ! factor 0.5 due to double-counting of diagonal blocks ! (we desymmetrize by adding transpose) @@ -2689,13 +2689,13 @@ CONTAINS END DO CALL dbt_destroy(t_3c_tmp) END IF - ELSEIF (nl_3c%sym == symmetric_ij) THEN + ELSE IF (nl_3c%sym == symmetric_ij) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps/2) END DO END DO - ELSEIF (nl_3c%sym == symmetric_none) THEN + ELSE IF (nl_3c%sym == symmetric_none) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps) diff --git a/src/qs_update_s_mstruct.F b/src/qs_update_s_mstruct.F index dd9017adf9..bee9f33d9e 100644 --- a/src/qs_update_s_mstruct.F +++ b/src/qs_update_s_mstruct.F @@ -227,8 +227,9 @@ CONTAINS IF (ASSOCIATED(qs_env%kg_env%subset)) THEN DO isub = 1, qs_env%kg_env%nsubsets - IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) & + IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) THEN CALL deallocate_task_list(qs_env%kg_env%subset(isub)%task_list) + END IF END DO ELSE ALLOCATE (qs_env%kg_env%subset(qs_env%kg_env%nsubsets)) diff --git a/src/qs_vcd_utils.F b/src/qs_vcd_utils.F index 379326e61d..75b0ff3b6c 100644 --- a/src/qs_vcd_utils.F +++ b/src/qs_vcd_utils.F @@ -153,8 +153,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "MAGNETIC_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) & + IF (reference == use_mom_ref_user) THEN CPABORT("User-defined reference point should be given explicitly") + END IF END IF CALL get_reference_point(rpoint=vcd_env%magnetic_origin, qs_env=qs_env, & @@ -167,8 +168,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "SPATIAL_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) & + IF (reference == use_mom_ref_user) THEN CPABORT("User-defined reference point should be given explicitly") + END IF END IF CALL get_reference_point(rpoint=vcd_env%spatial_origin, qs_env=qs_env, & @@ -824,9 +826,10 @@ CONTAINS + apt_total_nvpt(2, 2, l) & + apt_total_nvpt(3, 3, l))/3._dp DO i = 1, 3 - IF (vcd_env%output_unit > 0) & + IF (vcd_env%output_unit > 0) THEN WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", apt_total_nvpt(i, :, l) + "NVP | ", apt_total_nvpt(i, :, l) + END IF END DO END DO @@ -836,9 +839,10 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'NVP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) & + IF (vcd_env%output_unit > 0) THEN WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) + "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) + END IF END DO END DO @@ -849,9 +853,10 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'MFP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) & + IF (vcd_env%output_unit > 0) THEN WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "MFP | ", vcd_env%aat_atom_mfp(i, :, l) + "MFP | ", vcd_env%aat_atom_mfp(i, :, l) + END IF END DO END DO END IF diff --git a/src/qs_vxc.F b/src/qs_vxc.F index 924ff307d4..a3410e78ac 100644 --- a/src/qs_vxc.F +++ b/src/qs_vxc.F @@ -206,11 +206,13 @@ CONTAINS ! test if the real space density is available CPASSERT(ASSOCIATED(rho_struct)) - IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) & + IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) THEN CPABORT("nspins must be 1 or 2") + END IF mspin = SIZE(rho_struct_r) - IF (dft_control%nspins == 2 .AND. mspin == 1) & + IF (dft_control%nspins == 2 .AND. mspin == 1) THEN CPABORT("Spin count mismatch") + END IF ! there are some options related to SIC here. ! Normal DFT computes E(rho_alpha,rho_beta) (or its variant E(2*rho_alpha) for non-LSD) @@ -242,8 +244,9 @@ CONTAINS sic_scaling_b_zero = .FALSE. END IF - IF (PRESENT(pw_env_external)) & + IF (PRESENT(pw_env_external)) THEN pw_env => pw_env_external + END IF CALL pw_env_get(pw_env, xc_pw_pool=xc_pw_pool, auxbas_pw_pool=auxbas_pw_pool) uf_grid = .NOT. pw_grid_compare(auxbas_pw_pool%pw_grid, xc_pw_pool%pw_grid) @@ -759,7 +762,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_struct_g, rho_r, rho_g) - ELSEIF (ASSOCIATED(rho_struct_r)) THEN + ELSE IF (ASSOCIATED(rho_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_struct_r, rho_r, rho_g) ELSE CPABORT("Fine Grid in qs_xc_density requires rho_r or rho_g") @@ -767,7 +770,7 @@ CONTAINS IF (tau_r_valid) THEN IF (tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_struct_g, tau_r, tau_g) - ELSEIF (ASSOCIATED(tau_struct_r)) THEN + ELSE IF (ASSOCIATED(tau_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_struct_r, tau_r, tau_g) ELSE CPABORT("Fine Grid in qs_xc_density requires tau_r or tau_g") diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index 84b2bd4516..34110e06a9 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -996,7 +996,7 @@ CONTAINS lsd = .TRUE. scale_rho = .TRUE. END IF - ELSEIF (PRESENT(do_triplet)) THEN + ELSE IF (PRESENT(do_triplet)) THEN IF (nspins == 1 .AND. do_triplet) lsd = .TRUE. END IF diff --git a/src/qs_wannier90.F b/src/qs_wannier90.F index b2c7989282..33d326aeec 100644 --- a/src/qs_wannier90.F +++ b/src/qs_wannier90.F @@ -1232,7 +1232,7 @@ CONTAINS WRITE (reason, "(A,I0,A,ES9.2,A,I0,A,A32)") & "atom/AO W90 guarded: best/", num_candidates, "=", best_residual, & " k=", ik, " ", TRIM(best_reason) - ELSEIF (.NOT. ok .AND. num_candidates == 0) THEN + ELSE IF (.NOT. ok .AND. num_candidates == 0) THEN reason = "no matching SCF symmetry operation candidate" END IF ELSE @@ -1262,7 +1262,7 @@ CONTAINS reason, source_window_min_svalue, & candidate_residual) END IF - ELSEIF (.NOT. ok) THEN + ELSE IF (.NOT. ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real, dst_imag, dst_real, dst_imag, & matrix_s, matrix_ks, kpoint%xkp(1:3, ik), & cell_to_index, sab_nl, ispin, & @@ -1752,7 +1752,7 @@ CONTAINS END IF END IF END IF - ELSEIF (ASSOCIATED(qs_kpoint%kp_sym)) THEN + ELSE IF (ASSOCIATED(qs_kpoint%kp_sym)) THEN kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym IF (ASSOCIATED(kpsym)) THEN DO isym_try = 1, kpsym%nwred diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index af061e3cea..e70607cffd 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -761,8 +761,9 @@ CONTAINS END IF END SELECT - IF (PRESENT(extrapolation_method_nr)) & + IF (PRESENT(extrapolation_method_nr)) THEN extrapolation_method_nr = actual_extrapolation_method_nr + END IF my_orthogonal_wf = .FALSE. SELECT CASE (actual_extrapolation_method_nr) @@ -2305,8 +2306,9 @@ CONTAINS wfi_linear_ps_method_nr, wfi_ps_method_nr, & wfi_aspc_nr, wfi_gext_proj_nr, wfi_gext_proj_qtr_nr) IF (qs_env%wf_history%snapshot_count >= 2) THEN - IF (debug_this_module .AND. io_unit > 0) & + IF (debug_this_module .AND. io_unit > 0) THEN WRITE (io_unit, FMT="(T2,A)") "QS| Purging WFN history" + END IF CALL wfi_create(wf_history, interpolation_method_nr= & dft_control%qs_control%wf_interpolation_method_nr, & extrapolation_order=dft_control%qs_control%wf_extrapolation_order, & diff --git a/src/replica_methods.F b/src/replica_methods.F index 0fd4b3b08c..b8a1de1b67 100644 --- a/src/replica_methods.F +++ b/src/replica_methods.F @@ -295,8 +295,9 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) & + IF (.NOT. ASSOCIATED(rep_env)) THEN CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) + END IF NULLIFY (qs_env, dft_control, subsys) CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() diff --git a/src/replica_types.F b/src/replica_types.F index 646349fcae..41f96a58b2 100644 --- a/src/replica_types.F +++ b/src/replica_types.F @@ -206,8 +206,9 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) & + IF (.NOT. ASSOCIATED(rep_env)) THEN CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) + END IF CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() CALL cp_rm_iter_level(iteration_info=logger%iter_info, & diff --git a/src/response_solver.F b/src/response_solver.F index 9985ca3402..8409bc3eaa 100644 --- a/src/response_solver.F +++ b/src/response_solver.F @@ -1244,7 +1244,7 @@ CONTAINS CALL pw_zero(vhxc_rspace) IF (gapw) THEN CALL pw_transfer(v_hartree_rspace_gs, vhxc_rspace) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL pw_transfer(vh_rspace, vhxc_rspace) END IF CALL integrate_v_rspace(v_rspace=vhxc_rspace, & @@ -1795,7 +1795,7 @@ CONTAINS CALL pw_zero(v_xc(ispin)) IF (gapw) THEN ! Hartree potential of response density CALL pw_axpy(v_hartree_rspace_t, v_xc(ispin)) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL pw_axpy(zv_hartree_rspace, v_xc(ispin)) END IF CALL integrate_v_rspace(qs_env=qs_env, & diff --git a/src/restraint.F b/src/restraint.F index 4b2d6d7738..53c602452a 100644 --- a/src/restraint.F +++ b/src/restraint.F @@ -442,9 +442,9 @@ CONTAINS r0_13(:) = particle_set(index_a)%r - particle_set(index_c)%r r0_23(:) = particle_set(index_b)%r - particle_set(index_c)%r - rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) - rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) - rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) + rab = NORM2(r0_12) + rac = NORM2(r0_13) + rbc = NORM2(r0_23) tab = rab - g3x3_list(ng3x3)%dab tac = rac - g3x3_list(ng3x3)%dac tbc = rbc - g3x3_list(ng3x3)%dbc @@ -508,12 +508,12 @@ CONTAINS r0_24(:) = particle_set(index_b)%r - particle_set(index_d)%r r0_34(:) = particle_set(index_c)%r - particle_set(index_d)%r - rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) - rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) - rad = SQRT(DOT_PRODUCT(r0_14, r0_14)) - rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) - rbd = SQRT(DOT_PRODUCT(r0_24, r0_24)) - rcd = SQRT(DOT_PRODUCT(r0_34, r0_34)) + rab = NORM2(r0_12) + rac = NORM2(r0_13) + rad = NORM2(r0_14) + rbc = NORM2(r0_23) + rbd = NORM2(r0_24) + rcd = NORM2(r0_34) tab = rab - g4x6_list(ng4x6)%dab tac = rac - g4x6_list(ng4x6)%dac diff --git a/src/rpa_grad.F b/src/rpa_grad.F index a24334cf14..2ea5e679e9 100644 --- a/src/rpa_grad.F +++ b/src/rpa_grad.F @@ -1054,8 +1054,9 @@ CONTAINS mem_per_block = REAL(number_of_elements_per_blk, KIND=dp)*8.0_dp number_of_parallel_channels = MAX(1, MIN(MAXVAL(grid) - 1, FLOOR(mem_real/mem_per_block))) CALL para_env%min(number_of_parallel_channels) - IF (mp2_env%ri_grad%max_parallel_comm > 0) & + IF (mp2_env%ri_grad%max_parallel_comm > 0) THEN number_of_parallel_channels = MIN(number_of_parallel_channels, mp2_env%ri_grad%max_parallel_comm) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,T75,I6)') 'GRAD_INFO| Number of parallel communication channels:', number_of_parallel_channels @@ -1671,11 +1672,13 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) & + IF (ALLOCATED(index2send(pcol_send)%array)) THEN size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) + END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) & + IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) + END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -1829,11 +1832,13 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) & + IF (ALLOCATED(index2send(pcol_send)%array)) THEN size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) + END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) & + IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) + END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -2273,14 +2278,18 @@ CONTAINS DO ispin = 1, nspins DO pcol = 0, SIZE(sos_mp2_work_occ(ispin)%index2send, 1) - 1 - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & + END IF + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & + END IF + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & + END IF + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) + END IF END DO DEALLOCATE (sos_mp2_work_occ(ispin)%index2send, & sos_mp2_work_occ(ispin)%index2recv, & @@ -2309,7 +2318,8 @@ CONTAINS mp2_env%ri_grad%P_ij(ispin)%array(:, :) = 0.5_dp*(mp2_env%ri_grad%P_ij(ispin)%array + & TRANSPOSE(mp2_env%ri_grad%P_ij(ispin)%array)) - ! The first index of P_ab has to be distributed within the subgroups, so sum it up first and add the required elements later + ! The first index of P_ab has to be distributed within the subgroups, + ! so sum it up first and add the required elements later CALL para_env%sum(sos_mp2_work_virt(ispin)%P) itmp = get_limit(virtual(ispin), para_env_sub%num_pe, para_env_sub%mepos) diff --git a/src/rpa_gw_kpoints_util.F b/src/rpa_gw_kpoints_util.F index 460a46aaa6..00699efc4f 100644 --- a/src/rpa_gw_kpoints_util.F +++ b/src/rpa_gw_kpoints_util.F @@ -1315,8 +1315,9 @@ CONTAINS ELSE IF (kpoint_weights_W_method == kp_weights_W_tailored .OR. & kpoint_weights_W_method == kp_weights_W_auto) THEN - IF (kpoint_weights_W_method == kp_weights_W_tailored) & + IF (kpoint_weights_W_method == kp_weights_W_tailored) THEN exp_kpoints = qs_env%mp2_env%ri_rpa_im_time%exp_tailored_weights + END IF IF (kpoint_weights_W_method == kp_weights_W_auto) THEN IF (SUM(periodic) == 2) exp_kpoints = -1.0_dp diff --git a/src/rpa_im_time.F b/src/rpa_im_time.F index 5c1054cbb8..8081575ae5 100644 --- a/src/rpa_im_time.F +++ b/src/rpa_im_time.F @@ -477,8 +477,9 @@ CONTAINS first_cycle_im_time = .FALSE. - IF (jquad == 1 .AND. flops_2 == 0) & + IF (jquad == 1 .AND. flops_2 == 0) THEN has_mat_P_blocks(i_cell_T, i_mem, j_mem, i_cell_R_1, i_cell_R_2) = .FALSE. + END IF END DO END DO diff --git a/src/rpa_main.F b/src/rpa_main.F index 294525cce1..c005965d59 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -330,18 +330,20 @@ CONTAINS input_num_integ_groups = mp2_env%ri_rpa%rpa_num_integ_groups IF (my_do_gw .AND. do_minimax_quad) THEN IF (num_integ_points > 34) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 30.") + END IF num_integ_points = 30 END IF ELSE IF (do_minimax_quad .AND. num_integ_points > 20) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 20.") + END IF num_integ_points = 20 END IF END IF @@ -973,8 +975,9 @@ CONTAINS CALL cp_fm_struct_release(fm_struct) - IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) & + IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) THEN CALL cp_blacs_env_release(blacs_env_Q) + END IF END IF ! release blacs_env @@ -1333,9 +1336,10 @@ CONTAINS IF (calc_forces .AND. .NOT. do_im_time) CALL rpa_grad_create(rpa_grad, fm_mat_Q(1), & fm_mat_S, homo, virtual, mp2_env, Eigenval(:, 1, :), & unit_nr, do_ri_sos_laplace_mp2) - IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) & + IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) THEN CALL exchange_work%create(qs_env, para_env_sub, mat_munu, dimen_RI_red, & fm_mat_S, fm_mat_Q(1), fm_mat_Q_gemm(1), homo, virtual) + END IF Erpa = 0.0_dp IF (mp2_env%ri_rpa%exchange_correction /= rpa_exchange_none) e_exchange = 0.0_dp first_cycle = .TRUE. diff --git a/src/rt_propagation_forces.F b/src/rt_propagation_forces.F index bb9d1ac65c..5d8ffc1854 100644 --- a/src/rt_propagation_forces.F +++ b/src/rt_propagation_forces.F @@ -122,16 +122,18 @@ CONTAINS IF (rtp%linear_scaling) THEN CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_new(re)%matrix, zero, tmp, & filter_eps=rtp%filter_eps) - IF (rtp%propagate_complex_ks) & + IF (rtp%propagate_complex_ks) THEN CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) + END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) CALL compute_forces(force, tmp, S_der, rho_new(im)%matrix, C_mat, kind_of, atom_of_kind) ELSE CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_ao(ispin)%matrix, zero, tmp) - IF (rtp%propagate_complex_ks) & + IF (rtp%propagate_complex_ks) THEN CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) + END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) CALL compute_forces(force, tmp, S_der, rho_ao_im(ispin)%matrix, C_mat, kind_of, atom_of_kind) END IF diff --git a/src/rt_propagation_types.F b/src/rt_propagation_types.F index ec1e3f4823..416906664d 100644 --- a/src/rt_propagation_types.F +++ b/src/rt_propagation_types.F @@ -476,12 +476,15 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(rtp%H_last_iter) CALL dbcsr_deallocate_matrix_set(rtp%propagator_matrix) IF (ASSOCIATED(rtp%rho)) THEN - IF (ASSOCIATED(rtp%rho%old)) & + IF (ASSOCIATED(rtp%rho%old)) THEN CALL dbcsr_deallocate_matrix_set(rtp%rho%old) - IF (ASSOCIATED(rtp%rho%next)) & + END IF + IF (ASSOCIATED(rtp%rho%next)) THEN CALL dbcsr_deallocate_matrix_set(rtp%rho%next) - IF (ASSOCIATED(rtp%rho%new)) & + END IF + IF (ASSOCIATED(rtp%rho%new)) THEN CALL dbcsr_deallocate_matrix_set(rtp%rho%new) + END IF DEALLOCATE (rtp%rho) END IF @@ -490,20 +493,27 @@ CONTAINS CALL dbcsr_deallocate_matrix(rtp%S_inv) CALL dbcsr_deallocate_matrix(rtp%S_half) CALL dbcsr_deallocate_matrix(rtp%S_minus_half) - IF (ASSOCIATED(rtp%B_mat)) & + IF (ASSOCIATED(rtp%B_mat)) THEN CALL dbcsr_deallocate_matrix(rtp%B_mat) - IF (ASSOCIATED(rtp%C_mat)) & + END IF + IF (ASSOCIATED(rtp%C_mat)) THEN CALL dbcsr_deallocate_matrix_set(rtp%C_mat) - IF (ASSOCIATED(rtp%S_der)) & + END IF + IF (ASSOCIATED(rtp%S_der)) THEN CALL dbcsr_deallocate_matrix_set(rtp%S_der) - IF (ASSOCIATED(rtp%SinvH)) & + END IF + IF (ASSOCIATED(rtp%SinvH)) THEN CALL dbcsr_deallocate_matrix_set(rtp%SinvH) - IF (ASSOCIATED(rtp%SinvH_imag)) & + END IF + IF (ASSOCIATED(rtp%SinvH_imag)) THEN CALL dbcsr_deallocate_matrix_set(rtp%SinvH_imag) - IF (ASSOCIATED(rtp%SinvB)) & + END IF + IF (ASSOCIATED(rtp%SinvB)) THEN CALL dbcsr_deallocate_matrix_set(rtp%SinvB) - IF (ASSOCIATED(rtp%history)) & + END IF + IF (ASSOCIATED(rtp%history)) THEN CALL rtp_history_release(rtp) + END IF DEALLOCATE (rtp%orders) END SUBROUTINE rt_prop_release @@ -515,14 +525,18 @@ CONTAINS TYPE(rt_prop_type), INTENT(inout) :: rtp IF (ASSOCIATED(rtp%mos)) THEN - IF (ASSOCIATED(rtp%mos%old)) & + IF (ASSOCIATED(rtp%mos%old)) THEN CALL cp_fm_release(rtp%mos%old) - IF (ASSOCIATED(rtp%mos%new)) & + END IF + IF (ASSOCIATED(rtp%mos%new)) THEN CALL cp_fm_release(rtp%mos%new) - IF (ASSOCIATED(rtp%mos%next)) & + END IF + IF (ASSOCIATED(rtp%mos%next)) THEN CALL cp_fm_release(rtp%mos%next) - IF (ASSOCIATED(rtp%mos%admm)) & + END IF + IF (ASSOCIATED(rtp%mos%admm)) THEN CALL cp_fm_release(rtp%mos%admm) + END IF CALL cp_fm_struct_release(rtp%ao_ao_fmstruct) DEALLOCATE (rtp%mos) END IF @@ -593,8 +607,9 @@ CONTAINS IF (ASSOCIATED(rtp%history%s_history)) THEN DO i = 1, SIZE(rtp%history%s_history) - IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) & + IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) THEN CALL dbcsr_deallocate_matrix(rtp%history%s_history(i)%matrix) + END IF END DO DEALLOCATE (rtp%history%s_history) END IF diff --git a/src/rt_propagation_velocity_gauge.F b/src/rt_propagation_velocity_gauge.F index ee205d1999..9ad2819d5c 100644 --- a/src/rt_propagation_velocity_gauge.F +++ b/src/rt_propagation_velocity_gauge.F @@ -1090,48 +1090,58 @@ CONTAINS na = SIZE(acint_cos, 1) np = SIZE(acint_cos, 2) nb = SIZE(bcint_cos, 1) - ! Re(dV_ab/dRA) = + + + - ! Im(dV_ab/dRA) = - - + + ! Re(dV_ab/dRA) = + + ! + + + ! Im(dV_ab/dRA) = - + ! - + katom = alist_cos_ac%clist(kac)%catom DO idir = 1, 3 IF (iatom <= jatom) THEN ! For fa: - IF (found_real) & + IF (found_real) THEN fa(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & + MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (+MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & - MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) + END IF ! For fb: - IF (found_real) & + IF (found_real) THEN fb(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (-MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))))) + END IF ELSE ! For fa: - IF (found_real) & + IF (found_real) THEN fa(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & + MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (+MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & - MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) + END IF ! For fb - IF (found_real) & + IF (found_real) THEN fb(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (-MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))))) + END IF END IF force_thread(idir, iatom) = force_thread(idir, iatom) + f0*fa(idir) force_thread(idir, katom) = force_thread(idir, katom) - f0*fa(idir) diff --git a/src/scf_control_types.F b/src/scf_control_types.F index 527bb5e81f..623af5359f 100644 --- a/src/scf_control_types.F +++ b/src/scf_control_types.F @@ -302,8 +302,9 @@ CONTAINS END IF DEALLOCATE (scf_control%smear) - IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) & + IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) THEN CALL cdft_opt_type_release(scf_control%outer_scf%cdft_opt_control) + END IF IF (ASSOCIATED(scf_control%gce)) THEN DEALLOCATE (scf_control%gce) @@ -353,7 +354,7 @@ CONTAINS IF (scf_control%use_diag .AND. scf_control%use_ot) THEN ! don't allow both options to be true CPABORT("Don't activate OT and Diagonaliztion together") - ELSEIF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN + ELSE IF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN ! set default to diagonalization scf_control%use_diag = .TRUE. END IF @@ -699,9 +700,10 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T25,A,T71,ES10.2)") & "Smearing width (sigma) [a.u.]:", scf_control%smear%smearing_width, & "Accuracy threshold:", scf_control%smear%eps_fermi_dirac - IF (scf_control%smear%fixed_mag_mom > 0.0_dp) & + IF (scf_control%smear%fixed_mag_mom > 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T25,A,T61,F20.1)") & - "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom + "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom + END IF CASE (smear_energy_window) WRITE (UNIT=output_unit, FMT="(T25,A,T71,F10.6)") & "Smear window [a.u.]: ", scf_control%smear%window_size diff --git a/src/scine_utils.F b/src/scine_utils.F index 208d4b2f0b..8bd0ee64ca 100644 --- a/src/scine_utils.F +++ b/src/scine_utils.F @@ -117,15 +117,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSEIF (nc == j + 4) THEN + ELSE IF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 3) THEN + ELSE IF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 2) THEN + ELSE IF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 1) THEN + ELSE IF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j) THEN + ELSE IF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -134,15 +134,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSEIF (nc == j + 4) THEN + ELSE IF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 3) THEN + ELSE IF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 2) THEN + ELSE IF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 1) THEN + ELSE IF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j) THEN + ELSE IF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -151,15 +151,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSEIF (nc == j + 4) THEN + ELSE IF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 3) THEN + ELSE IF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 2) THEN + ELSE IF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 1) THEN + ELSE IF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j) THEN + ELSE IF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO diff --git a/src/se_core_matrix.F b/src/se_core_matrix.F index 2c53f7ca31..10bda9bd4e 100644 --- a/src/se_core_matrix.F +++ b/src/se_core_matrix.F @@ -281,24 +281,6 @@ CONTAINS ! two-centre one-electron term NULLIFY (s_block) -! CALL dbcsr_get_block_p(matrix_s(1)%matrix,& -! irow,icol,s_block,found) -! CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) -! -! if( irow == iatom )then -! R= -rij -! call makeS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,S) -! else -! R= rij -! call makeS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,S) -! endif -! -! do i=1,4 -! do j=1,4 -! s_block(i,j)=S(ix(i),ix(j)) -! enddo -! enddo - CALL dbcsr_get_block_p(matrix_s(1)%matrix, & irow, icol, s_block, found) CPASSERT(ASSOCIATED(s_block)) @@ -319,28 +301,11 @@ CONTAINS atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) -! if( irow == iatom )then -! R= -rij -! call makedS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,dS) -! else -! R= rij -! call makedS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,dS) -! endif - CALL dbcsr_get_block_p(matrix_p(1)%matrix, irow, icol, pabmat, found) CPASSERT(ASSOCIATED(pabmat)) DO icor = 1, 3 force_ab(icor) = 0._dp -! CALL dbcsr_get_block_p(matrix_s(icor+1)%matrix,irow,icol,dsmat,found) -! CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,failure) -! -! do i=1,4 -! do j=1,4 -! dsmat(i,j)=dS(ix(i),ix(j),icor) -! enddo -! enddo - CALL dbcsr_get_block_p(matrix_s(icor + 1)%matrix, irow, icol, dsmat, found) CPASSERT(ASSOCIATED(dsmat)) dsmat = 2._dp*kh*dsmat*pabmat @@ -628,7 +593,7 @@ CONTAINS S(:, :) = 0.0_dp v(:) = R(:) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) IF (rr < 1.0e-20_dp) THEN @@ -1006,7 +971,7 @@ CONTAINS dS(:, :, :) = 0.0_dp v(:) = R(:) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) IF (rr < 1.0e-20_dp) THEN diff --git a/src/semi_empirical_int_ana.F b/src/semi_empirical_int_ana.F index d9e33d563a..3698bf1625 100644 --- a/src/semi_empirical_int_ana.F +++ b/src/semi_empirical_int_ana.F @@ -548,7 +548,7 @@ CONTAINS (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2)*(-2.0_dp*apdg*(rij - dbi - daj)) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2)*(-2.0_dp*apdg*(rij - dbi - dbj)) END IF - ELSEIF (itype == do_method_pchg) THEN + ELSE IF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp dscale = 0.0_dp @@ -571,15 +571,15 @@ CONTAINS IF (l_denuc) dscale = dscale*(2._dp*xab*EXP(-aab*rija*rija)) - & scale*2._dp*xab*EXP(-aab*rija*rija)*(2.0_dp*aab*rija)*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) & - scale*2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6))*aab*(1.0_dp + 6.0_dp*0.0003_dp*rija**5)*drija & - scale*9.28_dp*EXP(-5.98_dp*rija)*5.98_dp*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) & @@ -1578,8 +1578,7 @@ CONTAINS ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN se_int_screen%ft = taper_eval(se_taper%taper_add, rij) - IF (lgrad) & - se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) + IF (lgrad) se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF ! Integral Values for sp shells only diff --git a/src/semi_empirical_int_debug.F b/src/semi_empirical_int_debug.F index 2a77ae1016..466d99a3c7 100644 --- a/src/semi_empirical_int_debug.F +++ b/src/semi_empirical_int_debug.F @@ -71,7 +71,7 @@ SUBROUTINE check_rotmat_der(sepi, sepj, rjiv, ij_matrix, do_invert) IF (i == 1) matrix => matrix_p IF (i == 2) matrix => matrix_m r0 = rjiv + (-1.0_dp)**(i - 1)*x - r = SQRT(DOT_PRODUCT(r0, r0)) + r = NORM2(r0) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=do_invert) END DO ! SP @@ -218,7 +218,7 @@ SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, in x(imap(j)) = dx DO i = 1, 2 r0 = rijv + (-1.0_dp)**(i - 1)*x - r = SQRT(DOT_PRODUCT(r0, r0)) + r = NORM2(r0) CALL rotmat_create(matrix) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=invert) diff --git a/src/semi_empirical_int_gks.F b/src/semi_empirical_int_gks.F index f285735404..b6da8aa20d 100644 --- a/src/semi_empirical_int_gks.F +++ b/src/semi_empirical_int_gks.F @@ -270,7 +270,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -373,7 +373,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -590,7 +590,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) r1 = 1.0_dp/rr r2 = r1*r1 @@ -807,7 +807,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) diff --git a/src/semi_empirical_int_num.F b/src/semi_empirical_int_num.F index a541863a75..a5cbd768c6 100644 --- a/src/semi_empirical_int_num.F +++ b/src/semi_empirical_int_num.F @@ -619,7 +619,7 @@ CONTAINS (zaf*pai + zbf*pbj)*EXP(-apdg*(rij - dai - dbj)**2) + & (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2) - ELSEIF (itype == do_method_pchg) THEN + ELSE IF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp ELSE @@ -635,11 +635,11 @@ CONTAINS (sepj%z == 1 .AND. (sepi%z == 6 .OR. sepi%z == 7 .OR. sepi%z == 8))) THEN ! Special Case O-H or N-H or C-H scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) ELSE diff --git a/src/semi_empirical_par_utils.F b/src/semi_empirical_par_utils.F index 4ca22c5713..ec1302790b 100644 --- a/src/semi_empirical_par_utils.F +++ b/src/semi_empirical_par_utils.F @@ -261,16 +261,16 @@ CONTAINS ELSE IF (l == 0) THEN n = nqs(sep%z) - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN ! Special case for Hydrogen.. If requested allow p-orbitals on it.. IF ((sep%z == 1) .AND. sep%p_orbitals_on_h) THEN n = 1 ELSE n = nqp(sep%z) END IF - ELSEIF (l == 2) THEN + ELSE IF (l == 2) THEN n = nqd(sep%z) - ELSEIF (l == 3) THEN + ELSE IF (l == 3) THEN n = nqf(sep%z) ELSE CPABORT("Invalid l quantum number !") @@ -535,24 +535,27 @@ CONTAINS z1 = sep%sto_exponents(0) z2 = sep%sto_exponents(1) z3 = sep%sto_exponents(2) - IF (z1 <= 0.0_dp) & + IF (z1 <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Trying to use s-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of s orbitals! ") + END IF amn = 0.0_dp nsp = nqs(sep%z) IF (sep%natorb >= 4) THEN - IF (z2 <= 0.0_dp) & + IF (z2 <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Trying to use p-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of p orbitals! ") + END IF amn(2) = amn_l_low(z1, z2, nsp, nsp, 1) amn(3) = amn_l_low(z2, z2, nsp, nsp, 2) IF (sep%dorb) THEN - IF (z3 <= 0.0_dp) & + IF (z3 <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Trying to use d-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of d orbitals! ") + END IF nd = nqd(sep%z) amn(4) = amn_l_low(z1, z3, nsp, nd, 2) amn(5) = amn_l_low(z2, z3, nsp, nd, 1) diff --git a/src/semi_empirical_store_int_types.F b/src/semi_empirical_store_int_types.F index f00537c0de..f878234b19 100644 --- a/src/semi_empirical_store_int_types.F +++ b/src/semi_empirical_store_int_types.F @@ -97,8 +97,9 @@ CONTAINS END IF ! Disk Storage disabled for semi-empirical methods - IF (store_int_env%memory_parameter%do_disk_storage) & + IF (store_int_env%memory_parameter%do_disk_storage) THEN CPABORT("Disk storage for SEMIEMPIRICAL methods disabled! ") + END IF ! Allocate containers/caches for integral storage if requested IF (.NOT. store_int_env%memory_parameter%do_all_on_the_fly .AND. store_int_env%compress) THEN diff --git a/src/semi_empirical_types.F b/src/semi_empirical_types.F index 806e85c01c..9157e5f5db 100644 --- a/src/semi_empirical_types.F +++ b/src/semi_empirical_types.F @@ -833,7 +833,7 @@ CONTAINS ADJUSTR("ACOUL"), "- "//" Slater parameter: ", sep%acoul WRITE (UNIT=output_unit, FMT="(T16,A11,T30,A,T69,I12)") & ADJUSTR("NR"), "- "//" Slater parameter: ", sep%nr - ELSEIF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN + ELSE IF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN ! Standard case DO i = 1, SIZE(sep%bfn1, 1) i_string = cp_to_string(i) diff --git a/src/semi_empirical_utils.F b/src/semi_empirical_utils.F index 5c9911931f..4cc9b5e0a9 100644 --- a/src/semi_empirical_utils.F +++ b/src/semi_empirical_utils.F @@ -305,10 +305,11 @@ CONTAINS END IF ! Check if the element has been defined.. - IF (.NOT. sep%defined) & + IF (.NOT. sep%defined) THEN CALL cp_abort(__LOCATION__, & "Semiempirical type ("//TRIM(sep%name)//") cannot be defined for "// & "the requested parameterization.") + END IF ! Fill 1 center - 2 electron integrals CALL setup_1c_2el_int(sep) diff --git a/src/shg_int/construct_shg.F b/src/shg_int/construct_shg.F index b63da9c9c1..9de93b969d 100644 --- a/src/shg_int/construct_shg.F +++ b/src/shg_int/construct_shg.F @@ -377,7 +377,8 @@ CONTAINS IF (ma - 1 >= 0) THEN Wamm(0:lamb, 1) = Waux_mat(1:lamb + 1, ipam - 1, ipb) IF (mb > 0) Wamm(0:lamb, 2) = Waux_mat(1:lamb + 1, ipam - 1, imb) - IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) !order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 + ! order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 + IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) IF (ma - 1 > 0 .AND. mb > 0) Wamm(0:lamb, 4) = Waux_mat(1:lamb + 1, imam + 1, imb) END IF !*** Wamp: la-1, ma+1 diff --git a/src/sirius_interface.F b/src/sirius_interface.F index c278a27ee1..9b94f8290b 100644 --- a/src/sirius_interface.F +++ b/src/sirius_interface.F @@ -327,7 +327,7 @@ CONTAINS symbol=element_symbol, & mass=REAL(mass/massunit, KIND=C_DOUBLE)) - ELSEIF (ASSOCIATED(gth_potential)) THEN + ELSE IF (ASSOCIATED(gth_potential)) THEN ! NULLIFY (atom_grid) CALL allocate_grid_atom(atom_grid) diff --git a/src/skala_gpw_features.F b/src/skala_gpw_features.F index 14a0b088a5..f791c73354 100644 --- a/src/skala_gpw_features.F +++ b/src/skala_gpw_features.F @@ -225,8 +225,9 @@ CONTAINS my_requires_grad = .FALSE. IF (PRESENT(requires_grad)) my_requires_grad = requires_grad my_requires_coordinate_grad = .FALSE. - IF (PRESENT(requires_coordinate_grad)) & + IF (PRESENT(requires_coordinate_grad)) THEN my_requires_coordinate_grad = requires_coordinate_grad + END IF my_requires_stress_grad = .FALSE. IF (PRESENT(requires_stress_grad)) my_requires_stress_grad = requires_stress_grad my_use_atom_chunks = .FALSE. @@ -595,8 +596,9 @@ CONTAINS END IF max_local_features = nflat_local - IF (my_atom_partition == skala_gpw_atom_partition_smooth) & + IF (my_atom_partition == skala_gpw_atom_partition_smooth) THEN max_local_features = nflat_local*natom + END IF ALLOCATE (local_owner(max_local_features), & local_source_points(max_local_features), & local_static(nstatic_per_point*max_local_features), & @@ -779,8 +781,9 @@ CONTAINS atom_position(owner) = atom_position(owner) + 1 source_global = global_source_points(ipt) cached_layout%feature_source_points(row) = source_global - IF (cached_layout%global_to_feature(source_global) == 0) & + IF (cached_layout%global_to_feature(source_global) == 0) THEN cached_layout%global_to_feature(source_global) = row + END IF static_base = nstatic_per_point*(ipt - 1) cached_layout%grid_coords(:, row) = global_static(static_base + 1:static_base + 3) cached_layout%grid_weights(row) = global_static(static_base + 4) @@ -1458,14 +1461,18 @@ CONTAINS IF (ALLOCATED(cache%chunk_feature_displs)) DEALLOCATE (cache%chunk_feature_displs) IF (ALLOCATED(cache%chunk_grad_counts)) DEALLOCATE (cache%chunk_grad_counts) IF (ALLOCATED(cache%chunk_grad_displs)) DEALLOCATE (cache%chunk_grad_displs) - IF (ALLOCATED(cache%route_grad_return_recv_counts)) & + IF (ALLOCATED(cache%route_grad_return_recv_counts)) THEN DEALLOCATE (cache%route_grad_return_recv_counts) - IF (ALLOCATED(cache%route_grad_return_recv_displs)) & + END IF + IF (ALLOCATED(cache%route_grad_return_recv_displs)) THEN DEALLOCATE (cache%route_grad_return_recv_displs) - IF (ALLOCATED(cache%route_grad_return_send_counts)) & + END IF + IF (ALLOCATED(cache%route_grad_return_send_counts)) THEN DEALLOCATE (cache%route_grad_return_send_counts) - IF (ALLOCATED(cache%route_grad_return_send_displs)) & + END IF + IF (ALLOCATED(cache%route_grad_return_send_displs)) THEN DEALLOCATE (cache%route_grad_return_send_displs) + END IF IF (ALLOCATED(cache%route_local_dest)) DEALLOCATE (cache%route_local_dest) IF (ALLOCATED(cache%chunk_return_positions)) DEALLOCATE (cache%chunk_return_positions) IF (ALLOCATED(cache%route_point_recv_counts)) DEALLOCATE (cache%route_point_recv_counts) @@ -1488,17 +1495,20 @@ CONTAINS IF (ALLOCATED(cache%local_feature_offsets)) DEALLOCATE (cache%local_feature_offsets) IF (ALLOCATED(cache%local_feature_points)) DEALLOCATE (cache%local_feature_points) IF (ALLOCATED(cache%local_feature_rows)) DEALLOCATE (cache%local_feature_rows) - IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) & + IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) THEN DEALLOCATE (cache%atomic_grid_size_bound_shape) - IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) & + END IF + IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) THEN DEALLOCATE (cache%chunk_atomic_grid_size_bound_shape) + END IF IF (ALLOCATED(cache%atomic_grid_weights)) DEALLOCATE (cache%atomic_grid_weights) IF (ALLOCATED(cache%chunk_atomic_grid_weights)) DEALLOCATE (cache%chunk_atomic_grid_weights) IF (ALLOCATED(cache%chunk_grid_weights)) DEALLOCATE (cache%chunk_grid_weights) IF (ALLOCATED(cache%grid_weights)) DEALLOCATE (cache%grid_weights) IF (ALLOCATED(cache%atom_coords)) DEALLOCATE (cache%atom_coords) - IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) & + IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) THEN DEALLOCATE (cache%chunk_coarse_0_atomic_coords) + END IF IF (ALLOCATED(cache%coarse_0_atomic_coords)) DEALLOCATE (cache%coarse_0_atomic_coords) IF (ALLOCATED(cache%chunk_grid_coords)) DEALLOCATE (cache%chunk_grid_coords) IF (ALLOCATED(cache%grid_coords)) DEALLOCATE (cache%grid_coords) @@ -1592,22 +1602,30 @@ CONTAINS IF (ALLOCATED(features%chunk_grad_counts)) DEALLOCATE (features%chunk_grad_counts) IF (ALLOCATED(features%chunk_grad_displs)) DEALLOCATE (features%chunk_grad_displs) IF (ALLOCATED(features%chunk_return_positions)) DEALLOCATE (features%chunk_return_positions) - IF (ALLOCATED(features%route_grad_return_recv_counts)) & + IF (ALLOCATED(features%route_grad_return_recv_counts)) THEN DEALLOCATE (features%route_grad_return_recv_counts) - IF (ALLOCATED(features%route_grad_return_recv_displs)) & + END IF + IF (ALLOCATED(features%route_grad_return_recv_displs)) THEN DEALLOCATE (features%route_grad_return_recv_displs) - IF (ALLOCATED(features%route_grad_return_send_counts)) & + END IF + IF (ALLOCATED(features%route_grad_return_send_counts)) THEN DEALLOCATE (features%route_grad_return_send_counts) - IF (ALLOCATED(features%route_grad_return_send_displs)) & + END IF + IF (ALLOCATED(features%route_grad_return_send_displs)) THEN DEALLOCATE (features%route_grad_return_send_displs) - IF (ALLOCATED(features%route_point_recv_counts)) & + END IF + IF (ALLOCATED(features%route_point_recv_counts)) THEN DEALLOCATE (features%route_point_recv_counts) - IF (ALLOCATED(features%route_point_recv_displs)) & + END IF + IF (ALLOCATED(features%route_point_recv_displs)) THEN DEALLOCATE (features%route_point_recv_displs) - IF (ALLOCATED(features%route_point_send_counts)) & + END IF + IF (ALLOCATED(features%route_point_send_counts)) THEN DEALLOCATE (features%route_point_send_counts) - IF (ALLOCATED(features%route_point_send_displs)) & + END IF + IF (ALLOCATED(features%route_point_send_displs)) THEN DEALLOCATE (features%route_point_send_displs) + END IF IF (ALLOCATED(features%route_send_local_rows)) DEALLOCATE (features%route_send_local_rows) IF (ALLOCATED(features%feature_index)) DEALLOCATE (features%feature_index) IF (ALLOCATED(features%local_feature_counts)) DEALLOCATE (features%local_feature_counts) @@ -1618,8 +1636,9 @@ CONTAINS IF (ALLOCATED(features%atomic_grid_weights)) DEALLOCATE (features%atomic_grid_weights) IF (ALLOCATED(features%atomic_grid_sizes)) DEALLOCATE (features%atomic_grid_sizes) IF (ALLOCATED(features%coarse_0_atomic_coords)) DEALLOCATE (features%coarse_0_atomic_coords) - IF (ALLOCATED(features%atomic_grid_size_bound_shape)) & + IF (ALLOCATED(features%atomic_grid_size_bound_shape)) THEN DEALLOCATE (features%atomic_grid_size_bound_shape) + END IF features%chunk_feature_count = 0 features%nflat = 0 features%nflat_local = 0 diff --git a/src/skala_gpw_functional.F b/src/skala_gpw_functional.F index 212747e875..ab0d553178 100644 --- a/src/skala_gpw_functional.F +++ b/src/skala_gpw_functional.F @@ -1514,8 +1514,9 @@ CONTAINS CPASSERT(SUM(features%route_point_send_counts) == nroute_points) nroute_grad_per_point = ngrad_per_point - IF (features%uses_collapsed_rks_dynamic) & + IF (features%uses_collapsed_rks_dynamic) THEN nroute_grad_per_point = ncollapsed_grad_per_point + END IF ALLOCATE (send_grad_buffer(MAX(1, nroute_grad_per_point*features%chunk_feature_count)), & recv_grad_buffer(MAX(1, nroute_grad_per_point*nroute_points)), & route_grad_return_send_counts(SIZE(features%route_point_recv_counts)), & diff --git a/src/smeagol_control_types.F b/src/smeagol_control_types.F index 37cbe5c18a..7e63f52054 100644 --- a/src/smeagol_control_types.F +++ b/src/smeagol_control_types.F @@ -58,7 +58,7 @@ MODULE smeagol_control_types REAL(kind=dp) :: to_smeagol_energy_units = 2.0_dp !> number of cell images along i and j cell vectors - INTEGER, DIMENSION(2) :: n_cell_images = (/1, 1/) + INTEGER, DIMENSION(2) :: n_cell_images = [1, 1] !> what lead (bulk transport calculation) INTEGER :: lead_label = smeagol_bulklead_leftright diff --git a/src/smeagol_emtoptions.F b/src/smeagol_emtoptions.F index fc1ea616e3..adb1cc9417 100644 --- a/src/smeagol_emtoptions.F +++ b/src/smeagol_emtoptions.F @@ -179,7 +179,8 @@ MODULE smeagol_emtoptions smeagolglobal_emSTT = torqueflag smeagolglobal_emSTTLin = torquelin - ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, therefore 'EM.TimeReversal' is also enabled. + ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, + ! therefore 'EM.TimeReversal' is also enabled. ! In case of this CP2K+SMEAGOL interface, the default value of 'timereversal' variable is .FALSE. IF (smeagol_control%aux%timereversal) THEN CALL cp_warn(__LOCATION__, & @@ -328,7 +329,8 @@ MODULE smeagol_emtoptions ! current-induced forces ! The value of 'smeagol_control%emforces' is set in qs_energies(). - ! Calculation of forces is enabled automatically for certain run_types (energy_force, geo_opt, md) and disabled otherwise. + ! Calculation of forces is enabled automatically for certain run_types + ! (energy_force, geo_opt, md) and disabled otherwise. IF (smeagol_control%aux%curr_dist) THEN smeagol_control%emforces = .TRUE. END IF @@ -338,8 +340,9 @@ MODULE smeagol_emtoptions IF (.NOT. smeagol_control%aux%isexplicit_GetRhoSingleLead) smeagol_control%aux%GetRhoSingleLead = GetRhoSingleLeadDefault IF (smeagol_control%aux%MinChannelIndex < 1) smeagol_control%aux%MinChannelIndex = 1 - IF (smeagol_control%aux%MaxChannelIndex < 1) & + IF (smeagol_control%aux%MaxChannelIndex < 1) THEN smeagol_control%aux%MaxChannelIndex = smeagol_control%aux%MinChannelIndex + 4 + END IF IF (smeagolglobal_emSTT .AND. smeagolglobal_emSTTLin .AND. smeagol_control%aux%GetRhoSingleLead /= -3) THEN CALL cp_warn(__LOCATION__, & diff --git a/src/smeagol_interface.F b/src/smeagol_interface.F index 556e5b4e67..eccf01abec 100644 --- a/src/smeagol_interface.F +++ b/src/smeagol_interface.F @@ -731,11 +731,13 @@ CONTAINS ! first invocation of the subroutine : initialise md_iter_level and md_first_step variables smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "MD") - IF (smeagol_control%aux%md_iter_level <= 0) & + IF (smeagol_control%aux%md_iter_level <= 0) THEN smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "GEO_OPT") + END IF - IF (smeagol_control%aux%md_iter_level <= 0) & + IF (smeagol_control%aux%md_iter_level <= 0) THEN smeagol_control%aux%md_iter_level = 0 + END IF ! index of the first GEO_OPT / MD step IF (smeagol_control%aux%md_iter_level > 0) THEN diff --git a/src/smeagol_matrix_utils.F b/src/smeagol_matrix_utils.F index ad3ea6d6d8..1bf43236fc 100644 --- a/src/smeagol_matrix_utils.F +++ b/src/smeagol_matrix_utils.F @@ -72,7 +72,8 @@ MODULE smeagol_matrix_utils INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_send = 2 INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_dim2 = nelements_dbcsr_send - INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 ! 128 MiB (to limit memory usage for matrix redistribution) + ! 128 MiB (to limit memory usage for matrix redistribution) + INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_dp = max_mpi_packet_size_bytes/INT(dp_size, kind=int_8) ! a portable way to determine the upper bound for tag value is to call @@ -220,7 +221,8 @@ CONTAINS ! via subroutine arguments, an extra MPI_Allreduce operation is needed each time we call ! replicate_neighbour_list() / get_nnodes_local(). max_ijk_cell_image(3) = -1 - IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 ! bulk-transport calculation expects exactly 3 cell images along transport direction + ! bulk-transport calculation expects exactly 3 cell images along transport direction + IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 ! replicate pair-wise neighbour list. Identical non-zero matrix blocks from cell image along transport direction ! are grouped together if do_merge == .TRUE. @@ -502,8 +504,10 @@ CONTAINS END IF END IF - ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements (should be OK due to SMEAGOL limitation) - ! in principle, it is possible to overcome this limit by using derived datatypes (which will require additional wrapper functions, indeed). + ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements + ! (should be OK due to SMEAGOL limitation) + ! in principle, it is possible to overcome this limit by using derived datatypes + ! (which will require additional wrapper functions, indeed). ! ! pre-post non-blocking receive operations IF (n_nonzero_elements_siesta > 0) THEN @@ -685,10 +689,13 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) DEALLOCATE (offset_per_proc, n_packed_elements_per_proc) - ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, local row index, and column index (in this order). - ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, source MPI rank, and column index. + ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, + ! local row index, and column index (in this order). + ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, + ! source MPI rank, and column index. ! (column indices are in the ascending order within each (row index, source MPI rank) block). - ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : local row index, column index + ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : + ! local row index, column index IF (n_nonzero_elements_siesta > 0) THEN ALLOCATE (reorder_recv_buffer(n_nonzero_elements_siesta)) ALLOCATE (next_nonzero_element_offset(siesta_struct%nrows)) @@ -1023,7 +1030,8 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) - iproc = siesta_struct%gather_root ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root + ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root + iproc = siesta_struct%gather_root IF (n_nonzero_elements_dbcsr > 0) THEN DO inode_proc = 1, nnodes_proc n_image_ind = siesta_struct%n_dbcsr_cell_images_to_merge(inode_proc) @@ -1866,8 +1874,9 @@ CONTAINS ! there is no need to send data to the same MPI process IF (iproc /= mepos) THEN nrequests = nrequests + INT(nelements_per_proc(iproc)/max_nelements_per_packet) - IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) & + IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) THEN nrequests = nrequests + 1 + END IF END IF END DO END FUNCTION get_number_of_mpi_sendrecv_requests diff --git a/src/start/cp2k.F b/src/start/cp2k.F index 8d26c43ea1..15857c3c7d 100644 --- a/src/start/cp2k.F +++ b/src/start/cp2k.F @@ -167,8 +167,9 @@ PROGRAM cp2k INTEGER :: veclib_max_threads, ierr CALL get_environment_variable("VECLIB_MAXIMUM_THREADS", env_var, status=ierr) veclib_max_threads = 0 - IF (ierr == 0) & + IF (ierr == 0) THEN READ (env_var, *) veclib_max_threads + END IF IF (ierr == 1 .OR. (ierr == 0 .AND. veclib_max_threads > 1)) THEN CALL cp_warn(__LOCATION__, & "macOS' Accelerate framework has its own threading enabled which may interfere"// & @@ -236,8 +237,9 @@ PROGRAM cp2k DO inp_var_idx = 1, SIZE(initial_variables, 2) ! check whether the variable was already set, in this case, overwrite - IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) & + IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) THEN EXIT + END IF END DO IF (inp_var_idx > SIZE(initial_variables, 2)) THEN diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index 7287947c5d..c1d18cf537 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -314,8 +314,9 @@ CONTAINS method_name_id /= do_nnp .AND. & method_name_id /= do_embed .AND. & method_name_id /= do_fist .AND. & - method_name_id /= do_ipi) & + method_name_id /= do_ipi) THEN CPABORT("Energy/Force run not available for all methods ") + END IF sublogger => cp_get_default_logger() CALL cp_add_iter_level(sublogger%iter_info, "JUST_ENERGY", & @@ -324,8 +325,9 @@ CONTAINS ! loop over molecules to generate a molecular guess ! this procedure is initiated here to avoid passing globenv deep down ! the subroutine stack - IF (do_mol_loop(force_env=force_env)) & + IF (do_mol_loop(force_env=force_env)) THEN CALL loop_over_molecules(globenv, force_env) + END IF SELECT CASE (globenv%run_type_id) CASE (energy_run) @@ -347,8 +349,9 @@ CONTAINS CASE (do_tamc) CALL qs_tamc(force_env, globenv) CASE (real_time_propagation) - IF (method_name_id /= do_qs) & + IF (method_name_id /= do_qs) THEN CPABORT("Real time propagation needs METHOD QS. ") + END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .TRUE. SELECT CASE (dft_control%rtp_control%rtp_method) @@ -360,8 +363,9 @@ CONTAINS CALL rt_prop_setup(force_env) END SELECT CASE (ehrenfest) - IF (method_name_id /= do_qs) & + IF (method_name_id /= do_qs) THEN CPABORT("Ehrenfest dynamics needs METHOD QS ") + END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .FALSE. CALL qs_mol_dyn(force_env, globenv) @@ -369,8 +373,9 @@ CONTAINS CALL do_bsse_calculation(force_env, globenv) CASE (linear_response_run) IF (method_name_id /= do_qs .AND. & - method_name_id /= do_qmmm) & + method_name_id /= do_qmmm) THEN CPABORT("Property calculations by Linear Response only within the QS or QMMM program ") + END IF ! The Ground State is needed, it can be read from Restart CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., linres=.TRUE.) CALL linres_calculation(force_env) @@ -800,8 +805,9 @@ CONTAINS ! change to the new working directory CALL m_chdir(TRIM(farming_env%Job(i)%cwd), ierr) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CPABORT("Failed to change dir to: "//TRIM(farming_env%Job(i)%cwd)) + END IF ! generate a fresh call to cp2k_run IF (new_rank == 0) THEN diff --git a/src/start/cp2k_shell.F b/src/start/cp2k_shell.F index d1071bc108..6dd3ad5438 100644 --- a/src/start/cp2k_shell.F +++ b/src/start/cp2k_shell.F @@ -541,13 +541,13 @@ CONTAINS TYPE(cp2k_shell_type) :: shell CHARACTER(LEN=*), INTENT(IN) :: arg1 - INTEGER :: ierr, iostat, n_atom + INTEGER :: ierr, n_atom IF (.NOT. parse_env_id(arg1, shell)) RETURN CALL get_natom(shell%env_id, n_atom, ierr) IF (.NOT. my_assert(ierr == 0, 'get_natom failed', shell)) RETURN IF (shell%iw > 0) THEN - WRITE (shell%iw, '(i10)', iostat=iostat) n_atom + WRITE (shell%iw, '(i10)') n_atom CALL m_flush(shell%iw) END IF END SUBROUTINE get_natom_command diff --git a/src/start/libcp2k.F b/src/start/libcp2k.F index 85f39e3c5a..4ac0f6b73b 100755 --- a/src/start/libcp2k.F +++ b/src/start/libcp2k.F @@ -515,8 +515,9 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=nmo) END BLOCK try @@ -555,13 +556,15 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=norb) - IF (buf_len < norb*norb) & + IF (buf_len < norb*norb) THEN EXIT try + END IF DO i = 0, norb - 1 DO j = 0, norb - 1 @@ -602,8 +605,9 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF nze_count = INT(active_space_env%eri%eri(1)%csr_mat%nze_total, KIND(nze_count)) END BLOCK try @@ -646,12 +650,14 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF ASSOCIATE (nze => active_space_env%eri%eri(1)%csr_mat%nze_total) - IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) & + IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) THEN EXIT try + END IF CALL active_space_env%eri%eri_foreach(1, active_space_env%active_orbitals, eri2array(buf_coords, buf_values)) diff --git a/src/stm_images.F b/src/stm_images.F index d4e1ecb285..a0f6411fcc 100644 --- a/src/stm_images.F +++ b/src/stm_images.F @@ -309,8 +309,9 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) & + IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) THEN WRITE (output_unit, '(T4,A)') "Warning: EFermi+bias below lowest computed occupied MO" + END IF ELSE nmo = SIZE(evals(ispin)%array) DO imo = 1, nmo @@ -320,8 +321,9 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) & + IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) THEN WRITE (output_unit, '(T4,A)') "Warning: E-Fermi+bias above highest computed unoccupied MO" + END IF END IF istates = istates + nstates(ispin) END DO diff --git a/src/subsys/colvar_types.F b/src/subsys/colvar_types.F index b7c28982d7..1e390bc3ec 100644 --- a/src/subsys/colvar_types.F +++ b/src/subsys/colvar_types.F @@ -501,7 +501,7 @@ CONTAINS SUBROUTINE colvar_setup(colvar) TYPE(colvar_type), INTENT(INOUT) :: colvar - INTEGER :: i, idum, iend, ii, istart, j, np, stat + INTEGER :: i, idum, iend, ii, istart, j, np INTEGER, DIMENSION(:), POINTER :: list SELECT CASE (colvar%type_id) @@ -660,11 +660,12 @@ CONTAINS IF (colvar%plane_plane_angle_param%plane1%type_of_def == plane_def_atoms) np = np + 3 IF (colvar%plane_plane_angle_param%plane2%type_of_def == plane_def_atoms) np = np + 3 ! if np is equal to zero this means that this is not a COLLECTIVE variable.. - IF (np == 0) & + IF (np == 0) THEN CALL cp_abort(__LOCATION__, & "PLANE_PLANE_ANGLE Colvar defined using two normal vectors! This is "// & "not a COLLECTIVE VARIABLE! One of the two planes must be defined "// & "using atomic positions.") + END IF ! Number of real atoms involved in the colvar colvar%n_atom_s = 0 @@ -850,8 +851,8 @@ CONTAINS i = colvar%xyz_outerdiag_param%i_atoms(2) list(2) = i CASE (u_colvar_id) - np = 1; ALLOCATE (list(np), stat=stat) - CPASSERT(stat == 0) + np = 1 + ALLOCATE (list(np)) colvar%n_atom_s = np; list(1) = 1 CASE (Wc_colvar_id) np = 3 @@ -1034,8 +1035,9 @@ CONTAINS idum = idum + 1 i = i_oxygens(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) & + IF (ANY(i_hydrogens == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS and HYDROGENS list") + END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1046,10 +1048,12 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens) & + IF (i <= n_oxygens) THEN CPABORT("atoms doubled in OXYGENS list") - IF (i > n_oxygens) & + END IF + IF (i > n_oxygens) THEN CPABORT("atoms doubled in HYDROGENS list") + END IF END IF END DO END DO @@ -1113,17 +1117,20 @@ CONTAINS idum = idum + 1 i = i_oxygens_water(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) & + IF (ANY(i_hydrogens == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and HYDROGENS list") - IF (ANY(i_oxygens_acid == i)) & + END IF + IF (ANY(i_oxygens_acid == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and OXYGENS_ACID list") + END IF END DO DO ii = 1, n_oxygens_acid idum = idum + 1 i = i_oxygens_acid(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) & + IF (ANY(i_hydrogens == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS_ACID and HYDROGENS list") + END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1134,12 +1141,15 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens_water) & + IF (i <= n_oxygens_water) THEN CPABORT("atoms doubled in OXYGENS_WATER list") - IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) & + END IF + IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) THEN CPABORT("atoms doubled in OXYGENS_ACID list") - IF (i > n_oxygens_water + n_oxygens_acid) & + END IF + IF (i > n_oxygens_water + n_oxygens_acid) THEN CPABORT("atoms doubled in HYDROGENS list") + END IF END IF END DO END DO @@ -1354,7 +1364,7 @@ CONTAINS TYPE(colvar_type), INTENT(IN) :: colvar_in INTEGER, INTENT(IN), OPTIONAL :: i_atom_offset - INTEGER :: i, my_offset, ndim, ndim2, stat + INTEGER :: i, my_offset, ndim, ndim2 my_offset = 0 IF (PRESENT(i_atom_offset)) my_offset = i_atom_offset @@ -1407,7 +1417,7 @@ CONTAINS ndim = SIZE(colvar_in%coord_param%c_kinds_to_b) ALLOCATE (colvar_out%coord_param%c_kinds_to_b(ndim)) colvar_out%coord_param%c_kinds_to_b = colvar_in%coord_param%c_kinds_to_b - ELSEIF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN + ELSE IF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_to_b) ALLOCATE (colvar_out%coord_param%i_at_to_b(ndim)) @@ -1615,11 +1625,11 @@ CONTAINS colvar_out%reaction_path_param%align_frames = colvar_in%reaction_path_param%align_frames colvar_out%reaction_path_param%subset = colvar_in%reaction_path_param%subset ndim = SIZE(colvar_in%reaction_path_param%i_rmsd) - ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim), stat=stat) + ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim)) colvar_out%reaction_path_param%i_rmsd = colvar_in%reaction_path_param%i_rmsd ndim = SIZE(colvar_in%reaction_path_param%r_ref, 1) ndim2 = SIZE(colvar_in%reaction_path_param%r_ref, 2) - ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2), stat=stat) + ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2)) colvar_out%reaction_path_param%r_ref = colvar_in%reaction_path_param%r_ref ELSE ndim = SIZE(colvar_in%reaction_path_param%colvar_p) @@ -1842,8 +1852,9 @@ CONTAINS IF (ASSOCIATED(colvar_p)) THEN DO i = 1, SIZE(colvar_p) - IF (ASSOCIATED(colvar_p(i)%colvar)) & + IF (ASSOCIATED(colvar_p(i)%colvar)) THEN CALL colvar_release(colvar_p(i)%colvar) + END IF END DO DEALLOCATE (colvar_p) END IF diff --git a/src/subsys/external_potential_types.F b/src/subsys/external_potential_types.F index dbdf0c557a..26bc3d047f 100644 --- a/src/subsys/external_potential_types.F +++ b/src/subsys/external_potential_types.F @@ -587,11 +587,13 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) name = potential%name - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN alpha_core_charge = potential%alpha_core_charge + END IF IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN core_charge_radius = potential%core_charge_radius + END IF IF (PRESENT(z)) z = potential%z IF (PRESENT(zeff)) zeff = potential%zeff IF (PRESENT(zeff_correction)) zeff_correction = potential%zeff_correction @@ -763,13 +765,15 @@ CONTAINS IF (PRESENT(name)) name = potential%name IF (PRESENT(aliases)) aliases = potential%aliases - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN alpha_core_charge = potential%alpha_core_charge + END IF IF (PRESENT(alpha_ppl)) alpha_ppl = potential%alpha_ppl IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge IF (PRESENT(cerf_ppl)) cerf_ppl = potential%cerf_ppl - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN core_charge_radius = potential%core_charge_radius + END IF IF (PRESENT(ppl_radius)) ppl_radius = potential%ppl_radius IF (PRESENT(ppnl_radius)) ppnl_radius = potential%ppnl_radius IF (PRESENT(soc_present)) soc_present = potential%soc @@ -1371,9 +1375,10 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1411,9 +1416,10 @@ CONTAINS IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r ELSE @@ -1557,9 +1563,10 @@ CONTAINS ! Read ngau and npol IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) ngau, npol CALL remove_word(line_att) @@ -1579,9 +1586,10 @@ CONTAINS DO igau = 1, ngau IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) alpha(igau), (cval(igau, ipol), ipol=1, npol) ELSE @@ -1775,9 +1783,10 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1818,9 +1827,10 @@ CONTAINS ! distribution and calculate the corresponding coefficient IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2157,9 +2167,10 @@ CONTAINS DO l = 0, lppnl IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2204,13 +2215,15 @@ CONTAINS END IF ELSE IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) & + IF (LEN_TRIM(line_att) /= 0) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) hprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2258,13 +2271,15 @@ CONTAINS ! Read non-local parameters for spin-orbit coupling DO i = 1, nprj_ppnl IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) & + IF (LEN_TRIM(line_att) /= 0) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) kprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2443,11 +2458,13 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN potential%alpha_core_charge = alpha_core_charge + END IF IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN potential%core_charge_radius = core_charge_radius + END IF IF (PRESENT(z)) potential%z = z IF (PRESENT(zeff)) potential%zeff = zeff IF (PRESENT(zeff_correction)) potential%zeff_correction = zeff_correction @@ -2573,13 +2590,15 @@ CONTAINS POINTER :: hprj_ppnl, kprj_ppnl IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN potential%alpha_core_charge = alpha_core_charge + END IF IF (PRESENT(alpha_ppl)) potential%alpha_ppl = alpha_ppl IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge IF (PRESENT(cerf_ppl)) potential%cerf_ppl = cerf_ppl - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN potential%core_charge_radius = core_charge_radius + END IF IF (PRESENT(ppl_radius)) potential%ppl_radius = ppl_radius IF (PRESENT(ppnl_radius)) potential%ppnl_radius = ppnl_radius IF (PRESENT(lppnl)) potential%lppnl = lppnl diff --git a/src/subsys/molecule_kind_types.F b/src/subsys/molecule_kind_types.F index 232123e92e..9943a66164 100644 --- a/src/subsys/molecule_kind_types.F +++ b/src/subsys/molecule_kind_types.F @@ -365,8 +365,9 @@ CONTAINS END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set)) THEN DO i = 1, SIZE(molecule_kind_set(imolecule_kind)%bend_kind_set) - IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) & + IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs) + END IF END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set) END IF @@ -934,24 +935,30 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T9,A,I6,/,T9,A,(T30,5I10))") & "Number of molecules: ", nmolecule, "Molecule list:", & (molecule_kind%molecule_list(imolecule), imolecule=1, nmolecule) - IF (molecule_kind%nbond > 0) & + IF (molecule_kind%nbond > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bonds: ", molecule_kind%nbond - IF (molecule_kind%nbend > 0) & + "Number of bonds: ", molecule_kind%nbond + END IF + IF (molecule_kind%nbend > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bends: ", molecule_kind%nbend - IF (molecule_kind%nub > 0) & + "Number of bends: ", molecule_kind%nbend + END IF + IF (molecule_kind%nub > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of Urey-Bradley:", molecule_kind%nub - IF (molecule_kind%ntorsion > 0) & + "Number of Urey-Bradley:", molecule_kind%nub + END IF + IF (molecule_kind%ntorsion > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of torsions: ", molecule_kind%ntorsion - IF (molecule_kind%nimpr > 0) & + "Number of torsions: ", molecule_kind%ntorsion + END IF + IF (molecule_kind%nimpr > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of improper: ", molecule_kind%nimpr - IF (molecule_kind%nopbend > 0) & + "Number of improper: ", molecule_kind%nimpr + END IF + IF (molecule_kind%nopbend > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of out opbends: ", molecule_kind%nopbend + "Number of out opbends: ", molecule_kind%nopbend + END IF END IF END IF END SUBROUTINE write_molecule_kind diff --git a/src/subsys/molecule_types.F b/src/subsys/molecule_types.F index f300b5d188..41d097f00c 100644 --- a/src/subsys/molecule_types.F +++ b/src/subsys/molecule_types.F @@ -212,11 +212,13 @@ CONTAINS DEALLOCATE (gci%colv_list) END IF - IF (ASSOCIATED(gci%g3x3_list)) & + IF (ASSOCIATED(gci%g3x3_list)) THEN DEALLOCATE (gci%g3x3_list) + END IF - IF (ASSOCIATED(gci%g4x6_list)) & + IF (ASSOCIATED(gci%g4x6_list)) THEN DEALLOCATE (gci%g4x6_list) + END IF ! Local information IF (ASSOCIATED(gci%lcolv)) THEN @@ -227,14 +229,17 @@ CONTAINS DEALLOCATE (gci%lcolv) END IF - IF (ASSOCIATED(gci%lg3x3)) & + IF (ASSOCIATED(gci%lg3x3)) THEN DEALLOCATE (gci%lg3x3) + END IF - IF (ASSOCIATED(gci%lg4x6)) & + IF (ASSOCIATED(gci%lg4x6)) THEN DEALLOCATE (gci%lg4x6) + END IF - IF (ASSOCIATED(gci%fixd_list)) & + IF (ASSOCIATED(gci%fixd_list)) THEN DEALLOCATE (gci%fixd_list) + END IF DEALLOCATE (gci) END IF diff --git a/src/surface_dipole.F b/src/surface_dipole.F index a4271394e8..ef35421cad 100644 --- a/src/surface_dipole.F +++ b/src/surface_dipole.F @@ -166,7 +166,7 @@ CONTAINS rhoavsurf(i) = accurate_sum(wf_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), i)) END DO - ELSEIF (idir_surfdip == 2) THEN + ELSE IF (idir_surfdip == 2) THEN isurf = 3 jsurf = 1 @@ -258,7 +258,7 @@ CONTAINS IF (idir_surfdip == 3) THEN vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) = & vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) + vdip - ELSEIF (idir_surfdip == 2) THEN + ELSE IF (idir_surfdip == 2) THEN IF (irho >= bo(1, 2) .AND. irho <= bo(2, 2)) THEN vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) = & vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) + vdip diff --git a/src/swarm/glbopt_history.F b/src/swarm/glbopt_history.F index 81cc126cca..a217a22a75 100644 --- a/src/swarm/glbopt_history.F +++ b/src/swarm/glbopt_history.F @@ -213,8 +213,9 @@ CONTAINS ALLOCATE (history%entries(k)%p) history%entries(k)%p = fingerprint - IF (PRESENT(id)) & + IF (PRESENT(id)) THEN history%entries(k)%id = id + END IF history%length = history%length + 1 IF (debug) THEN @@ -222,8 +223,9 @@ CONTAINS DO k = 1, history%length !WRITE(*,*) "history: ", k, "Epot",history%entries(k)%p%Epot IF (k > 1) THEN - IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) & + IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) THEN CPABORT("history_add: history in wrong order") + END IF END IF END DO END IF @@ -374,8 +376,9 @@ CONTAINS INTEGER :: i DO i = 1, history%length - IF (ASSOCIATED(history%entries(i)%p)) & + IF (ASSOCIATED(history%entries(i)%p)) THEN DEALLOCATE (history%entries(i)%p) + END IF END DO DEALLOCATE (history%entries) diff --git a/src/swarm/glbopt_mincrawl.F b/src/swarm/glbopt_mincrawl.F index ce6938ec53..bbb9eb7133 100644 --- a/src/swarm/glbopt_mincrawl.F +++ b/src/swarm/glbopt_mincrawl.F @@ -182,8 +182,9 @@ CONTAINS RETURN END IF - IF (TRIM(status) == "ok") & + IF (TRIM(status) == "ok") THEN CALL mincrawl_register_minima(this, report) + END IF IF (.FALSE.) CALL print_tempdist(best_minima) diff --git a/src/swarm/glbopt_minhop.F b/src/swarm/glbopt_minhop.F index 9bde51b2d7..53c4202532 100644 --- a/src/swarm/glbopt_minhop.F +++ b/src/swarm/glbopt_minhop.F @@ -217,8 +217,9 @@ CONTAINS ! new locally lowest IF (this%iw > 0) WRITE (this%iw, '(A)') " MINHOP| New locally lowest" this%worker_state(wid)%Epot_hop = report_Epot - IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) & + IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) THEN ALLOCATE (this%worker_state(wid)%pos_hop(SIZE(report_positions))) + END IF this%worker_state(wid)%pos_hop(:) = report_positions this%worker_state(wid)%fp_hop = report_fp END IF diff --git a/src/swarm/glbopt_worker.F b/src/swarm/glbopt_worker.F index 78e14d9927..bcb2f8134a 100644 --- a/src/swarm/glbopt_worker.F +++ b/src/swarm/glbopt_worker.F @@ -232,8 +232,9 @@ CONTAINS END DO CALL unpack_subsys_particles(worker%subsys, r=positions) - IF (n_fragments > 0 .AND. worker%iw > 0) & + IF (n_fragments > 0 .AND. worker%iw > 0) THEN WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Ran fix_fragmentation times:", n_fragments + END IF ! setup geometry optimization IF (worker%iw > 0) WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Starting local optimisation at trajectory frame ", iframe @@ -292,10 +293,10 @@ CONTAINS DO WHILE (stack_size > 0) i = stack(stack_size); stack_size = stack_size - 1 !pop DO j = 1, n_particles - IF (norm(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected + IF (NORM2(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected IF (.NOT. marked(j)) THEN marked(j) = .TRUE. - stack(stack_size + 1) = j; stack_size = stack_size + 1; !push + stack(stack_size + 1) = j; stack_size = stack_size + 1 !push END IF END IF END DO @@ -314,7 +315,7 @@ CONTAINS IF (marked(i)) CYCLE DO j = 1, n_particles IF (.NOT. marked(j)) CYCLE - d = norm(diff(positions, i, j)) + d = NORM2(diff(positions, i, j)) IF (d < min_dist) THEN min_dist = d cluster_edge = i @@ -324,7 +325,7 @@ CONTAINS END DO dr = diff(positions, cluster_edge, fragment_edge) - s = 1.0 - bondlength/norm(dr) + s = 1.0 - bondlength/NORM2(dr) DO i = 1, n_particles IF (marked(i)) CYCLE positions(3*i - 2:3*i) = positions(3*i - 2:3*i) - s*dr @@ -348,19 +349,6 @@ CONTAINS dr = positions(3*i - 2:3*i) - positions(3*j - 2:3*j) END FUNCTION diff -! ************************************************************************************************** -!> \brief Helper routine for fix_fragmentation, calculates vector norm -!> \param vec ... -!> \return ... -!> \author Ole Schuett -! ************************************************************************************************** - PURE FUNCTION norm(vec) RESULT(res) - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec - REAL(KIND=dp) :: res - - res = SQRT(DOT_PRODUCT(vec, vec)) - END FUNCTION norm - ! ************************************************************************************************** !> \brief Finalizes worker for global optimization !> \param worker ... diff --git a/src/swarm/swarm_master.F b/src/swarm/swarm_master.F index 703686c352..bd627a6d5d 100644 --- a/src/swarm/swarm_master.F +++ b/src/swarm/swarm_master.F @@ -261,8 +261,9 @@ CONTAINS IF (.NOT. master%should_stop) THEN CALL external_control(master%should_stop, "SWARM", master%globenv) - IF (master%should_stop .AND. master%iw > 0) & + IF (master%should_stop .AND. master%iw > 0) THEN WRITE (master%iw, *) " SWARM| Received stop from external_control. Quitting." + END IF END IF !IF(unit > 0) & diff --git a/src/swarm/swarm_message.F b/src/swarm/swarm_message.F index 96418c033a..79bc07e666 100644 --- a/src/swarm/swarm_message.F +++ b/src/swarm/swarm_message.F @@ -866,8 +866,9 @@ CONTAINS TYPE(message_entry_type), POINTER :: new_entry - IF (swarm_message_haskey(msg, key)) & + IF (swarm_message_haskey(msg, key)) THEN CPABORT("swarm_message_add_${label}$: key already exists: "//TRIM(key)) + END IF ALLOCATE (new_entry) new_entry%key = key @@ -920,8 +921,9 @@ CONTAINS curr_entry => msg%root DO WHILE (ASSOCIATED(curr_entry)) IF (TRIM(curr_entry%key) == TRIM(key)) THEN - IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) & + IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) THEN CPABORT("swarm_message_get_${label}$: value not associated key: "//TRIM(key)) + END IF #:if label.startswith("1d_") ALLOCATE (value(SIZE(curr_entry%value_${label}$))) #:endif diff --git a/src/swarm/swarm_mpi.F b/src/swarm/swarm_mpi.F index f1f4842ffe..db985c32f6 100644 --- a/src/swarm/swarm_mpi.F +++ b/src/swarm/swarm_mpi.F @@ -133,8 +133,9 @@ CONTAINS !WRITE (*,*) "this is worker ", worker_id, swarm_mpi%worker%mepos, swarm_mpi%worker%num_pe ! collect world-ranks of each worker groups rank-0 node - IF (swarm_mpi%worker%mepos == 0) & + IF (swarm_mpi%worker%mepos == 0) THEN swarm_mpi%wid2group(worker_id) = swarm_mpi%world%mepos + END IF END IF @@ -162,14 +163,16 @@ CONTAINS logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr swarm_mpi%master_output_path = output_unit2path(output_unit) - IF (output_unit /= default_output_unit) & + IF (output_unit /= default_output_unit) THEN CLOSE (output_unit) + END IF END IF CALL swarm_mpi%world%bcast(swarm_mpi%master_output_path) - IF (ASSOCIATED(swarm_mpi%master)) & + IF (ASSOCIATED(swarm_mpi%master)) THEN CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path) + END IF END SUBROUTINE logger_init_master ! ************************************************************************************************** @@ -183,8 +186,9 @@ CONTAINS CHARACTER(LEN=default_path_length) :: output_path output_path = "__STD_OUT__" - IF (output_unit /= default_output_unit) & + IF (output_unit /= default_output_unit) THEN INQUIRE (unit=output_unit, name=output_path) + END IF END FUNCTION output_unit2path ! ************************************************************************************************** @@ -245,9 +249,10 @@ CONTAINS IF (para_env%is_source()) THEN ! open output_unit according to output_path output_unit = default_output_unit - IF (output_path /= "__STD_OUT__") & + IF (output_path /= "__STD_OUT__") THEN CALL open_file(file_name=output_path, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", unit_number=output_unit) + END IF END IF old_logger => cp_get_default_logger() @@ -294,8 +299,9 @@ CONTAINS NULLIFY (logger, old_logger) logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr - IF (output_unit > 0 .AND. output_unit /= default_output_unit) & + IF (output_unit > 0 .AND. output_unit /= default_output_unit) THEN CALL close_file(output_unit) + END IF CALL cp_rm_default_logger() !pops the top-most logger old_logger => cp_get_default_logger() diff --git a/src/swarm/swarm_worker.F b/src/swarm/swarm_worker.F index 2b51172354..13c8f698e8 100644 --- a/src/swarm/swarm_worker.F +++ b/src/swarm/swarm_worker.F @@ -123,8 +123,9 @@ CONTAINS END SELECT END IF - IF (.NOT. swarm_message_haskey(report, "status")) & + IF (.NOT. swarm_message_haskey(report, "status")) THEN CALL swarm_message_add(report, "status", "ok") + END IF END SUBROUTINE swarm_worker_execute diff --git a/src/task_list_methods.F b/src/task_list_methods.F index f7983f47a6..5b467db21c 100644 --- a/src/task_list_methods.F +++ b/src/task_list_methods.F @@ -1682,8 +1682,7 @@ CONTAINS DO i = 1, desc%group_size ! At the moment we can only offload replicated tasks - IF (load_imbalance(i) > 0) & - load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) + IF (load_imbalance(i) > 0) load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) END DO ! simplest algorithm I can think of of is that the processor with the most @@ -1935,8 +1934,9 @@ CONTAINS DO igrid_level = 1, SIZE(rs_descs) IF (rs_descs(igrid_level)%rs_desc%distributed) THEN - IF (.NOT. skip_load_balance_distributed) & + IF (.NOT. skip_load_balance_distributed) THEN CALL load_balance_distributed(tasks, ntasks, rs_descs, igrid_level, natoms) + END IF CALL get_current_loads(loads(:, igrid_level), rs_descs, igrid_level, ntasks, & tasks, use_reordered_ranks=.FALSE.) @@ -1958,10 +1958,6 @@ CONTAINS END IF END DO - !IF (desc%my_pos==0) THEN - ! WRITE(*,*) "Total replicated load is ",replicated_load - !END IF - ! Now we adjust the rank ordering based on the current loads ! we leave the first distributed level and all the replicated levels in the default order IF (reorder_rs_grid_ranks) THEN @@ -2022,21 +2018,6 @@ CONTAINS ! Now we use the replicated tasks to balance out the rest of the load CALL load_balance_replicated(rs_descs, ntasks, tasks) - !total_loads = 0 - !DO igrid_level=1,SIZE(rs_descs) - ! CALL get_current_loads(loads(:,igrid_level), rs_descs, igrid_level, ntasks, & - ! tasks, use_reordered_ranks=.TRUE.) - ! total_loads = total_loads + loads(:, igrid_level) - !END DO - - !IF (desc%my_pos==0) THEN - ! WRITE(*,*) "" - ! WRITE(*,*) "At the end of the load balancing procedure" - ! WRITE(*,*) "Maximum load:",MAXVAL(total_loads) - ! WRITE(*,*) "Average load:",SUM(total_loads)/SIZE(total_loads) - ! WRITE(*,*) "Minimum load:",MINVAL(total_loads) - !ENDIF - ! given a list of tasks, this will do the needed reshuffle so that all tasks will be local CALL create_local_tasks(rs_descs, ntasks, tasks, ntasks_recv, tasks_recv) @@ -2046,13 +2027,6 @@ CONTAINS ! CALL get_atom_pair(atom_pair_send, tasks, ntasks=ntasks, send=.TRUE., symmetric=symmetric, rs_descs=rs_descs) - ! natom_send=SIZE(atom_pair_send) - ! CALL desc%group%sum(natom_send) - ! IF (desc%my_pos==0) THEN - ! WRITE(*,*) "" - ! WRITE(*,*) "Total number of atomic blocks to be send:",natom_send - ! ENDIF - CALL get_atom_pair(atom_pair_recv, tasks_recv, ntasks=ntasks_recv, send=.FALSE., symmetric=symmetric, rs_descs=rs_descs) ! cleanup, at this point we don't need the original tasks anymore @@ -2859,18 +2833,24 @@ CONTAINS tasks(itask)%subpatch_pattern = 0 ! encode the domain size for this task ! if the bit is set, we need to add the border in that direction - IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) & + IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 0) - IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) & + END IF + IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 1) - IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) & + END IF + IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 2) - IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) & + END IF + IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 3) - IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) & + END IF + IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 4) - IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) & + END IF + IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 5) + END IF itask = itask + 1 END DO END DO diff --git a/src/tblite_interface.F b/src/tblite_interface.F index c15de30544..fe2be3e8d6 100644 --- a/src/tblite_interface.F +++ b/src/tblite_interface.F @@ -180,8 +180,9 @@ CONTAINS nspin = SIZE(matrix_p, 1) nimg = SIZE(matrix_p, 2) IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN - IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) & + IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) THEN CALL dbcsr_deallocate_matrix_set(tb%rho_ao_kp_ref) + END IF END IF IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN CALL dbcsr_allocate_matrix_set(tb%rho_ao_kp_ref, nspin, nimg) @@ -337,8 +338,9 @@ CONTAINS info = tb%calc%variable_info() IF (info%charge > shell_resolved) CPABORT("tblite: no support for orbital resolved charge") IF (info%dipole > atom_resolved) CPABORT("tblite: no support for shell resolved dipole moment") - IF (info%quadrupole > atom_resolved) & + IF (info%quadrupole > atom_resolved) THEN CPABORT("tblite: no support shell resolved quadrupole moment") + END IF CALL new_wavefunction(tb%wfn, tb%mol%nat, tb%calc%bas%nsh, tb%calc%bas%nao, nSpin, 0.0_dp) CALL get_occupation(tb%mol, tb%calc%bas, tb%calc%h0, tb%wfn%nocc, tb%wfn%n0at, tb%wfn%n0sh) @@ -463,8 +465,9 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT("tblite SCC mixer OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT("tblite SCC mixer MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (max_weight < min_weight) & + IF (max_weight < min_weight) THEN CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") + END IF IF (weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") SELECT CASE (solver) CASE (tblite_solver_gvd, tblite_solver_gvr) @@ -1470,8 +1473,9 @@ CONTAINS END IF !compute multipole moments for gfn2 - IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) & + IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) THEN CALL tb_get_multipole(qs_env, tb) + END IF ! output overlap information NULLIFY (logger) @@ -1582,7 +1586,7 @@ CONTAINS CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_GRADIENT", debug_value, STATUS=debug_status) IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_gradient CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_POTENTIAL", debug_value, STATUS=debug_status) - IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_potential + IF (debug_status == 0) READ (debug_value, *) skip_scf_dispersion_potential #endif IF (dft_control%qs_control%do_ls_scf .OR. scf_control%use_ot) THEN use_native_mixer = .FALSE. @@ -1630,9 +1634,10 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSEIF (calculate_forces .AND. nspin > 1) THEN - IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) & + ELSE IF (calculate_forces .AND. nspin > 1) THEN + IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN CPABORT("Missing converged tblite density for UKS/LSD forces") + END IF matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -1923,7 +1928,7 @@ CONTAINS ! LS_SCF and OT optimize the electronic variables directly. Use the ! current shell/multipole response from that density without an ! extra SCC variable mixing step. - ELSEIF (nspin > 1) THEN + ELSE IF (nspin > 1) THEN n_mix_cols = nspin*max_shell IF (do_dipole) n_mix_cols = n_mix_cols + nspin*dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + nspin*quad_n @@ -1987,7 +1992,7 @@ CONTAINS skip_charge_mixing = use_no_mixer IF (skip_charge_mixing) THEN ! - ELSEIF (do_combined_mixing) THEN + ELSE IF (do_combined_mixing) THEN n_mix_cols = max_shell IF (do_dipole) n_mix_cols = n_mix_cols + dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + quad_n @@ -2118,10 +2123,12 @@ CONTAINS CALL tb%calc%coulomb%get_energy(tb%mol, tb%cache, tb%wfn, tb%e_es) END IF IF (ALLOCATED(tb%calc%dispersion)) THEN - IF (.NOT. skip_scf_dispersion_potential) & + IF (.NOT. skip_scf_dispersion_potential) THEN CALL tb%calc%dispersion%get_potential(tb%mol, tb%dcache, tb%wfn, tb%pot) - IF (.NOT. skip_scf_dispersion_energy) & + END IF + IF (.NOT. skip_scf_dispersion_energy) THEN CALL tb%calc%dispersion%get_energy(tb%mol, tb%dcache, tb%wfn, tb%e_scd) + END IF END IF IF (ALLOCATED(tb%calc%interactions)) THEN CALL tb%calc%interactions%get_potential(tb%mol, tb%icache, tb%wfn, tb%pot) @@ -3484,8 +3491,9 @@ CONTAINS kpoint_coordinate = REAL(2*ikp_axis - nkp_grid(i) - 1, KIND=dp)/ & REAL(2*nkp_grid(i), KIND=dp) + kp_shift(i) END IF - IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) & + IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) THEN mesh_has_gamma(i) = .TRUE. + END IF END DO END DO has_multipole_response = ASSOCIATED(tb%dipbra) .OR. ASSOCIATED(tb%quadbra) @@ -3493,7 +3501,7 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSEIF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN + ELSE IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -3933,8 +3941,9 @@ CONTAINS post_processing_output_file = "" IF (LEN_TRIM(ref%grad_file) > 0) grad_file = ref%grad_file IF (LEN_TRIM(ref%json_file) > 0) json_file = ref%json_file - IF (LEN_TRIM(ref%post_processing_output_file) > 0) & + IF (LEN_TRIM(ref%post_processing_output_file) > 0) THEN post_processing_output_file = ref%post_processing_output_file + END IF WRITE (charge_str, "(I0)") dft_control%charge spin = MAX(0, dft_control%multiplicity - 1) @@ -4026,8 +4035,9 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_min_weight_default, & ", while CP2K uses MIN_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_min_weight, "." - IF (ref%stop_on_error) & + IF (ref%stop_on_error) THEN CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MIN_WEIGHT") + END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_max_weight - & tblite_mixer_max_weight_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4036,8 +4046,9 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_max_weight_default, & ", while CP2K uses MAX_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_max_weight, "." - IF (ref%stop_on_error) & + IF (ref%stop_on_error) THEN CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MAX_WEIGHT") + END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_weight_factor - & tblite_mixer_weight_factor_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4047,19 +4058,22 @@ CONTAINS "The native reference run uses tblite's library default ", tblite_mixer_weight_factor_default, & ", while CP2K uses WEIGHT_FACTOR ", & dft_control%qs_control%xtb_control%tblite_mixer_weight_factor, "." - IF (ref%stop_on_error) & + IF (ref%stop_on_error) THEN CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/WEIGHT_FACTOR") + END IF END IF etemp = 300.0_dp - IF (ASSOCIATED(scf_control) .AND. ASSOCIATED(scf_control%smear)) THEN - IF (scf_control%smear%do_smear) THEN - etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") - IF (scf_control%smear%method /= smear_fermi_dirac) THEN - WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & - "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & - TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." - WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & - "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." + IF (ASSOCIATED(scf_control)) THEN + IF (ASSOCIATED(scf_control%smear)) THEN + IF (scf_control%smear%do_smear) THEN + etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") + IF (scf_control%smear%method /= smear_fermi_dirac) THEN + WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & + "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & + TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." + WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & + "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." + END IF END IF END IF END IF @@ -4072,13 +4086,15 @@ CONTAINS etemp_guess_str = " --etemp-guess "//TRIM(ADJUSTL(etemp_guess_val_str)) END IF param_str = "" - IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) & + IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) THEN param_str = " --param "//TRIM(tb_shell_quote(dft_control%qs_control%xtb_control%tblite_param_file)) + END IF spinpol_str = "" IF (dft_control%lsd) spinpol_str = " --spin-polarized" post_processing_str = "" - IF (LEN_TRIM(ref%post_processing) > 0) & + IF (LEN_TRIM(ref%post_processing) > 0) THEN post_processing_str = " --post-processing "//TRIM(tb_shell_quote(ref%post_processing)) + END IF post_processing_output_str = "" IF (LEN_TRIM(post_processing_output_file) > 0) THEN WRITE (UNIT=iounit, FMT="(/,T2,A)") & @@ -4089,8 +4105,9 @@ CONTAINS TRIM(tb_shell_quote(post_processing_output_file)) END IF restart_str = " --no-restart" - IF (LEN_TRIM(ref%restart_file) > 0) & + IF (LEN_TRIM(ref%restart_file) > 0) THEN restart_str = " --restart "//TRIM(tb_shell_quote(ref%restart_file)) + END IF CALL tb_write_reference_gen(qs_env, TRIM(gen_file)) @@ -4138,17 +4155,22 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,A)") "Guess: ", TRIM(guess) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Solver: ", TRIM(solver) WRITE (UNIT=iounit, FMT="(T2,A,L1)") "Spin-pol.: ", dft_control%lsd - IF (ref%efield_active) & + IF (ref%efield_active) THEN WRITE (UNIT=iounit, FMT="(T2,A,3ES16.8,A)") "Efield: ", ref%efield, " V/Angstrom" - IF (ref%solvation_active) & + END IF + IF (ref%solvation_active) THEN WRITE (UNIT=iounit, FMT="(T2,A,A,1X,A)") "Solvation: ", TRIM(solvation_model_name), & - TRIM(ref%solvation_solvent) - IF (LEN_TRIM(ref%post_processing) > 0) & + TRIM(ref%solvation_solvent) + END IF + IF (LEN_TRIM(ref%post_processing) > 0) THEN WRITE (UNIT=iounit, FMT="(T2,A,A)") "Post proc.: ", TRIM(ref%post_processing) - IF (LEN_TRIM(post_processing_output_file) > 0) & + END IF + IF (LEN_TRIM(post_processing_output_file) > 0) THEN WRITE (UNIT=iounit, FMT="(T2,A,A)") "PP output: ", TRIM(post_processing_output_file) - IF (ref%electronic_temperature_guess > 0.0_dp) & + END IF + IF (ref%electronic_temperature_guess > 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") "Guess etemp:", etemp_guess, " K" + END IF WRITE (UNIT=iounit, FMT="(T2,A,A)") "Grad file: ", TRIM(grad_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "JSON file: ", TRIM(json_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Log file: ", TRIM(log_file) @@ -4351,8 +4373,9 @@ CONTAINS grad_str = "" IF (ref%guess_cli%grad) grad_str = " --grad" json_str = "" - IF (LEN_TRIM(ref%guess_cli%json_file) > 0) & + IF (LEN_TRIM(ref%guess_cli%json_file) > 0) THEN json_str = " --json "//TRIM(tb_shell_quote(ref%guess_cli%json_file)) + END IF log_file = TRIM(file_base)//".guess.log" command = TRIM(tb_shell_quote(ref%program_name))// & " guess --charge "//TRIM(ADJUSTL(charge_str))// & @@ -4367,38 +4390,44 @@ CONTAINS " "//TRIM(tb_shell_quote(guess_input))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "guess", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) & + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) THEN CALL tb_delete_file(ref%guess_cli%json_file) + END IF END IF IF (ref%param_cli%enabled) THEN method_str = "" - IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) & + IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) THEN method_str = " --method "// & TRIM(tb_reference_method_name(MERGE(ref%param_cli%method, & dft_control%qs_control%xtb_control%tblite_method, & ref%param_cli%method_explicit))) + END IF output_str = "" - IF (LEN_TRIM(ref%param_cli%output_file) > 0) & + IF (LEN_TRIM(ref%param_cli%output_file) > 0) THEN output_str = " --output "//TRIM(tb_shell_quote(ref%param_cli%output_file)) + END IF log_file = TRIM(file_base)//".param.log" command = TRIM(tb_shell_quote(ref%program_name))//" param"// & TRIM(method_str)// & TRIM(output_str) - IF (LEN_TRIM(ref%param_cli%input_file) > 0) & + IF (LEN_TRIM(ref%param_cli%input_file) > 0) THEN command = TRIM(command)//" "//TRIM(tb_shell_quote(ref%param_cli%input_file)) + END IF command = TRIM(command)//" > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "param", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) & + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) THEN CALL tb_delete_file(ref%param_cli%output_file) + END IF END IF IF (ref%fit_cli%enabled) THEN dry_run_str = "" IF (ref%fit_cli%dry_run) dry_run_str = " --dry-run" copy_str = "" - IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) & + IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN copy_str = " --copy "//TRIM(tb_shell_quote(ref%fit_cli%copy_file)) + END IF log_file = TRIM(file_base)//".fit.log" command = TRIM(tb_shell_quote(ref%program_name))//" fit"// & TRIM(dry_run_str)// & @@ -4407,8 +4436,9 @@ CONTAINS " "//TRIM(tb_shell_quote(ref%fit_cli%input_file))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "fit", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) & + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN CALL tb_delete_file(ref%fit_cli%copy_file) + END IF END IF IF (ref%tagdiff_cli%enabled) THEN @@ -4740,8 +4770,9 @@ CONTAINS CALL tb_delete_file(grad_file) CALL tb_delete_file(json_file) CALL tb_delete_file(log_file) - IF (LEN_TRIM(post_processing_output_file) > 0) & + IF (LEN_TRIM(post_processing_output_file) > 0) THEN CALL tb_delete_file(post_processing_output_file) + END IF END SUBROUTINE tb_reference_cleanup diff --git a/src/tblite_scc_mixer.F b/src/tblite_scc_mixer.F index 237f33576f..84a6bf6d4b 100644 --- a/src/tblite_scc_mixer.F +++ b/src/tblite_scc_mixer.F @@ -220,7 +220,7 @@ CONTAINS ALLOCATE (beta(MIN(memory, itn), MIN(memory, itn)), c(MIN(memory, itn), 1)) - omega(it1) = SQRT(DOT_PRODUCT(dq, dq)) + omega(it1) = NORM2(dq) IF (omega(it1) > (wfac/maxw)) THEN omega(it1) = wfac/omega(it1) ELSE @@ -229,7 +229,7 @@ CONTAINS IF (omega(it1) < minw) omega(it1) = minw df(:, it1) = dq - dqlast - inv = MAX(SQRT(DOT_PRODUCT(df(:, it1), df(:, it1))), EPSILON(1.0_wp)) + inv = MAX(NORM2(df(:, it1)), EPSILON(1.0_wp)) inv = 1.0_wp/inv df(:, it1) = inv*df(:, it1) diff --git a/src/tblite_types.F b/src/tblite_types.F index 5fb1e505c7..5ed92fa276 100644 --- a/src/tblite_types.F +++ b/src/tblite_types.F @@ -133,16 +133,21 @@ CONTAINS IF (ALLOCATED(tb_tblite%dcndr)) DEALLOCATE (tb_tblite%dcndr) IF (ALLOCATED(tb_tblite%dcndL)) DEALLOCATE (tb_tblite%dcndL) - IF (ASSOCIATED(tb_tblite%dipbra)) & + IF (ASSOCIATED(tb_tblite%dipbra)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%dipbra) - IF (ASSOCIATED(tb_tblite%dipket)) & + END IF + IF (ASSOCIATED(tb_tblite%dipket)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%dipket) - IF (ASSOCIATED(tb_tblite%quadbra)) & + END IF + IF (ASSOCIATED(tb_tblite%quadbra)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%quadbra) - IF (ASSOCIATED(tb_tblite%quadket)) & + END IF + IF (ASSOCIATED(tb_tblite%quadket)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%quadket) - IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) & + END IF + IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%rho_ao_kp_ref) + END IF #if defined(__TBLITE) IF (ALLOCATED(tb_tblite%mixer)) DEALLOCATE (tb_tblite%mixer) IF (ALLOCATED(tb_tblite%param)) DEALLOCATE (tb_tblite%param) diff --git a/src/tmc/tmc_analysis.F b/src/tmc/tmc_analysis.F index 574ef635c3..a8dfda06b5 100644 --- a/src/tmc/tmc_analysis.F +++ b/src/tmc/tmc_analysis.F @@ -118,13 +118,15 @@ CONTAINS CALL section_vals_val_get(tmc_ana_section, "DENSITY", i_vals=i_arr_tmp) IF (SIZE(i_arr_tmp(:)) == 3) THEN - IF (ANY(i_arr_tmp(:) <= 0)) & + IF (ANY(i_arr_tmp(:) <= 0)) THEN CALL cp_abort(__LOCATION__, "The amount of intervals in each "// & "direction has to be greater than 0.") + END IF nr_bins(:) = i_arr_tmp(:) ELSE IF (SIZE(i_arr_tmp(:)) == 1) THEN - IF (ANY(i_arr_tmp(:) <= 0)) & + IF (ANY(i_arr_tmp(:) <= 0)) THEN CPABORT("The amount of intervals has to be greater than 0.") + END IF nr_bins(:) = i_arr_tmp(1) ELSE IF (SIZE(i_arr_tmp(:)) == 0) THEN nr_bins(:) = 1 @@ -250,13 +252,15 @@ CONTAINS END IF ! init radial distribution function - IF (ASSOCIATED(ana_env%pair_correl)) & + IF (ASSOCIATED(ana_env%pair_correl)) THEN CALL ana_pair_correl_init(ana_pair_correl=ana_env%pair_correl, & atoms=ana_env%atoms, cell=ana_env%cell) + END IF ! init classical dipole moment calculations - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN CALL ana_dipole_moment_init(ana_dip_mom=ana_env%dip_mom, & atoms=ana_env%atoms) + END IF END SUBROUTINE analysis_init ! ************************************************************************************************** @@ -484,18 +488,21 @@ CONTAINS IF (weight_act > 0) THEN ! calculates the 3 dimensional distributed density - IF (ASSOCIATED(ana_env%density_3d)) & + IF (ASSOCIATED(ana_env%density_3d)) THEN CALL calc_density_3d(elem=ana_env%last_elem, & weight=weight_act, atoms=ana_env%atoms, & ana_env=ana_env) + END IF ! calculated the radial distribution function for each atom type - IF (ASSOCIATED(ana_env%pair_correl)) & + IF (ASSOCIATED(ana_env%pair_correl)) THEN CALL calc_paircorrelation(elem=ana_env%last_elem, weight=weight_act, & atoms=ana_env%atoms, ana_env=ana_env) + END IF ! calculates the classical dipole moments - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN CALL calc_dipole_moment(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) + END IF ! calculates the dipole moments analysis and dielectric constant IF (ASSOCIATED(ana_env%dip_ana)) THEN ! in symmetric case use also the dipoles @@ -504,64 +511,72 @@ CONTAINS ! (-x,y,z) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(3) = -ana_env%last_elem%dipole(3) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(3) = -ana_env%dip_mom%last_dip_cl(3) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(:) = -ana_env%last_elem%dipole(:) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(:) = -ana_env%dip_mom%last_dip_cl(:) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! back to (x,y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) + END IF END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) @@ -600,24 +615,29 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) IF (ASSOCIATED(ana_env%density_3d)) THEN - IF (ana_env%density_3d%conf_counter > 0) & + IF (ana_env%density_3d%conf_counter > 0) THEN CALL print_density_3d(ana_env=ana_env) + END IF END IF IF (ASSOCIATED(ana_env%pair_correl)) THEN - IF (ana_env%pair_correl%conf_counter > 0) & + IF (ana_env%pair_correl%conf_counter > 0) THEN CALL print_paircorrelation(ana_env=ana_env) + END IF END IF IF (ASSOCIATED(ana_env%dip_mom)) THEN - IF (ana_env%dip_mom%conf_counter > 0) & + IF (ana_env%dip_mom%conf_counter > 0) THEN CALL print_dipole_moment(ana_env) + END IF END IF IF (ASSOCIATED(ana_env%dip_ana)) THEN - IF (ana_env%dip_ana%conf_counter > 0) & + IF (ana_env%dip_ana%conf_counter > 0) THEN CALL print_dipole_analysis(ana_env) + END IF END IF IF (ASSOCIATED(ana_env%displace)) THEN - IF (ana_env%displace%conf_counter > 0) & + IF (ana_env%displace%conf_counter > 0) THEN CALL print_average_displacement(ana_env) + END IF END IF ! end the timing @@ -691,16 +711,18 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=elem) END IF ! if there was no previous element, create a new temp element to write in - IF (.NOT. ASSOCIATED(elem)) & + IF (.NOT. ASSOCIATED(elem)) THEN CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & nr_dim=nr_dim) + END IF END DO conf_loop END IF ! close the files CALL analyse_files_close(tmc_ana=ana_env) - IF (ASSOCIATED(elem)) & + IF (ASSOCIATED(elem)) THEN CALL deallocate_sub_tree_node(tree_elem=elem) + END IF ! end the timing CALL timestop(handle) @@ -843,11 +865,12 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) & + IF (.NOT. flag) THEN WRITE (file_ptr, FMT='(A8,11A20)') "# conf_nr", "dens_act[g/cm^3]", & - "dens_average[g/cm^3]", "density_variance", & - "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & - "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" + "dens_average[g/cm^3]", "density_variance", & + "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & + "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" + END IF WRITE (file_ptr, FMT="(I8,11F20.10)") ana_env%density_3d%conf_counter + 1 - weight, & SUM(mass_bin(:, :, :))/vol_sub_box/SIZE(mass_bin(:, :, :)), & SUM(ana_env%density_3d%sum_density(:, :, :))/ & @@ -975,11 +998,12 @@ CONTAINS SIZE(ana_env%density_3d%sum_density(:, :, :))/ & REAL(ana_env%density_3d%conf_counter, KIND=dp))**2) WRITE (ana_env%io_unit, FMT="(/,T2,A)") REPEAT("-", 79) - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (ana_env%io_unit, *) "TMC|ANALYSIS_CELL_DENSITY_X= ", & - SUM(ana_env%density_3d%sum_density(:, :, :))/ & - SIZE(ana_env%density_3d%sum_density(:, :, :))/ & - REAL(ana_env%density_3d%conf_counter, KIND=dp) + SUM(ana_env%density_3d%sum_density(:, :, :))/ & + SIZE(ana_env%density_3d%sum_density(:, :, :))/ & + REAL(ana_env%density_3d%conf_counter, KIND=dp) + END IF ! end the timing CALL timestop(handle) END SUBROUTINE print_density_3d @@ -1175,12 +1199,13 @@ CONTAINS END DO CALL close_file(unit_number=file_ptr) - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (*, *) "TMC|ANALYSIS_G_R_"// & - TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & - TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & - SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & - voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) + TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & + TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & + SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & + voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) + END IF END DO ! end the timing @@ -1297,9 +1322,10 @@ CONTAINS SUBROUTINE print_dipole_moment(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (*, *) "TMC|ANALYSIS_FINAL_CLASS_CELL_DIPOLE_MOMENT_X= ", & - ana_env%dip_mom%last_dip_cl(:) + ana_env%dip_mom%last_dip_cl(:) + END IF END SUBROUTINE print_dipole_moment ! ************************************************************************************************** @@ -1327,8 +1353,9 @@ CONTAINS CPASSERT(ASSOCIATED(ana_env%dip_ana)) weight_act = weight - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN weight_act = weight_act/REAL(8.0, KIND=dp) + END IF ! get the volume ALLOCATE (scaled_cell) @@ -1521,12 +1548,14 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "temperature ", cp_to_string(ana_env%temperature) WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "used configurations ", & cp_to_string(REAL(ana_env%dip_ana%conf_counter, KIND=dp)) - IF (ana_env%dip_ana%ana_type == ana_type_ice) & + IF (ana_env%dip_ana%ana_type == ana_type_ice) THEN WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with directions of hexagonal structure" - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & + "ice analysis with directions of hexagonal structure" + END IF + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with symmetrized dipoles in each direction." + "ice analysis with symmetrized dipoles in each direction." + END IF WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "for product of 2 directions(per vol):" DO i = 1, 3 @@ -1607,8 +1636,9 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) & + IF (.NOT. flag) THEN WRITE (file_ptr, *) "# conf squared deviation of the cell" + END IF WRITE (file_ptr, *) elem%nr, disp CALL close_file(unit_number=file_ptr) END IF @@ -1638,9 +1668,10 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "cell root mean square deviation: ", & cp_to_string(SQRT(ana_env%displace%disp/ & REAL(ana_env%displace%conf_counter, KIND=dp))) - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (*, *) "TMC|ANALYSIS_AVERAGE_CELL_DISPLACEMENT_X= ", & - SQRT(ana_env%displace%disp/ & - REAL(ana_env%displace%conf_counter, KIND=dp)) + SQRT(ana_env%displace%disp/ & + REAL(ana_env%displace%conf_counter, KIND=dp)) + END IF END SUBROUTINE print_average_displacement END MODULE tmc_analysis diff --git a/src/tmc/tmc_analysis_types.F b/src/tmc/tmc_analysis_types.F index 140aeeeb15..49bd263e20 100644 --- a/src/tmc/tmc_analysis_types.F +++ b/src/tmc/tmc_analysis_types.F @@ -156,22 +156,28 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_ana)) - IF (ASSOCIATED(tmc_ana%dirs)) & + IF (ASSOCIATED(tmc_ana%dirs)) THEN DEALLOCATE (tmc_ana%dirs) + END IF - IF (ASSOCIATED(tmc_ana%density_3d)) & + IF (ASSOCIATED(tmc_ana%density_3d)) THEN CALL tmc_ana_dens_release(tmc_ana%density_3d) - IF (ASSOCIATED(tmc_ana%pair_correl)) & + END IF + IF (ASSOCIATED(tmc_ana%pair_correl)) THEN CALL tmc_ana_pair_correl_release(tmc_ana%pair_correl) + END IF - IF (ASSOCIATED(tmc_ana%dip_mom)) & + IF (ASSOCIATED(tmc_ana%dip_mom)) THEN CALL tmc_ana_dipole_moment_release(tmc_ana%dip_mom) + END IF - IF (ASSOCIATED(tmc_ana%dip_ana)) & + IF (ASSOCIATED(tmc_ana%dip_ana)) THEN CALL tmc_ana_dipole_analysis_release(tmc_ana%dip_ana) + END IF - IF (ASSOCIATED(tmc_ana%displace)) & + IF (ASSOCIATED(tmc_ana%displace)) THEN CALL tmc_ana_displacement_release(ana_disp=tmc_ana%displace) + END IF DEALLOCATE (tmc_ana) diff --git a/src/tmc/tmc_calculations.F b/src/tmc/tmc_calculations.F index e0d9a91e12..cb0b3bba1b 100644 --- a/src/tmc/tmc_calculations.F +++ b/src/tmc/tmc_calculations.F @@ -178,8 +178,9 @@ CONTAINS tmp_cell%hmat(:, 3) = tmp_cell%hmat(:, 3)*box_scale(3) CALL init_cell(cell=tmp_cell) - IF (PRESENT(scaled_hmat)) & + IF (PRESENT(scaled_hmat)) THEN scaled_hmat(:, :) = tmp_cell%hmat + END IF IF (PRESENT(vec)) THEN vec = pbc(r=vec, cell=tmp_cell) @@ -611,9 +612,10 @@ CONTAINS eff(:) = 0.0_dp DO i = 1, tmc_env%params%nr_temp - IF (tmc_env%m_env%tree_node_count(i) > 0) & + IF (tmc_env%m_env%tree_node_count(i) > 0) THEN eff(i) = tmc_env%params%move_types%mv_count(0, i)/ & (tmc_env%m_env%tree_node_count(i)*1.0_dp) + END IF eff(0) = eff(0) + tmc_env%params%move_types%mv_count(0, i)/ & (SUM(tmc_env%m_env%tree_node_count(1:))*1.0_dp) END DO diff --git a/src/tmc/tmc_cancelation.F b/src/tmc/tmc_cancelation.F index 086541c7ea..a0a5bf800a 100644 --- a/src/tmc/tmc_cancelation.F +++ b/src/tmc/tmc_cancelation.F @@ -97,8 +97,9 @@ CONTAINS //cp_to_string(elem%stat)) END SELECT ! set dot color - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=elem, tmc_params=tmc_env%params) + END IF ! add to list IF (need_to_cancel) THEN diff --git a/src/tmc/tmc_dot_tree.F b/src/tmc/tmc_dot_tree.F index b231aaa2af..936874ff42 100644 --- a/src/tmc/tmc_dot_tree.F +++ b/src/tmc/tmc_dot_tree.F @@ -339,10 +339,11 @@ CONTAINS END IF IF (.NOT. ASSOCIATED(new_element%parent)) THEN - IF (new_element%nr > 1) & + IF (new_element%nr > 1) THEN CALL cp_warn(__LOCATION__, & "try to create dot, but no parent on node "// & cp_to_string(new_element%nr)//"exists") + END IF ELSE CALL create_dot_branch(parent_nr=new_element%parent%nr, & child_nr=new_element%nr, & diff --git a/src/tmc/tmc_file_io.F b/src/tmc/tmc_file_io.F index 6aa7d1b0f0..71053815d2 100644 --- a/src/tmc/tmc_file_io.F +++ b/src/tmc/tmc_file_io.F @@ -301,10 +301,11 @@ CONTAINS CALL open_file(file_name=file_name, file_status="OLD", file_form="UNFORMATTED", & file_action="READ", unit_number=file_ptr) READ (file_ptr) temp_size - IF (temp_size /= SIZE(tmc_env%params%Temp)) & + IF (temp_size /= SIZE(tmc_env%params%Temp)) THEN CALL cp_abort(__LOCATION__, & "the actual specified temperatures does not "// & "fit in amount with the one from restart file ") + END IF ALLOCATE (tmp_temp(temp_size)) READ (file_ptr) tmp_temp(:), & tmc_env%m_env%gt_act%nr, & @@ -323,9 +324,10 @@ CONTAINS job_counts, & timings - IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) & + IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) THEN CALL cp_abort(__LOCATION__, "the temperatures differ from the previous calculation. "// & "There were the following temperatures used:") + END IF IF (ANY(mv_weight_tmp(:) /= tmc_env%params%move_types%mv_weight(:))) THEN CPWARN("The amount of mv types differs between the original and the restart run.") END IF @@ -722,13 +724,14 @@ CONTAINS ! write the different energies ! TODO if necessary - IF (files_conf_missmatch) & + IF (files_conf_missmatch) THEN CALL cp_warn(__LOCATION__, & 'there is a missmatch in the configuration numbering. '// & "Read number of lines (pos|cell|dip)"// & cp_to_string(tmc_ana%lc_traj)//"|"// & cp_to_string(tmc_ana%lc_cell)//"|"// & cp_to_string(tmc_ana%lc_dip)) + END IF ! end the timing CALL timestop(handle) @@ -769,20 +772,22 @@ CONTAINS c_tmp(:) = " " tmc_ana%lc_traj = tmc_ana%lc_traj + 1 READ (tmc_ana%id_traj, '(A)', IOSTAT=status) c_tmp(:) - IF (status > 0) & + IF (status > 0) THEN CALL cp_abort(__LOCATION__, & "configuration header read error at line: "// & cp_to_string(tmc_ana%lc_traj)//": "//c_tmp) + END IF IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK EXIT search_next_conf END IF IF (INDEX(c_tmp, "=") > 0) THEN READ (c_tmp(INDEX(c_tmp, "=") + 1:), *, IOSTAT=status) i_tmp ! read the configuration number - IF (status /= 0) & + IF (status /= 0) THEN CALL cp_abort(__LOCATION__, & "configuration header read error (for conf nr) at line: "// & cp_to_string(tmc_ana%lc_traj)) + END IF IF (i_tmp > conf_nr) THEN ! TODO we could also read the energy ... conf_nr = i_tmp @@ -914,8 +919,9 @@ CONTAINS IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE IF (status > 0) THEN - IF (status /= 0) & + IF (status /= 0) THEN CPABORT("configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell)) + END IF stat = TMC_STATUS_FAILED ELSE IF (elem%nr < 0) elem%nr = conf_nr diff --git a/src/tmc/tmc_master.F b/src/tmc/tmc_master.F index 20811cce10..b93d15d0eb 100644 --- a/src/tmc/tmc_master.F +++ b/src/tmc/tmc_master.F @@ -135,9 +135,10 @@ CONTAINS CPASSERT(stat /= TMC_STATUS_FAILED) CPASSERT(work_list(wg)%elem%stat /= status_calc_approx_ener) - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: cancel group "//cp_to_string(wg) + "TMC|master: cancel group "//cp_to_string(wg) + END IF CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=para_env, tmc_params=tmc_env%params) work_list(wg)%canceled = .TRUE. @@ -247,8 +248,9 @@ CONTAINS walltime_offset = 20 ! default value the whole program needs to finalize ! initialize the different modules - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL init_draw_trees(tmc_params=tmc_env%params) + END IF !-- initialize variables ! nr_of_job: counting the different task send / received @@ -284,10 +286,11 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_params=tmc_env%params, & elem=init_conf, success=flag, wait_for_message=.TRUE.) - IF (stat /= TMC_STAT_START_CONF_RESULT) & + IF (stat /= TMC_STAT_START_CONF_RESULT) THEN CALL cp_abort(__LOCATION__, & "receiving start configuration failed, received stat "// & cp_to_string(stat)) + END IF ! get the atom names from first energy worker CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & @@ -299,10 +302,11 @@ CONTAINS CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%move_types, & mol_array=init_conf%mol) - IF (ASSOCIATED(tmc_env%params%nmc_move_types)) & + IF (ASSOCIATED(tmc_env%params%nmc_move_types)) THEN CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%nmc_move_types, & mol_array=init_conf%mol) + END IF ! set initial configuration ! set initial random number generator seed (rng seed) @@ -348,15 +352,17 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=init_conf) ! regtest output - IF (tmc_env%params%print_test_output .OR. DEBUG > 0) & + IF (tmc_env%params%print_test_output .OR. DEBUG > 0) THEN WRITE (tmc_env%m_env%io_unit, *) "TMC|first_global_tree_rnd_nr_X= ", & - tmc_env%m_env%gt_head%rnd_nr + tmc_env%m_env%gt_head%rnd_nr + END IF ! calculate the approx energy of the first element (later the exact) IF (tmc_env%m_env%gt_head%conf(1)%elem%stat == status_calc_approx_ener) THEN wg = 1 - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN wg = tmc_env%tmc_comp_set%group_ener_nr + 1 + END IF stat = TMC_STAT_APPROX_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -391,27 +397,30 @@ CONTAINS IF (flag .EQV. .FALSE.) EXIT worker_request_loop ! messages from worker group could be faster then the canceling request IF (worker_info(wg)%canceled .AND. (stat /= TMC_CANCELING_RECEIPT)) THEN - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: recv stat "//cp_to_string(stat)// & - " of canceled worker group" + "TMC|master: recv stat "//cp_to_string(stat)// & + " of canceled worker group" + END IF CYCLE worker_request_loop END IF ! in case of parallel tempering canceled element could be reactivated, ! calculated faster and deleted - IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) & + IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) THEN CALL cp_abort(__LOCATION__, & "no tree elem exist when receiving stat "// & cp_to_string(stat)//"of group"//cp_to_string(wg)) + END IF - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: received stat "//cp_to_string(stat)// & - " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & - " elem"//cp_to_string(worker_info(wg)%elem%nr)// & - " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & - " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled + "TMC|master: received stat "//cp_to_string(stat)// & + " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & + " elem"//cp_to_string(worker_info(wg)%elem%nr)// & + " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & + " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled + END IF SELECT CASE (stat) ! -- FAILED -------------------------- CASE (TMC_STATUS_FAILED) @@ -539,8 +548,9 @@ CONTAINS worker_info(wg)%start_time = m_walltime() - worker_info(wg)%start_time CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay) - IF (.NOT. worker_info(wg)%canceled) & + IF (.NOT. worker_info(wg)%canceled) THEN worker_info(wg)%busy = .FALSE. + END IF ! the first node in tree is always accepted.!. IF (ASSOCIATED(worker_info(wg)%elem, init_conf)) THEN !-- distribute energy of first element to all subtrees @@ -555,9 +565,10 @@ CONTAINS init_conf => NULL() ELSE worker_info(wg)%elem%stat = status_calculated - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(worker_info(wg)%elem, & tmc_params=tmc_env%params) + END IF ! check acceptance of depending nodes ! first (initial) configuration do not have to be checked CALL check_acceptance_of_depending_subtree_nodes(tree_elem=worker_info(wg)%elem, & @@ -578,11 +589,12 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & cancel_count=cancel_count) - IF (DEBUG >= 9) & + IF (DEBUG >= 9) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: handled energy result of sub tree ", & - worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & - " with stat", worker_info(wg)%elem%stat + "TMC|master: handled energy result of sub tree ", & + worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & + " with stat", worker_info(wg)%elem%stat + END IF worker_info(wg)%elem => NULL() !-- SCF ENERGY ----------------------- @@ -610,11 +622,12 @@ CONTAINS !-- do tree update (check new results) CALL tree_update(tmc_env=tmc_env, result_acc=flag, & something_updated=l_update_tree) - IF (DEBUG >= 2 .AND. l_update_tree) & + IF (DEBUG >= 2 .AND. l_update_tree) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: tree updated "//cp_to_string(l_update_tree)// & - " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & - " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) + "TMC|master: tree updated "//cp_to_string(l_update_tree)// & + " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & + " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) + END IF CALL send_analysis_tasks(ana_list=tmc_env%m_env%analysis_list, & ana_worker_info=ana_worker_info, & @@ -642,13 +655,15 @@ CONTAINS "(incl. delay", walltime_delay, "and offset", walltime_offset, ") left" ELSE ! calculations finished - IF (tmc_env%params%print_test_output) & + IF (tmc_env%params%print_test_output) THEN WRITE (tmc_env%m_env%io_unit, *) "Total energy: ", & - tmc_env%m_env%result_list(1)%elem%potential + tmc_env%m_env%result_list(1)%elem%potential + END IF END IF - IF (tmc_env%m_env%restart_out_step /= 0) & + IF (tmc_env%m_env%restart_out_step /= 0) THEN CALL print_restart_file(tmc_env=tmc_env, job_counts=nr_of_job, & timings=worker_timings_aver) + END IF EXIT task_loop END IF @@ -656,9 +671,10 @@ CONTAINS ! update the rest of the tree (canceling and deleting elements) ! ======================================================================= IF (l_update_tree) THEN - IF (DEBUG >= 2) & + IF (DEBUG >= 2) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: start remove elem and cancel calculation" + "TMC|master: start remove elem and cancel calculation" + END IF !-- CLEANING tree nodes beside the path through the tree from ! end_of_clean_tree to tree_ptr ! --> getting back the end of clean tree @@ -680,13 +696,15 @@ CONTAINS worker_counter = worker_counter + 1 wg = MODULO(worker_counter, tmc_env%tmc_comp_set%para_env_m_w%num_pe - 1) + 1 - IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) & + IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) THEN WRITE (tmc_env%m_env%io_unit, *) "all workers are busy" + END IF IF (.NOT. worker_info(wg)%busy) THEN - IF (DEBUG >= 13) & + IF (DEBUG >= 13) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: search new task for worker ", wg + "TMC|master: search new task for worker ", wg + END IF ! no group separation IF (tmc_env%tmc_comp_set%group_cc_nr <= 0) THEN ! search next element to calculate the energy @@ -698,7 +716,7 @@ CONTAINS new_elem=gt_elem_tmp, & reactivation_cc_count=reactivation_cc_count) END IF - ELSEIF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN + ELSE IF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN ! specialized groups (groups for exact energy and groups for configurational change) ! creating new element (configurational change group) !-- crate new node, configurational change is handled in tmc_tree module @@ -707,8 +725,9 @@ CONTAINS reactivation_cc_count=reactivation_cc_count) ! element could be already created, hence CC worker has nothing to do for this element ! in next round he will get a task - IF (stat == status_created .OR. stat == status_calculate_energy) & + IF (stat == status_created .OR. stat == status_calculate_energy) THEN stat = TMC_STATUS_WAIT_FOR_NEW_TASK + END IF ELSE ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & @@ -716,10 +735,11 @@ CONTAINS react_count=reactivation_ener_count) END IF - IF (DEBUG >= 10) & + IF (DEBUG >= 10) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: send task with elem stat "//cp_to_string(stat)// & - " to group "//cp_to_string(wg) + "TMC|master: send task with elem stat "//cp_to_string(stat)// & + " to group "//cp_to_string(wg) + END IF ! MESSAGE settings: status informations and task for communication SELECT CASE (stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -741,9 +761,10 @@ CONTAINS ! in case of parallel tempering the node can be already be calculating (related to another global tree node !-- send task to calculate system property gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem%stat = status_calculate_energy - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF stat = TMC_STAT_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -809,27 +830,30 @@ CONTAINS WRITE (tmc_env%m_env%io_unit, FMT=*) & "ener prepared ", tree_elem_counters END IF - IF (tmc_env%params%SPECULATIVE_CANCELING) & + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN WRITE (tmc_env%m_env%io_unit, *) & - "canceled cc|E: ", nr_of_job(5:6), & - ", reactivated: cc ", & - reactivation_cc_count, & - ", reactivated: E ", & - reactivation_ener_count + "canceled cc|E: ", nr_of_job(5:6), & + ", reactivated: cc ", & + reactivation_cc_count, & + ", reactivated: E ", & + reactivation_ener_count + END IF WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & " Average time for cc/ener calc ", & worker_timings_aver(1), worker_timings_aver(2) - IF (tmc_env%params%SPECULATIVE_CANCELING) & + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & - " Average time until cancel cc/ener calc ", & - worker_timings_aver(3), worker_timings_aver(4) - IF (tmc_env%params%esimate_acc_prob) & + " Average time until cancel cc/ener calc ", & + worker_timings_aver(3), worker_timings_aver(4) + END IF + IF (tmc_env%params%esimate_acc_prob) THEN WRITE (tmc_env%m_env%io_unit, *) & - "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & - tmc_env%m_env%estim_corr_wrong(1), & - tmc_env%m_env%estim_corr_wrong(3), " | ", & - tmc_env%m_env%estim_corr_wrong(2), & - tmc_env%m_env%estim_corr_wrong(4) + "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & + tmc_env%m_env%estim_corr_wrong(1), & + tmc_env%m_env%estim_corr_wrong(3), " | ", & + tmc_env%m_env%estim_corr_wrong(2), & + tmc_env%m_env%estim_corr_wrong(4) + END IF WRITE (tmc_env%m_env%io_unit, *) & "Time: ", INT(m_walltime() - run_time_start), "of", & INT(tmc_env%m_env%walltime - walltime_delay - walltime_offset), & @@ -869,10 +893,11 @@ CONTAINS " (MC elements/calculated configuration) global:", & efficiency(0), " sub tree(s): ", efficiency(1:) DEALLOCATE (efficiency) - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & - " (MC elements/created configuration) :", & - tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) + " (MC elements/created configuration) :", & + tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) + END IF WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & " (MC elements/energy calculated configuration):", & tmc_env%m_env%result_count(:)/REAL(nr_of_job(4), KIND=dp) @@ -909,8 +934,9 @@ CONTAINS CALL free_cancelation_list(tmc_env%m_env%cancelation_list) ! -- write final configuration - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL finalize_draw_tree(tmc_params=tmc_env%params) + END IF WRITE (tmc_env%m_env%io_unit, *) "TMC master: all work done." diff --git a/src/tmc/tmc_messages.F b/src/tmc/tmc_messages.F index 82b36f4bdb..26ae8e290c 100644 --- a/src/tmc/tmc_messages.F +++ b/src/tmc/tmc_messages.F @@ -88,8 +88,9 @@ CONTAINS CPASSERT(ASSOCIATED(para_env)) master = .FALSE. - IF (para_env%mepos == MASTER_COMM_ID) & + IF (para_env%mepos == MASTER_COMM_ID) THEN master = .TRUE. + END IF END FUNCTION check_if_group_master ! ************************************************************************************************** @@ -211,11 +212,12 @@ CONTAINS CPABORT("Unable to send message when m_send%info(4) > 0") !TODO send characters CALL para_env%send(m_send%task_char, dest, message_tag) END IF - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " send element info to ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:), " with comm ", & - para_env%get_handle(), " and tag ", message_tag + " send element info to ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:), " with comm ", & + para_env%get_handle(), " and tag ", message_tag + END IF IF (m_send%info(2) > 0) DEALLOCATE (m_send%task_int) IF (m_send%info(3) > 0) DEALLOCATE (m_send%task_real) IF (m_send%info(4) > 0) DEALLOCATE (m_send%task_char) @@ -290,10 +292,11 @@ CONTAINS ! first get message type and sizes CALL para_env%recv(m_send%info, dest, message_tag) END IF - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " recv element info from ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:) + " recv element info from ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:) + END IF !-- receive message integer part IF (m_send%info(2) > 0) THEN ALLOCATE (m_send%task_int(m_send%info(2))) @@ -350,14 +353,16 @@ CONTAINS CASE (TMC_STAT_ENERGY_REQUEST, TMC_STAT_APPROX_ENERGY_REQUEST) CALL read_energy_request_message(elem, m_send, tmc_params) CASE (TMC_STAT_ENERGY_RESULT) - IF (PRESENT(elem_array)) & + IF (PRESENT(elem_array)) THEN CALL read_energy_result_message(elem_array(dest)%elem, m_send, tmc_params) + END IF CASE (TMC_STAT_NMC_REQUEST, TMC_STAT_NMC_BROADCAST, & TMC_STAT_MD_REQUEST, TMC_STAT_MD_BROADCAST) CALL read_NMC_request_massage(msg_type, elem, m_send, tmc_params) CASE (TMC_STAT_NMC_RESULT, TMC_STAT_MD_RESULT) - IF (PRESENT(elem_array)) & + IF (PRESENT(elem_array)) THEN CALL read_NMC_result_massage(msg_type, elem_array(dest)%elem, m_send, tmc_params) + END IF CASE (TMC_STATUS_FAILED, TMC_STATUS_STOP_RECEIPT) ! if task is failed, handle situation in outer routine CASE (TMC_STAT_SCF_STEP_ENER_RECEIVE) @@ -1075,8 +1080,9 @@ CONTAINS counter = 0 !then float array with pos, (vel), random number seed, subbox_center msg_size_real = 1 + SIZE(elem%pos) + 1 + SIZE(elem%rng_seed) + 1 + SIZE(elem%subbox_center(:)) + 1 - IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) & - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) ! the velocities + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) THEN + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + END IF ! the velocities IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ! box size for NpT ALLOCATE (m_send%task_real(msg_size_real)) @@ -1214,9 +1220,10 @@ CONTAINS + 1 + SIZE(tmc_params%nmc_move_types%mv_count) & + 1 + SIZE(tmc_params%nmc_move_types%acc_count) + 1 IF (DEBUG > 0) msg_size_int = msg_size_int + 1 + 1 + 1 + 1 - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN msg_size_int = msg_size_int + 1 + SIZE(tmc_params%nmc_move_types%subbox_count) & + 1 + SIZE(tmc_params%nmc_move_types%subbox_acc_count) + END IF ALLOCATE (m_send%task_int(msg_size_int)) counter = 1 @@ -1270,8 +1277,9 @@ CONTAINS + 1 ! check bit IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & - msg_type == TMC_STAT_MD_BROADCAST) & - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 ! for MD also: vel, e_kin_befor_md, ekin + msg_type == TMC_STAT_MD_BROADCAST) THEN + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 + END IF ! for MD also: vel, e_kin_befor_md, ekin ALLOCATE (m_send%task_real(msg_size_real)) ! pos @@ -1400,8 +1408,9 @@ CONTAINS msg_type == TMC_STAT_MD_BROADCAST) THEN elem%vel = m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) - IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) & + IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) THEN elem%ekin_before_md = m_send%task_real(counter + 1) + END IF counter = counter + 2 elem%ekin = m_send%task_real(counter + 1) counter = counter + 2 @@ -1415,8 +1424,9 @@ CONTAINS END IF DEALLOCATE (mv_counter, acc_counter) - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN DEALLOCATE (subbox_counter, subbox_acc_counter) + END IF CPASSERT(counter == m_send%info(3)) CPASSERT(m_send%task_int(m_send%info(2)) == message_end_flag) CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) @@ -1564,7 +1574,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_string_length), & - ALLOCATABLE, DIMENSION(:) :: msg(:) + ALLOCATABLE, DIMENSION(:) :: msg INTEGER :: i CPASSERT(ASSOCIATED(para_env)) diff --git a/src/tmc/tmc_move_handle.F b/src/tmc/tmc_move_handle.F index 6354703e49..cfa8ab5b31 100644 --- a/src/tmc/tmc_move_handle.F +++ b/src/tmc/tmc_move_handle.F @@ -114,22 +114,25 @@ CONTAINS CALL section_vals_get(nmc_section, explicit=explicit) IF (explicit) THEN ! check the approx potential file, already read - IF (tmc_params%NMC_inp_file == "") & + IF (tmc_params%NMC_inp_file == "") THEN CPABORT("Please specify a valid approximate potential.") + END IF CALL section_vals_val_get(nmc_section, "NR_NMC_STEPS", & i_val=nmc_steps) - IF (nmc_steps <= 0) & + IF (nmc_steps <= 0) THEN CPABORT("Please specify a valid amount of NMC steps (NR_NMC_STEPS {INTEGER}).") + END IF CALL section_vals_val_get(nmc_section, "PROB", r_val=nmc_prob) CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", & r_val=nmc_init_acc_prob) - IF (nmc_init_acc_prob <= 0.0_dp) & + IF (nmc_init_acc_prob <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for INIT_ACC_PROB") + END IF move_type_section => section_vals_get_subs_vals(nmc_section, "MOVE_TYPE") CALL section_vals_get(move_type_section, n_repetition=n_NMC_items) @@ -150,10 +153,11 @@ CONTAINS ! initilaize the move array with related sizes, probs, etc. CALL move_types_create(tmc_params%move_types, tmc_params%nr_temp) - IF (mv_prob_sum <= 0.0) & + IF (mv_prob_sum <= 0.0) THEN CALL cp_abort(__LOCATION__, & "The probabilities to perform the moves are "// & "in total less equal 0") + END IF ! get the sizes, probs, etc. for each move type and convert units DO i_tmp = 1, n_items + n_NMC_items @@ -188,16 +192,18 @@ CONTAINS ! move sizes are checked afterwards, because not all moves require a valid move size CALL section_vals_val_get(move_type_section, "PROB", i_rep_section=i_rep, & r_val=mv_prob) - IF (mv_prob < 0.0_dp) & + IF (mv_prob < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid move probability (>0.0) "// & "for the move type "//inp_kind_name) + END IF CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", i_rep_section=i_rep, & r_val=init_acc_prob) - IF (init_acc_prob < 0.0_dp) & + IF (init_acc_prob < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for the move type "//inp_kind_name) + END IF ! set the related index and perform unit conversion of move sizes SELECT CASE (inp_kind_name) ! atom / molecule translation @@ -278,8 +284,9 @@ CONTAINS CALL section_vals_val_get(move_type_section, "ATOMS", & i_rep_section=i_rep, i_rep_val=i, & c_vals=move_types%atom_lists(i)%atoms) - IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) & + IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) THEN CPABORT("ATOM_SWAP requires minimum two atom kinds selected. ") + END IF END DO END IF ! gaussian adaptation @@ -290,10 +297,11 @@ CONTAINS CPABORT("A unknown move type is selected: "//inp_kind_name) END SELECT ! check for valid move sizes - IF (delta_x < 0.0_dp) & + IF (delta_x < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid move size (>0.0) "// & "for the move type "//inp_kind_name) + END IF ! check if not already set IF (move_types%mv_weight(ind) > 0.0) THEN CPABORT("TMC: Each move type can be set only once. ") @@ -341,11 +349,12 @@ CONTAINS move_types%mv_weight(mv_type_mol_rot) > 0.0_dp) THEN ! if there is no molecule information available, ! molecules moves can not be performed - IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) & + IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) THEN CALL cp_abort(__LOCATION__, & "molecule move: there is no molecule "// & "information available. Please specify molecules when "// & "using molecule moves.") + END IF END IF ! for the atom swap move @@ -363,11 +372,12 @@ CONTAINS EXIT ref_loop END IF END DO ref_loop - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "ATOM_SWAP: The selected atom type ("// & TRIM(move_types%atom_lists(list_i)%atoms(atom_j))// & ") is not contained in the system. ") + END IF ! check if not be swapped with the same atom type IF (ANY(move_types%atom_lists(list_i)%atoms(atom_j) == & move_types%atom_lists(list_i)%atoms(atom_j + 1:))) THEN @@ -389,10 +399,11 @@ CONTAINS END IF END DO ref_lop END IF - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "The system contains only a single atom type,"// & " atom_swap is not possible.") + END IF END IF END IF END SUBROUTINE check_moves @@ -408,8 +419,9 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_params)) CALL move_types_release(tmc_params%move_types) - IF (ASSOCIATED(tmc_params%nmc_move_types)) & + IF (ASSOCIATED(tmc_params%nmc_move_types)) THEN CALL move_types_release(tmc_params%nmc_move_types) + END IF END SUBROUTINE finalize_mv_types ! ************************************************************************************************** @@ -760,8 +772,9 @@ CONTAINS CPASSERT(PRESENT(acc)) IF (PRESENT(subbox)) THEN ! only update subbox acceptance - IF (acc) & + IF (acc) THEN move_types%subbox_acc_count(mv_type, conf_moved) = move_types%subbox_acc_count(mv_type, conf_moved) + 1 + END IF move_types%subbox_count(mv_type, conf_moved) = move_types%subbox_count(mv_type, conf_moved) + 1 ! No more to do change_type = 0 @@ -790,8 +803,9 @@ CONTAINS END IF IF (conf_moved > 0) move_types%mv_count(0, conf_moved) = move_types%mv_count(0, conf_moved) + ABS(change_res) - IF (mv_type >= 0 .AND. conf_moved > 0) & + IF (mv_type >= 0 .AND. conf_moved > 0) THEN move_types%mv_count(mv_type, conf_moved) = move_types%mv_count(mv_type, conf_moved) + ABS(change_type) + END IF IF (prob_opt) THEN WHERE (move_types%mv_count > 0) & diff --git a/src/tmc/tmc_moves.F b/src/tmc/tmc_moves.F index 3f24f4def5..a6e1aec153 100644 --- a/src/tmc/tmc_moves.F +++ b/src/tmc/tmc_moves.F @@ -124,8 +124,9 @@ CONTAINS ! rng_seed=elem%rng_seed, rng_seed_last_acc=last_acc_elem%rng_seed) !-- atom translation CASE (mv_type_atom_trans) - IF (act_nr_elem_mv == 0) & + IF (act_nr_elem_mv == 0) THEN act_nr_elem_mv = SIZE(elem%pos)/tmc_params%dim_per_elem + END IF ALLOCATE (elem_center(tmc_params%dim_per_elem)) i = 1 move_elements_loop: DO @@ -167,8 +168,9 @@ CONTAINS CASE (mv_type_mol_trans) nr_molec = MAXVAL(elem%mol(:)) ! if all particles should be displaced, set the amount of molecules - IF (act_nr_elem_mv == 0) & + IF (act_nr_elem_mv == 0) THEN act_nr_elem_mv = nr_molec + END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -181,8 +183,9 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) & + ) THEN mol_in_sb(m) = status_ok + END IF END DO ! displace the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -242,8 +245,9 @@ CONTAINS !-- molecule rotation CASE (mv_type_mol_rot) nr_molec = MAXVAL(elem%mol(:)) - IF (act_nr_elem_mv == 0) & + IF (act_nr_elem_mv == 0) THEN act_nr_elem_mv = nr_molec + END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -256,8 +260,9 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) & + ) THEN mol_in_sb(m) = status_ok + END IF END DO ! rotate the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -703,16 +708,18 @@ CONTAINS CALL find_nearest_proton_acceptor_donator(elem=elem, mol=mol, & donor_acceptor=donor_acceptor, tmc_params=tmc_params, & rng_stream=rng_stream) - IF (ANY(mol_arr(:) == mol)) & + IF (ANY(mol_arr(:) == mol)) THEN EXIT chain_completition_loop + END IF mol_arr(counter) = mol END DO chain_completition_loop counter = counter - 1 ! last searched element is equal to one other in list ! just take the loop of molecules out of the chain DO k = 1, counter - IF (mol_arr(k) == mol) & + IF (mol_arr(k) == mol) THEN EXIT + END IF END DO mol_arr(1:counter - k + 1) = mol_arr(k:counter) counter = counter - k + 1 diff --git a/src/tmc/tmc_setup.F b/src/tmc/tmc_setup.F index 5c6ec41642..f110e1c573 100644 --- a/src/tmc/tmc_setup.F +++ b/src/tmc/tmc_setup.F @@ -239,8 +239,9 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_energy_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CPABORT("creating force env result in error "//cp_to_string(ierr)) + END IF END IF ! worker for configurational change IF (tmc_env%params%NMC_inp_file /= "" .AND. & @@ -253,15 +254,18 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_NMC_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CPABORT("creating approx force env result in error "//cp_to_string(ierr)) + END IF END IF CALL do_tmc_worker(tmc_env=tmc_env) ! start the worker routine - IF (tmc_env%w_env%env_id_ener > 0) & + IF (tmc_env%w_env%env_id_ener > 0) THEN CALL destroy_force_env(tmc_env%w_env%env_id_ener, ierr) - IF (tmc_env%w_env%env_id_approx > 0) & + END IF + IF (tmc_env%w_env%env_id_approx > 0) THEN CALL destroy_force_env(tmc_env%w_env%env_id_approx, ierr) + END IF CALL cp_rm_default_logger() CALL cp_logger_release(logger_sub) @@ -296,8 +300,9 @@ CONTAINS END DO CALL do_tmc_worker(tmc_env=tmc_env, ana_list=tmc_ana_env_list) ! start the worker routine for analysis DO i = 1, tmc_env%params%nr_temp - IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) & + IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=tmc_ana_env_list(i)%temp%last_elem) + END IF CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp) END DO DEALLOCATE (tmc_ana_env_list) @@ -401,16 +406,19 @@ CONTAINS CALL analysis_init(ana_env=ana_list(temp)%temp, nr_dim=nr_dim) ! to allocate the dipole array in tree elements IF (ana_list(temp)%temp%costum_dip_file_name /= & - tmc_default_unspecified_name) & + tmc_default_unspecified_name) THEN tmc_env%params%print_dipole = .TRUE. + END IF - IF (.NOT. ASSOCIATED(elem)) & + IF (.NOT. ASSOCIATED(elem)) THEN CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=elem, nr_dim=nr_dim) + END IF CALL analysis_restart_read(ana_env=ana_list(temp)%temp, & elem=elem) - IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) & + IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CPABORT("uncorrect initialization of the initial configuration") + END IF ! do for all directories DO dir_ind = 1, SIZE(ana_list(temp)%temp%dirs) WRITE (output_unit, FMT='(T2,A,"| ",A,T41,A40)') "TMC_ANA", & @@ -424,25 +432,31 @@ CONTAINS ! remove the last saved element to start with a new file ! there is no weight for this element IF (dir_ind < SIZE(ana_list(temp)%temp%dirs) .AND. & - ASSOCIATED(ana_list(temp)%temp%last_elem)) & + ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + END IF + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN ana_list(temp)%temp%conf_offset = ana_list(temp)%temp%conf_offset & + ana_list(temp)%temp%last_elem%nr + END IF END DO CALL finalize_tmc_analysis(ana_env=ana_list(temp)%temp) ! write analysis restart file ! if there is something to write ! shifts the last element to actual element - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL analysis_restart_print(ana_env=ana_list(temp)%temp) - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + END IF + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - IF (ASSOCIATED(elem)) & + END IF + IF (ASSOCIATED(elem)) THEN CALL deallocate_sub_tree_node(tree_elem=elem) + END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) + END IF CALL tmc_ana_env_release(ana_list(temp)%temp) END DO @@ -499,8 +513,9 @@ CONTAINS CALL section_vals_val_get(tmc_section, "NR_TEMPERATURE", i_val=nr_temp) CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) & + IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) THEN CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") + END IF IF (nr_temp == 1) THEN nr_temp = SIZE(inp_Temp) ALLOCATE (Temps(nr_temp)) @@ -513,9 +528,10 @@ CONTAINS DO t_act = 2, SIZE(Temps) Temps(t_act) = Temps(t_act - 1) + (tmax - tmin)/(SIZE(Temps) - 1.0_dp) END DO - IF (ANY(Temps < 0.0_dp)) & + IF (ANY(Temps < 0.0_dp)) THEN CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") + END IF END IF ! get multiple directories @@ -596,13 +612,15 @@ CONTAINS CALL section_vals_val_get(tmc_section, "GROUP_ENERGY_NR", i_val=tmc_env%tmc_comp_set%group_ener_nr) CALL section_vals_val_get(tmc_section, "GROUP_CC_SIZE", i_val=tmc_env%tmc_comp_set%group_cc_size) CALL section_vals_val_get(tmc_section, "GROUP_ANALYSIS_NR", i_val=itmp) - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) & + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) THEN tmc_env%tmc_comp_set%ana_on_the_fly = itmp - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) & + END IF + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) THEN CALL cp_abort(__LOCATION__, & "analysing on the fly is up to now not supported for multiple cores. "// & "Restart file witing for this case and temperature "// & "distribution has to be solved.!.") + END IF CALL section_vals_val_get(tmc_section, "RESULT_LIST_IN_MEMORY", l_val=tmc_env%params%USE_REDUCED_TREE) ! swap the variable, because of oposit meaning tmc_env%params%USE_REDUCED_TREE = .NOT. tmc_env%params%USE_REDUCED_TREE @@ -615,21 +633,24 @@ CONTAINS CPABORT("no or a valid NMC input file has to be specified ") ELSE IF (tmc_env%params%NMC_inp_file == "") THEN ! no keyword - IF (tmc_env%tmc_comp_set%group_cc_size > 0) & + IF (tmc_env%tmc_comp_set%group_cc_size > 0) THEN CALL cp_warn(__LOCATION__, & "The configurational groups are deactivated, "// & "because no approximated energy input is specified.") + END IF tmc_env%tmc_comp_set%group_cc_size = 0 ELSE ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%NMC_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) & + IF (.NOT. flag .OR. itmp /= 0) THEN CPABORT("a valid NMC input file has to be specified") + END IF END IF CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) & + IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) THEN CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") + END IF IF (tmc_env%params%nr_temp == 1) THEN tmc_env%params%nr_temp = SIZE(inp_Temp) ALLOCATE (tmc_env%params%Temp(tmc_env%params%nr_temp)) @@ -642,9 +663,10 @@ CONTAINS DO itmp = 2, SIZE(tmc_env%params%Temp) tmc_env%params%Temp(itmp) = tmc_env%params%Temp(itmp - 1) + (tmax - tmin)/(SIZE(tmc_env%params%Temp) - 1.0_dp) END DO - IF (ANY(tmc_env%params%Temp < 0.0_dp)) & + IF (ANY(tmc_env%params%Temp < 0.0_dp)) THEN CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") + END IF END IF CALL section_vals_val_get(tmc_section, "TASK_TYPE", explicit=explicit_key) @@ -711,13 +733,14 @@ CONTAINS tmc_env%m_env%restart_out_file_name = tmc_default_restart_out_file_name tmc_env%m_env%restart_out_step = HUGE(tmc_env%m_env%restart_out_step) END IF - IF (tmc_env%m_env%restart_out_step < 0) & + IF (tmc_env%m_env%restart_out_step < 0) THEN CALL cp_abort(__LOCATION__, & "Please specify a valid value for the frequency "// & "to write restart files (RESTART_OUT #). "// & "# > 0 to define the amount of Markov chain elements in between, "// & "or 0 to deactivate the restart file writing. "// & "Lonely keyword writes restart file only at the end of the run.") + END IF CALL section_vals_val_get(tmc_section, "INFO_OUT_STEP_SIZE", i_val=tmc_env%m_env%info_out_step_size) CALL section_vals_val_get(tmc_section, "DOT_TREE", c_val=tmc_env%params%dot_file_name) @@ -734,13 +757,15 @@ CONTAINS ! the NMC_FILE_NAME is already read in tmc_preread_input CALL section_vals_val_get(tmc_section, "ENERGY_FILE_NAME", c_val=tmc_env%params%energy_inp_file) ! file name keyword without file name - IF (tmc_env%params%energy_inp_file == "") & + IF (tmc_env%params%energy_inp_file == "") THEN CPABORT("a valid exact energy input file has to be specified ") + END IF ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%energy_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) & + IF (.NOT. flag .OR. itmp /= 0) THEN CALL cp_abort(__LOCATION__, "a valid exact energy input file has to be specified, "// & TRIM(tmc_env%params%energy_inp_file)//" does not exist.") + END IF CALL section_vals_val_get(tmc_section, "NUM_MV_ELEM_IN_CELL", i_val=tmc_env%params%nr_elem_mv) @@ -751,10 +776,12 @@ CONTAINS CALL section_vals_val_get(tmc_section, "SUB_BOX", r_vals=r_arr_tmp) IF (SIZE(r_arr_tmp) > 1) THEN - IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) & + IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) THEN CPABORT("The entered sub box sizes does not fit in number of dimensions.") - IF (ANY(r_arr_tmp <= 0.0_dp)) & + END IF + IF (ANY(r_arr_tmp <= 0.0_dp)) THEN CPABORT("The entered sub box lengths should be greater than 0.") + END IF DO itmp = 1, SIZE(tmc_env%params%sub_box_size) tmc_env%params%sub_box_size(itmp) = r_arr_tmp(itmp)/au2a END DO @@ -774,14 +801,17 @@ CONTAINS CALL section_vals_val_get(tmc_section, "PRINT_ONLY_ACC", l_val=tmc_env%params%print_only_diff_conf) CALL section_vals_val_get(tmc_section, "PRINT_COORDS", l_val=tmc_env%params%print_trajectory) CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", l_val=tmc_env%params%print_dipole) + END IF CALL section_vals_val_get(tmc_section, "PRINT_FORCES", explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL section_vals_val_get(tmc_section, "PRINT_FORCES", l_val=tmc_env%params%print_forces) + END IF CALL section_vals_val_get(tmc_section, "PRINT_CELL", explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL section_vals_val_get(tmc_section, "PRINT_CELL", l_val=tmc_env%params%print_cell) + END IF CALL section_vals_val_get(tmc_section, "PRINT_ENERGIES", l_val=tmc_env%params%print_energies) END SUBROUTINE tmc_read_input @@ -850,9 +880,10 @@ CONTAINS - tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr)/ & REAL(tmc_comp_set%group_cc_size, KIND=dp)) - IF (tmc_comp_set%group_cc_nr < 1) & + IF (tmc_comp_set%group_cc_nr < 1) THEN CALL cp_warn(__LOCATION__, & "There are not enougth cores left for creating groups for configurational change.") + END IF IF (flag) success = .FALSE. END IF @@ -1010,9 +1041,10 @@ CONTAINS WRITE (file_nr, FMT=fmt_my) plabel, "cores per group (ener|cc) ", & cp_to_string(tmc_env%tmc_comp_set%group_ener_size)//" | "// & cp_to_string(tmc_env%tmc_comp_set%group_cc_size) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN WRITE (file_nr, FMT=fmt_my) plabel, "Analysis groups ", & - cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) + cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) + END IF IF (SIZE(tmc_env%params%Temp(:)) <= 7) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" @@ -1026,18 +1058,20 @@ CONTAINS cp_to_string(tmc_env%m_env%num_MC_elem) WRITE (file_nr, FMT=fmt_my) plabel, "exact potential input file:", & TRIM(tmc_env%params%energy_inp_file) - IF (tmc_env%params%NMC_inp_file /= "") & + IF (tmc_env%params%NMC_inp_file /= "") THEN WRITE (file_nr, FMT=fmt_my) plabel, "approximate potential input file:", & - TRIM(tmc_env%params%NMC_inp_file) + TRIM(tmc_env%params%NMC_inp_file) + END IF IF (ANY(tmc_env%params%sub_box_size > 0.0_dp)) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" WRITE (c_tmp, FMT="(1000F8.2)") tmc_env%params%sub_box_size(:)*au2a WRITE (file_nr, FMT=fmt_tmp) plabel, "Sub box size [A]", TRIM(c_tmp) END IF - IF (tmc_env%params%pressure > 0.0_dp) & + IF (tmc_env%params%pressure > 0.0_dp) THEN WRITE (file_nr, FMT=fmt_my) plabel, "Pressure [bar]: ", & - cp_to_string(tmc_env%params%pressure*au2bar) + cp_to_string(tmc_env%params%pressure*au2bar) + END IF WRITE (file_nr, FMT=fmt_my) plabel, "Numbers of atoms/molecules moved " WRITE (file_nr, FMT=fmt_my) plabel, " within one conf. change", & cp_to_string(tmc_env%params%nr_elem_mv) diff --git a/src/tmc/tmc_tree_acceptance.F b/src/tmc/tmc_tree_acceptance.F index 939f31563c..8a72ab56e6 100644 --- a/src/tmc/tmc_tree_acceptance.F +++ b/src/tmc/tmc_tree_acceptance.F @@ -490,9 +490,10 @@ CONTAINS END IF END IF - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot_color(gt_tree_element=tmp_gt_list_ptr%gt_elem, & tmc_params=tmc_env%params) + END IF END IF tmp_gt_list_ptr => tmp_gt_list_ptr%next END DO @@ -546,8 +547,9 @@ CONTAINS cp_to_string(stat)) END SELECT - IF (tmc_params%DRAW_TREE) & + IF (tmc_params%DRAW_TREE) THEN CALL create_dot_color(tree_element=ptr, tmc_params=tmc_params) + END IF END IF ! end the timing @@ -685,8 +687,9 @@ CONTAINS !-- hence new configurations can be created on basis of this configuration CASE (status_calculate_MD, status_calculate_NMC_steps, status_calculate_energy, & status_created, status_calc_approx_ener) - IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) & + IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) THEN gt_act_elem%stat = gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat + END IF CASE (status_calculated) CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -754,9 +757,10 @@ CONTAINS tmc_env%m_env%result_count(gt_act_elem%mv_conf) + 1 ! in case of swapped also count the result for ! the other swapped temperature - IF (gt_act_elem%swaped) & + IF (gt_act_elem%swaped) THEN tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) = & - tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 + tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 + END IF ! count also for global tree Markov Chain tmc_env%m_env%result_count(0) = tmc_env%m_env%result_count(0) + 1 @@ -816,14 +820,16 @@ CONTAINS END IF ! result acceptance check !====================================================================== !-- set status accepted or rejected of certain subtree elements - IF (.NOT. gt_act_elem%swaped) & + IF (.NOT. gt_act_elem%swaped) THEN CALL subtree_configuration_stat_change(gt_ptr=gt_act_elem, & stat=gt_act_elem%stat, & tmc_params=tmc_env%params) + END IF - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot_color(gt_tree_element=gt_act_elem, & tmc_params=tmc_env%params) + END IF ! probability update CALL prob_update(move_types=tmc_env%params%move_types, & @@ -835,11 +841,12 @@ CONTAINS result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf, accepted=result_acc, & tmc_params=tmc_env%params) - IF (gt_act_elem%swaped) & + IF (gt_act_elem%swaped) THEN CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf + 1, accepted=result_acc, & tmc_params=tmc_env%params) + END IF ! save for analysis IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1 .AND. result_acc) THEN @@ -879,8 +886,9 @@ CONTAINS ready = .FALSE. IF ((elem%scf_energies_count >= 4) & .AND. (elem%stat /= status_deleted) .AND. (elem%stat /= status_deleted_result) & - .AND. (elem%stat /= status_canceled_ener)) & + .AND. (elem%stat /= status_canceled_ener)) THEN ready = .TRUE. + END IF END FUNCTION ready_for_update_acc_prob ! ************************************************************************************************** @@ -1032,9 +1040,10 @@ CONTAINS IF (tmp_prob >= 0.0_dp) THEN tmp_pt_ptr%gt_elem%prob_acc = tmp_prob !-- speculative canceling for the related direction - IF (tmc_env%params%SPECULATIVE_CANCELING) & + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN CALL search_canceling_elements(pt_elem_in=tmp_pt_ptr%gt_elem, & prob=tmp_pt_ptr%gt_elem%prob_acc, tmc_env=tmc_env) + END IF END IF ! get next related global tree pointer diff --git a/src/tmc/tmc_tree_build.F b/src/tmc/tmc_tree_build.F index cea018160d..62a319f9c0 100644 --- a/src/tmc/tmc_tree_build.F +++ b/src/tmc/tmc_tree_build.F @@ -364,10 +364,11 @@ CONTAINS ! simulated annealing start temperature global_tree%Temp = tmc_env%params%Temp(1) - IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) & + IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "there is no parallel tempering implementation for simulated annealing implemented "// & "(just one Temp per global tree element.") + END IF !-- IF program is restarted, read restart file IF (tmc_env%m_env%restart_in_file_name /= "") THEN @@ -440,10 +441,12 @@ CONTAINS !-- distribute energy of first element to all subtrees DO i = 1, SIZE(gt_tree_ptr%conf) gt_tree_ptr%conf(i)%elem%stat = status_accepted_result - IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) & + IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) THEN gt_tree_ptr%conf(i)%elem%dipole = gt_tree_ptr%conf(1)%elem%dipole - IF (tmc_env%m_env%restart_in_file_name == "") & + END IF + IF (tmc_env%m_env%restart_in_file_name == "") THEN gt_tree_ptr%conf(i)%elem%potential = gt_tree_ptr%conf(1)%elem%potential + END IF END DO IF (tmc_env%m_env%restart_in_file_name == "") THEN @@ -538,10 +541,12 @@ CONTAINS ((.NOT. n_acc) .AND. ASSOCIATED(tmp_elem%nacc))) THEN !set pointer to the actual element - IF (n_acc) & + IF (n_acc) THEN new_elem => tmp_elem%acc - IF (.NOT. n_acc) & + END IF + IF (.NOT. n_acc) THEN new_elem => tmp_elem%nacc + END IF ! check for existing subtree element CPASSERT(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem)) @@ -570,10 +575,11 @@ CONTAINS CASE (mv_type_MD) new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_MD CASE (mv_type_NMC_moves) - IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) & + IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) THEN CALL cp_warn(__LOCATION__, & "reactivating tree element with wrong status"// & cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat)) + END IF new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_NMC_steps !IF(DEBUG>=1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & @@ -599,12 +605,14 @@ CONTAINS !-- set pointers to and from element one level up !-- paste new gt tree node element at right end IF (n_acc) THEN - IF (ASSOCIATED(tmp_elem%acc)) & + IF (ASSOCIATED(tmp_elem%acc)) THEN CPABORT("creating new subtree element on an occupied acc branch") + END IF tmp_elem%acc => new_elem ELSE - IF (ASSOCIATED(tmp_elem%nacc)) & + IF (ASSOCIATED(tmp_elem%nacc)) THEN CPABORT("creating new subtree element on an occupied nacc branch") + END IF tmp_elem%nacc => new_elem END IF new_elem%parent => tmp_elem @@ -687,9 +695,10 @@ CONTAINS new_elem%prob_acc = tmc_env%params%move_types%acc_prob( & mv_type_swap_conf, new_elem%mv_conf) CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) + END IF ! nothing to do for the workers stat = status_calculated keep_on = .FALSE. @@ -710,10 +719,11 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) + END IF END IF ELSE !-- check if child element in REJECTED direction already exist @@ -725,10 +735,11 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) + END IF END IF END IF ! set approximate probability of acceptance @@ -738,9 +749,10 @@ CONTAINS new_elem%conf(new_elem%mv_conf)%elem%move_type, new_elem%mv_conf) ! add refence and dot CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) + END IF END IF ! swap or no swap END IF ! global tree node already exist. Hence the Subtree node also (it is speculative canceled) END IF ! keep on (checking and creating) @@ -749,8 +761,9 @@ CONTAINS IF (new_elem%stat == status_accepted_result .OR. & new_elem%stat == status_accepted .OR. & new_elem%stat == status_rejected .OR. & - new_elem%stat == status_rejected_result) & + new_elem%stat == status_rejected_result) THEN CPABORT("selected existing RESULT gt node") + END IF !-- set status of global tree element for decision in master routine SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat) CASE (status_rejected_result, status_rejected, status_accepted, & @@ -758,16 +771,18 @@ CONTAINS ! energy is already calculated new_elem%stat = status_calculated stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF CASE (status_calc_approx_ener) new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF END IF CASE (status_calculate_MD, status_calculate_energy, & status_calculate_NMC_steps, status_created) @@ -775,9 +790,10 @@ CONTAINS new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF END IF CASE (status_cancel_ener, status_canceled_ener) ! configuration is already created, @@ -787,9 +803,10 @@ CONTAINS ! creation complete, handle energy calculation at a different position ! (for different worker group) stat = status_calculated - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF CASE (status_cancel_nmc, status_canceled_nmc) ! reactivation canceled element (but with new global tree element) new_elem%conf(new_elem%mv_conf)%elem%stat = & @@ -797,9 +814,10 @@ CONTAINS new_elem%stat = status_calculate_NMC_steps stat = new_elem%conf(new_elem%mv_conf)%elem%stat reactivation_cc_count = reactivation_cc_count + 1 - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & "unknown stat "// & @@ -953,8 +971,9 @@ CONTAINS new_elem%stat = status_calculated ELSE new_elem%stat = status_created - IF (tmc_env%params%NMC_inp_file /= "") & + IF (tmc_env%params%NMC_inp_file /= "") THEN new_elem%stat = status_calc_approx_ener + END IF END IF CASE (mv_type_gausian_adapt) ! still could be implemented @@ -1004,8 +1023,9 @@ CONTAINS ELSE gt_ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params) + END IF !remove pointer from tree parent IF (ASSOCIATED(gt_ptr%parent)) THEN @@ -1060,12 +1080,13 @@ CONTAINS ! if there is still e reference to a global tree pointer, do not deallocate element IF (ASSOCIATED(ptr%gt_nodes_references)) THEN - IF (ASSOCIATED(ptr%parent)) & + IF (ASSOCIATED(ptr%parent)) THEN CALL cp_warn(__LOCATION__, & "try to deallocate subtree element"// & cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr)// & " still with global tree element references e.g."// & cp_to_string(ptr%gt_nodes_references%gt_elem%nr)) + END IF CPASSERT(ASSOCIATED(ptr%gt_nodes_references%gt_elem)) ELSE SELECT CASE (ptr%stat) @@ -1095,8 +1116,9 @@ CONTAINS ELSE ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN CALL create_dot_color(tree_element=ptr, tmc_params=tmc_env%params) + END IF !remove pointer from tree parent IF (ASSOCIATED(ptr%parent)) THEN @@ -1276,19 +1298,21 @@ CONTAINS ! delete element IF (remove_this) THEN !-- mark as deleted and draw it in tree - IF (.NOT. ASSOCIATED(begin_ptr%parent)) & + IF (.NOT. ASSOCIATED(begin_ptr%parent)) THEN CALL cp_abort(__LOCATION__, & "try to remove unused subtree element "// & cp_to_string(begin_ptr%sub_tree_nr)//" "// & cp_to_string(begin_ptr%nr)// & " but parent does not exist") + END IF tmp_ptr => begin_ptr ! check if a working group is still working on this element removed = .TRUE. DO i = 1, SIZE(working_elem_list(:)) IF (ASSOCIATED(working_elem_list(i)%elem)) THEN - IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) & + IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) THEN removed = .FALSE. + END IF END IF END DO IF (removed) THEN @@ -1333,10 +1357,11 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) & + IF (ASSOCIATED(actual_ptr%parent)) THEN CALL remove_result_g_tree(end_of_clean_tree=end_of_clean_tree, & actual_ptr=actual_ptr%parent, & tmc_env=tmc_env) + END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN !-- deallocate node @@ -1376,9 +1401,10 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) & + IF (ASSOCIATED(actual_ptr%parent)) THEN CALL remove_result_s_tree(end_of_clean_tree, actual_ptr%parent, & tmc_env) + END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN @@ -1446,8 +1472,9 @@ CONTAINS actual_ptr=tmp_gt_ptr, tmc_env=tmc_env) !check if something changed, if not no deallocation of result subtree necessary - IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) & + IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) THEN change_trajec = .TRUE. + END IF tmc_env%m_env%gt_head => tmc_env%m_env%gt_clean_end CPASSERT(.NOT. ASSOCIATED(tmc_env%m_env%gt_head%parent)) !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr @@ -1459,8 +1486,9 @@ CONTAINS ! get last checked element in trajectory related to the subtree (resultlist order is NOT subtree order) conf_loop: DO i = 1, SIZE(tmc_env%m_env%result_list) last_acc_st_elem => tmc_env%m_env%result_list(i)%elem - IF (last_acc_st_elem%sub_tree_nr == tree) & + IF (last_acc_st_elem%sub_tree_nr == tree) THEN EXIT conf_loop + END IF END DO conf_loop CPASSERT(last_acc_st_elem%sub_tree_nr == tree) CALL remove_unused_s_tree(begin_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, & diff --git a/src/tmc/tmc_tree_search.F b/src/tmc/tmc_tree_search.F index 5de61a8f44..a2371f3447 100644 --- a/src/tmc/tmc_tree_search.F +++ b/src/tmc/tmc_tree_search.F @@ -721,10 +721,12 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) & + IF (ASSOCIATED(ptr%acc)) THEN CALL count_nodes_in_global_tree(ptr%acc, counter) - IF (ASSOCIATED(ptr%nacc)) & + END IF + IF (ASSOCIATED(ptr%nacc)) THEN CALL count_nodes_in_global_tree(ptr%nacc, counter) + END IF END SUBROUTINE count_nodes_in_global_tree ! ************************************************************************************************** @@ -741,9 +743,11 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) & + IF (ASSOCIATED(ptr%acc)) THEN CALL count_nodes_in_tree(ptr%acc, counter) - IF (ASSOCIATED(ptr%nacc)) & + END IF + IF (ASSOCIATED(ptr%nacc)) THEN CALL count_nodes_in_tree(ptr%nacc, counter) + END IF END SUBROUTINE count_nodes_in_tree END MODULE tmc_tree_search diff --git a/src/tmc/tmc_types.F b/src/tmc/tmc_types.F index 02292e1c68..b7884be56f 100644 --- a/src/tmc/tmc_types.F +++ b/src/tmc/tmc_types.F @@ -216,22 +216,28 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%params)) DEALLOCATE (tmc_env%params%sub_box_size) - IF (ASSOCIATED(tmc_env%params%Temp)) & + IF (ASSOCIATED(tmc_env%params%Temp)) THEN DEALLOCATE (tmc_env%params%Temp) - IF (ASSOCIATED(tmc_env%params%cell)) & + END IF + IF (ASSOCIATED(tmc_env%params%cell)) THEN DEALLOCATE (tmc_env%params%cell) - IF (ASSOCIATED(tmc_env%params%atoms)) & + END IF + IF (ASSOCIATED(tmc_env%params%atoms)) THEN CALL deallocate_tmc_atom_type(tmc_env%params%atoms) + END IF DEALLOCATE (tmc_env%params) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_sub_group) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_w) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_first_w) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & + END IF + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_ana) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) & + END IF + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) THEN CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_only) + END IF DEALLOCATE (tmc_env%tmc_comp_set) @@ -281,8 +287,9 @@ CONTAINS DO i = 1, tmc_env%params%nr_temp tmc_env%m_env%st_heads(i)%elem => NULL() tmc_env%m_env%st_clean_ends(i)%elem => NULL() - IF (tmc_env%params%USE_REDUCED_TREE) & + IF (tmc_env%params%USE_REDUCED_TREE) THEN tmc_env%m_env%result_list(i)%elem => NULL() + END IF END DO tmc_env%m_env%gt_head => NULL() tmc_env%m_env%gt_clean_end => NULL() diff --git a/src/tmc/tmc_worker.F b/src/tmc/tmc_worker.F index 2e2204d988..bdc50bb514 100644 --- a/src/tmc/tmc_worker.F +++ b/src/tmc/tmc_worker.F @@ -167,13 +167,15 @@ CONTAINS END IF ! set the communicator in the external control for receiving exit tags ! and sending additional information (e.g. the intermediate scf energies) - IF (tmc_env%params%use_scf_energy_info) & + IF (tmc_env%params%use_scf_energy_info) THEN CALL set_intermediate_info_comm(env_id=itmp, & comm=tmc_env%tmc_comp_set%para_env_m_w) - IF (tmc_env%params%SPECULATIVE_CANCELING) & + END IF + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN CALL set_external_comm(comm=tmc_env%tmc_comp_set%para_env_m_w, & in_external_master_id=MASTER_COMM_ID, & in_exit_tag=TMC_CANCELING_MESSAGE) + END IF END IF !-- WORKING LOOP --! master_work_time: DO @@ -187,9 +189,10 @@ CONTAINS result_count=ana_restart_conf, & tmc_params=tmc_env%params, elem=conf) - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN WRITE (tmc_env%w_env%io_unit, *) "worker: group master of group ", & - tmc_env%tmc_comp_set%group_nr, "got task ", work_stat + tmc_env%tmc_comp_set%group_nr, "got task ", work_stat + END IF calc_stat = TMC_STATUS_CALCULATING SELECT CASE (work_stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -208,9 +211,10 @@ CONTAINS para_env=para_env_m_w, & tmc_params=tmc_env%params) CASE (TMC_STATUS_FAILED) - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%w_env%io_unit, *) "master worker of group", & - tmc_env%tmc_comp_set%group_nr, " exit work time." + tmc_env%tmc_comp_set%group_nr, " exit work time." + END IF EXIT master_work_time !-- group master read the CP2K input file, and write data to master CASE (TMC_STAT_START_CONF_REQUEST) @@ -230,10 +234,11 @@ CONTAINS tmc_params=tmc_env%params, elem=conf, & wait_for_message=.TRUE.) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & para_env=tmc_env%tmc_comp_set%para_env_m_first_w) + END IF !-- calculate the approximate energy CASE (TMC_STAT_APPROX_ENERGY_REQUEST) CPASSERT(tmc_env%w_env%env_id_approx > 0) @@ -267,7 +272,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -339,10 +344,11 @@ CONTAINS res_exist=flag, ierr=ierr) IF (.NOT. flag) tmc_env%params%print_dipole = .FALSE. ! TODO maybe let run with the changed option, but inform user properly - IF (.NOT. flag) & + IF (.NOT. flag) THEN CALL cp_abort(__LOCATION__, & "TMC: The requested dipoles are not porvided by the "// & "force environment.") + END IF END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -358,10 +364,11 @@ CONTAINS END SELECT !-- send information back to master - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%w_env%io_unit, *) "worker group ", & - tmc_env%tmc_comp_set%group_nr, & - "calculations done, send result energy", conf%potential + tmc_env%tmc_comp_set%group_nr, & + "calculations done, send result energy", conf%potential + END IF itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & @@ -386,9 +393,10 @@ CONTAINS CALL analysis_init(ana_env=ana_list(itmp)%temp, nr_dim=num_dim) ana_list(itmp)%temp%print_test_output = tmc_env%params%print_test_output - IF (.NOT. ASSOCIATED(conf)) & + IF (.NOT. ASSOCIATED(conf)) THEN CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=conf, nr_dim=num_dim) + END IF CALL analysis_restart_read(ana_env=ana_list(itmp)%temp, & elem=conf) !check if we have the read the file @@ -438,12 +446,14 @@ CONTAINS cp_to_string(work_stat)) END SELECT - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN WRITE (tmc_env%w_env%io_unit, *) "worker: group ", & - tmc_env%tmc_comp_set%group_nr, & - "send back status:", work_stat - IF (ASSOCIATED(conf)) & + tmc_env%tmc_comp_set%group_nr, & + "send back status:", work_stat + END IF + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=conf) + END IF END DO master_work_time !-- every other group paricipants---------------------------------------- ELSE @@ -489,7 +499,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -516,8 +526,9 @@ CONTAINS "group participant got unknown working type "// & cp_to_string(work_stat)) END SELECT - IF (ASSOCIATED(conf)) & + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=conf) + END IF END DO worker_work_time END IF ! -------------------------------------------------------------------- @@ -525,8 +536,9 @@ CONTAINS IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN DO itmp = 1, tmc_env%params%nr_temp CALL analysis_restart_print(ana_env=ana_list(itmp)%temp) - IF (ASSOCIATED(conf)) & + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(itmp)%temp%last_elem) + END IF CALL finalize_tmc_analysis(ana_list(itmp)%temp) END DO END IF @@ -546,9 +558,10 @@ CONTAINS CALL remove_intermediate_info_comm(env_id=itmp) END IF END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) THEN CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_sub_group, & tmc_params=tmc_env%params) + END IF work_stat = TMC_STATUS_STOP_RECEIPT itmp = MASTER_COMM_ID @@ -563,10 +576,11 @@ CONTAINS tmc_params=tmc_env%params) END IF - IF (DEBUG >= 5) & + IF (DEBUG >= 5) THEN WRITE (tmc_env%w_env%io_unit, *) "worker ", & - tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & - tmc_env%tmc_comp_set%group_nr, "stops working!" + tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & + tmc_env%tmc_comp_set%group_nr, "stops working!" + END IF IF (PRESENT(ana_list)) THEN DO itmp = 1, tmc_env%params%nr_temp @@ -574,8 +588,9 @@ CONTAINS ana_list(itmp)%temp%cell => NULL() END DO END IF - IF (ASSOCIATED(conf)) & + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=conf) + END IF IF (ASSOCIATED(ana_restart_conf)) DEALLOCATE (ana_restart_conf) ! end the timing @@ -872,10 +887,11 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN CALL cp_abort(__LOCATION__, & "the intermediate SCF energy request can not be set "// & "employing this force environment! ") + END IF ! set the information values(1) = REAL(comm%get_handle(), KIND=dp) @@ -910,10 +926,11 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN CALL cp_abort(__LOCATION__, & "the SCF intermediate energy communicator can not be "// & "removed! ") + END IF description = "[EXT_SCF_ENER_COMM]" diff --git a/src/topology.F b/src/topology.F index b82782ec0a..e482a1cb4c 100644 --- a/src/topology.F +++ b/src/topology.F @@ -548,11 +548,12 @@ CONTAINS "connectivity type.") END SELECT END DO - IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) & + IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) THEN CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") + END IF ! Merge defined structures section => section_vals_get_subs_vals(subsys_section, "TOPOLOGY%MOL_SET%MERGE_MOLECULES") @@ -660,8 +661,9 @@ CONTAINS i_val=topology%natoms) CALL timestop(handle2) ! Check on atom numbers - IF (topology%natoms <= 0) & + IF (topology%natoms <= 0) THEN CPABORT("No atomic coordinates have been found! ") + END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & "PRINT%TOPOLOGY_INFO") diff --git a/src/topology_amber.F b/src/topology_amber.F index 8f9bbc4361..10425ea382 100644 --- a/src/topology_amber.F +++ b/src/topology_amber.F @@ -184,8 +184,9 @@ CONTAINS END DO ! Trigger error IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) & + IF (j /= natom) THEN CPABORT("Error while reading CRD file. Unexpected end of file.") + END IF ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom j = natom @@ -230,10 +231,11 @@ CONTAINS END DO setup_velocities = .TRUE. IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) & + IF (j /= natom) THEN CALL cp_warn(__LOCATION__, & "No VELOCITY information found in CRD file. Ignoring BOX information. "// & "Please provide the BOX information directly from the main CP2K input! ") + END IF setup_velocities = .FALSE. ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom @@ -257,10 +259,11 @@ CONTAINS IF (my_end) THEN CPWARN_IF(j /= natom, "BOX information missing in CRD file.") ELSE - IF (j /= natom) & + IF (j /= natom) THEN CALL cp_warn(__LOCATION__, & "BOX information found in CRD file. They will be ignored. "// & "Please provide the BOX information directly from the main CP2K input!") + END IF END IF CALL parser_release(parser) CALL cp_print_key_finished_output(iw, logger, subsys_section, & @@ -1060,16 +1063,18 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i1 ! ************************************************************************************************** @@ -1096,26 +1101,30 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i3 ! ************************************************************************************************** @@ -1143,31 +1152,36 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i4 ! ************************************************************************************************** @@ -1197,36 +1211,42 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) !array5 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array5(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i5 ! ************************************************************************************************** @@ -1250,16 +1270,18 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i), lower_to_upper=.TRUE.) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_c1 ! ************************************************************************************************** @@ -1283,16 +1305,18 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_r1 ! ************************************************************************************************** @@ -1321,8 +1345,9 @@ CONTAINS section = TRIM(parser%input_line(indflag:)) ! Input format CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) & + IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) THEN CPABORT("Expecting %FORMAT. Not found! Abort reading of AMBER topology file!") + END IF start_f = INDEX(parser%input_line, "(") end_f = INDEX(parser%input_line, ")") @@ -1346,10 +1371,11 @@ CONTAINS LOGICAL :: found_AMBER_V8 CALL parser_search_string(parser, "%VERSION ", .TRUE., found_AMBER_V8, begin_line=.TRUE.) - IF (.NOT. found_AMBER_V8) & + IF (.NOT. found_AMBER_V8) THEN CALL cp_abort(__LOCATION__, & "This is not an AMBER V.8 PRMTOP format file. Cannot interpret older "// & "AMBER file formats. ") + END IF IF (output_unit > 0) WRITE (output_unit, '(" AMBER_INFO| ",A)') "Amber PrmTop V.8 or greater.", & TRIM(parser%input_line) diff --git a/src/topology_cif.F b/src/topology_cif.F index 0100632559..eb3f9250f3 100644 --- a/src/topology_cif.F +++ b/src/topology_cif.F @@ -249,9 +249,10 @@ CONTAINS CALL parser_search_string(parser, "_space_group_symop_operation_xyz", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) END IF - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_warn(__LOCATION__, "The fields (_symmetry_equiv_pos_as_xyz) or "// & "(_space_group_symop_operation_xyz) were not found in CIF file!") + END IF IF (iw > 0) WRITE (iw, '(A,I0)') " CIF_INFO| Number of atoms before applying symmetry operations :: ", natom IF (iw > 0) WRITE (iw, '(A10,1X,3F12.6)') (TRIM(id2str(atom_info%id_atmname(ii))), atom_info%r(1:3, ii), ii=1, natom) isym = 0 @@ -290,7 +291,6 @@ CONTAINS DO jj = 1, natom r2 = atom_info%r(1:3, jj) r = pbc(r1 - r2, cell) - ! SQRT(DOT_PRODUCT(r, r)) <= threshold IF (DOT_PRODUCT(r, r) <= (threshold*threshold)) THEN check = .FALSE. EXIT diff --git a/src/topology_connectivity_util.F b/src/topology_connectivity_util.F index 8506ee4119..7518b6dfc0 100644 --- a/src/topology_connectivity_util.F +++ b/src/topology_connectivity_util.F @@ -74,7 +74,7 @@ CONTAINS inter_bends, inter_bonds, inter_imprs, inter_torsions, inter_ubs, intra_bends, & intra_bonds, intra_imprs, intra_torsions, intra_ubs, inum, ires, istart_mol, istart_typ, & itorsion, ityp, iub, iw, j, j1, j2, j3, j4, jind, last, min_index, natom, nelectron, & - nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit, stat + nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit INTEGER, DIMENSION(:), POINTER :: c_var_a, c_var_b, c_var_c, c_var_d, c_var_type, & first_list, last_list, map_atom_mol, map_atom_type, map_cvar_mol, map_cvars, map_var_mol, & map_vars, molecule_list @@ -225,7 +225,7 @@ CONTAINS found = .TRUE. found_last = .FALSE. imol = ABS(map_atom_mol(i)) - ELSEIF (ikind == topology%nmol_type) THEN + ELSE IF (ikind == topology%nmol_type) THEN found = .TRUE. found_last = .TRUE. imol = ABS(map_atom_mol(natom)) @@ -1057,9 +1057,8 @@ CONTAINS END IF molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + iimpr*SIZE(molecule_kind%molecule_list) - ALLOCATE (impr_list(iimpr), STAT=stat) - ALLOCATE (opbend_list(iimpr), STAT=stat) - CPASSERT(stat == 0) + ALLOCATE (impr_list(iimpr)) + ALLOCATE (opbend_list(iimpr)) iimpr = 0 DO j = bnd_type(1, i), bnd_type(2, i) IF (j == 0) CYCLE diff --git a/src/topology_constraint_util.F b/src/topology_constraint_util.F index b7d07a8b12..2980507f15 100644 --- a/src/topology_constraint_util.F +++ b/src/topology_constraint_util.F @@ -241,11 +241,13 @@ CONTAINS END IF END IF CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", n_rep_val=nrep) - IF (nrep /= 0) & + IF (nrep /= 0) THEN CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", c_vals=atom_typeh) + END IF CALL section_vals_val_get(hbonds_section, "TARGETS", n_rep_val=nrep) - IF (nrep /= 0) & + IF (nrep /= 0) THEN CALL section_vals_val_get(hbonds_section, "TARGETS", r_vals=hdist) + END IF IF (ASSOCIATED(hdist)) THEN CPASSERT(SIZE(hdist) == SIZE(atom_typeh)) END IF @@ -342,7 +344,7 @@ CONTAINS IF (ishbond) THEN nhdist = nhdist + 1 rvec = particle_set(offset + bond_list(k)%a)%r - particle_set(offset + bond_list(k)%b)%r - rmod = SQRT(DOT_PRODUCT(rvec, rvec)) + rmod = NORM2(rvec) IF (ASSOCIATED(hdist)) THEN IF (SIZE(hdist) > 0) THEN IF (bond_list(k)%a == j) atomic_kind => atom_list(bond_list(k)%b)%atomic_kind @@ -750,13 +752,13 @@ CONTAINS IF (fix_fixed_atom) THEN fixd_list(kk)%restraint%active = cons_info%fixed_restraint(k2loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_k0(k2loc) - ELSEIF (fix_atom_qm) THEN + ELSE IF (fix_atom_qm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_qm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_qm_k0 - ELSEIF (fix_atom_mm) THEN + ELSE IF (fix_atom_mm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_mm_k0 - ELSEIF (fix_atom_molname) THEN + ELSE IF (fix_atom_molname) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mol_restraint(k1loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_mol_k0(k1loc) ELSE @@ -813,8 +815,9 @@ CONTAINS CASE (use_perd_xyz) CPASSERT(SIZE(r) == 3) fixd_list(kk)%coord(1:3) = r(1:3) - IF (ASSOCIATED(topology%cell_muc)) & + IF (ASSOCIATED(topology%cell_muc)) THEN CALL cell_transform_input_cartesian(topology%cell_muc, fixd_list(kk)%coord) + END IF END SELECT ELSE ! Write coord0 value for restraint @@ -1338,11 +1341,12 @@ CONTAINS ! Intramolecular constraint IF (const_mol(i) /= 0) THEN k = const_mol(i) - IF (k > SIZE(molecule_kind_set)) & + IF (k > SIZE(molecule_kind_set)) THEN CALL cp_abort(__LOCATION__, & "A constraint has been specified providing the molecule index. But the"// & " molecule index ("//cp_to_string(k)//") is out of range of the possible"// & " molecule kinds ("//cp_to_string(SIZE(molecule_kind_set))//").") + END IF isize = SIZE(constr_x_mol(k)%constr) CALL reallocate(constr_x_mol(k)%constr, 1, isize + 1) constr_x_mol(k)%constr(isize + 1) = i @@ -1379,13 +1383,14 @@ CONTAINS LOGICAL, INTENT(IN) :: found CHARACTER(LEN=*), INTENT(IN) :: name - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_warn(__LOCATION__, & " MOLNAME ("//TRIM(name)//") was defined for constraints, but this molecule name "// & "is not defined. Please check carefully your PDB, PSF (has priority over PDB) or "// & "input driven CP2K coordinates. In case you may not find the reason for this warning "// & "it may be a good idea to print all molecule information (including kind name) activating "// & "the print_key MOLECULES specific of the SUBSYS%PRINT section. ") + END IF END SUBROUTINE print_warning_molname diff --git a/src/topology_coordinate_util.F b/src/topology_coordinate_util.F index e2a1b91768..63584a9429 100644 --- a/src/topology_coordinate_util.F +++ b/src/topology_coordinate_util.F @@ -198,8 +198,9 @@ CONTAINS CALL reallocate(mass, 1, counter) CALL reallocate(id_element, 1, counter) CALL reallocate(charge, 1, counter) - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(5X,A,I3)') "Total Number of Atomic Kinds = ", topology%natom_type + END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -338,10 +339,11 @@ CONTAINS END DO my_ignore_outside_box = .FALSE. IF (PRESENT(ignore_outside_box)) my_ignore_outside_box = ignore_outside_box - IF (.NOT. my_ignore_outside_box .AND. .NOT. check) & + IF (.NOT. my_ignore_outside_box .AND. .NOT. check) THEN CALL cp_abort(__LOCATION__, & "A non-periodic calculation has been requested but the system size "// & "exceeds the cell size in at least one of the non-periodic directions!") + END IF IF (do_center) THEN CALL section_vals_val_get(subsys_section, & "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT", explicit=explicit) @@ -636,20 +638,23 @@ CONTAINS ! copy of data, not copy of pointer exclusions(iatom)%list_onfo = ex_onfo_list(iatom)%array1 IF (iw > 0) THEN - IF (ASSOCIATED(list)) & + IF (ASSOCIATED(list)) THEN WRITE (iw, *) "exclusion list_vdw :: ", & - "atom num :", iatom, "exclusion list ::", & - list - IF (topology%exclude_vdw /= topology%exclude_ei) THEN - IF (ASSOCIATED(list2)) & - WRITE (iw, *) "exclusion list_ei :: ", & "atom num :", iatom, "exclusion list ::", & - list2 + list END IF - IF (ASSOCIATED(exclusions(iatom)%list_onfo)) & + IF (topology%exclude_vdw /= topology%exclude_ei) THEN + IF (ASSOCIATED(list2)) THEN + WRITE (iw, *) "exclusion list_ei :: ", & + "atom num :", iatom, "exclusion list ::", & + list2 + END IF + END IF + IF (ASSOCIATED(exclusions(iatom)%list_onfo)) THEN WRITE (iw, *) "onfo list :: ", & - "atom num :", iatom, "onfo list ::", & - exclusions(iatom)%list_onfo + "atom num :", iatom, "onfo list ::", & + exclusions(iatom)%list_onfo + END IF END IF END DO ! deallocate onfo diff --git a/src/topology_generate_util.F b/src/topology_generate_util.F index 718c42ac9b..5e17f4df5a 100644 --- a/src/topology_generate_util.F +++ b/src/topology_generate_util.F @@ -1669,7 +1669,7 @@ CONTAINS nvar=nvar, & Ilist=Ilist) Ilist(it_levl) = -1 - ELSEIF (it_levl == max_levl) THEN + ELSE IF (it_levl == max_levl) THEN IF (Ilist(1) > ind) CYCLE Ilist(it_levl) = ind nvar = nvar + 1 diff --git a/src/topology_gromos.F b/src/topology_gromos.F index d3ddfa9858..743d890308 100644 --- a/src/topology_gromos.F +++ b/src/topology_gromos.F @@ -607,10 +607,12 @@ CONTAINS DEALLOCATE (na) DEALLOCATE (am) DEALLOCATE (ac) - IF (ASSOCIATED(ba)) & + IF (ASSOCIATED(ba)) THEN DEALLOCATE (ba) - IF (ASSOCIATED(bb)) & + END IF + IF (ASSOCIATED(bb)) THEN DEALLOCATE (bb) + END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & diff --git a/src/topology_input.F b/src/topology_input.F index 4aa95dfb4b..6aad5946ca 100644 --- a/src/topology_input.F +++ b/src/topology_input.F @@ -64,8 +64,9 @@ CONTAINS CALL section_vals_val_get(topology_section, "CHARGE_BETA", l_val=topology%charge_beta) CALL section_vals_val_get(topology_section, "CHARGE_EXTENDED", l_val=topology%charge_extended) ival = COUNT([topology%charge_occup, topology%charge_beta, topology%charge_extended]) - IF (ival > 1) & + IF (ival > 1) THEN CPABORT("Only one between can be defined! ") + END IF CALL section_vals_val_get(topology_section, "PARA_RES", l_val=topology%para_res) CALL section_vals_val_get(topology_section, "GENERATE%REORDER", l_val=topology%reorder_atom) CALL section_vals_val_get(topology_section, "GENERATE%CREATE_MOLECULES", l_val=topology%create_molecules) diff --git a/src/topology_multiple_unit_cell.F b/src/topology_multiple_unit_cell.F index bd93f27785..771768035e 100644 --- a/src/topology_multiple_unit_cell.F +++ b/src/topology_multiple_unit_cell.F @@ -65,19 +65,21 @@ CONTAINS i_vals=multiple_unit_cell) ! Fail is one of the value is set to zero.. - IF (ANY(multiple_unit_cell <= 0)) & + IF (ANY(multiple_unit_cell <= 0)) THEN CALL cp_abort(__LOCATION__, "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL accepts "// & "only integer values greater than zero.") + END IF IF (ANY(multiple_unit_cell /= 1)) THEN ! Check that the setup between CELL and TOPOLOGY is the same CALL section_vals_val_get(subsys_section, "CELL%MULTIPLE_UNIT_CELL", & i_vals=iwork) - IF (ANY(iwork /= multiple_unit_cell)) & + IF (ANY(iwork /= multiple_unit_cell)) THEN CALL cp_abort(__LOCATION__, "The input parameters for "// & "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL and "// & "SUBSYS%CELL%MULTIPLE_UNIT_CELL have to agree.") + END IF cell => topology%cell_muc natoms = topology%natoms*PRODUCT(multiple_unit_cell) @@ -88,9 +90,10 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(work_section, '_DEFAULT_KEYWORD_', n_rep_val=nrep) check = nrep == natoms - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "The number of available entries in the "// & "VELOCITY section is not compatible with the number of atoms.") + END IF END IF CALL reallocate(topology%atom_info%id_molname, 1, natoms) diff --git a/src/topology_pdb.F b/src/topology_pdb.F index 481169411a..f995d732a2 100644 --- a/src/topology_pdb.F +++ b/src/topology_pdb.F @@ -185,12 +185,20 @@ CONTAINS ELSE atom_info%id_resname(natom) = id0 END IF + ! Some information is not always given, so we mark it as used to prevent linters from crying + ! regarding never a never used variable 'istat' READ (UNIT=line(23:26), FMT=*, IOSTAT=istat) atom_info%resid(natom) + MARK_USED(istat) READ (UNIT=line(31:38), FMT=*, IOSTAT=istat) atom_info%r(1, natom) + MARK_USED(istat) READ (UNIT=line(39:46), FMT=*, IOSTAT=istat) atom_info%r(2, natom) + MARK_USED(istat) READ (UNIT=line(47:54), FMT=*, IOSTAT=istat) atom_info%r(3, natom) + MARK_USED(istat) READ (UNIT=line(55:60), FMT=*, IOSTAT=istat) atom_info%occup(natom) + MARK_USED(istat) READ (UNIT=line(61:66), FMT=*, IOSTAT=istat) atom_info%beta(natom) + MARK_USED(istat) READ (UNIT=line(73:76), FMT=*, IOSTAT=istat) strtmp IF (istat == 0) THEN atom_info%id_molname(natom) = str2id(s2s(strtmp)) @@ -209,7 +217,7 @@ CONTAINS IF (topology%charge_occup) atom_info%atm_charge(natom) = atom_info%occup(natom) IF (topology%charge_beta) atom_info%atm_charge(natom) = atom_info%beta(natom) IF (topology%charge_extended) THEN - READ (UNIT=line(81:), FMT=*, IOSTAT=istat) atom_info%atm_charge(natom) + READ (UNIT=line(81:), FMT=*) atom_info%atm_charge(natom) END IF IF (atom_info%id_element(natom) == id0) THEN @@ -310,8 +318,9 @@ CONTAINS CALL section_vals_val_get(print_key, "CHARGE_BETA", l_val=charge_beta) CALL section_vals_val_get(print_key, "CHARGE_EXTENDED", l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) & + IF (i > 1) THEN CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected") + END IF atom_info => topology%atom_info record = cp_print_key_generate_filename(logger, print_key, & @@ -371,8 +380,9 @@ CONTAINS END IF IF (ASSOCIATED(atom_info%atm_charge)) THEN IF (ANY([charge_occup, charge_beta, charge_extended]) .AND. & - (atom_info%atm_charge(i) == -HUGE(0.0_dp))) & + (atom_info%atm_charge(i) == -HUGE(0.0_dp))) THEN CPABORT("No atomic charges found yet (after the topology setup)") + END IF IF (charge_occup) THEN WRITE (UNIT=line(55:60), FMT="(F6.2)") atom_info%atm_charge(i) ELSE IF (charge_beta) THEN diff --git a/src/topology_psf.F b/src/topology_psf.F index 91aaec84e7..ce03e59dae 100644 --- a/src/topology_psf.F +++ b/src/topology_psf.F @@ -113,9 +113,10 @@ CONTAINS c_int = 'I8' label = 'PSF' CALL parser_search_string(parser, label, .TRUE., found, begin_line=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "Missing PSF specification line in <"//TRIM(filename)//">") + END IF DO WHILE (parser_test_next_token(parser) /= "EOL") CALL parser_get_object(parser, field) SELECT CASE (field(1:3)) @@ -147,11 +148,12 @@ CONTAINS natom = 0 ELSE CALL parser_get_object(parser, natom) - IF (natom_prev + natom > topology%natoms) & + IF (natom_prev + natom > topology%natoms) THEN CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") + END IF IF (iw > 0) WRITE (iw, '(T2,A,'//TRIM(c_int)//')') 'PSF_INFO| NATOM = ', natom !malloc the memory that we need CALL reallocate(atom_info%id_molname, 1, natom_prev + natom) diff --git a/src/topology_types.F b/src/topology_types.F index 440becf6d0..6300d6809b 100644 --- a/src/topology_types.F +++ b/src/topology_types.F @@ -68,12 +68,13 @@ MODULE topology_types REAL(KIND=dp) :: hbonds_k0 = -1.0_dp ! Restraints control ! Fixed Atoms INTEGER :: nfixed_atoms = -1 - INTEGER, POINTER :: fixed_atoms(:) => NULL(), fixed_type(:) => NULL(), fixed_mol_type(:) => NULL() - LOGICAL, POINTER :: fixed_restraint(:) => NULL() ! Restraints control - REAL(KIND=dp), POINTER :: fixed_k0(:) => NULL() ! Restraints control + INTEGER, DIMENSION(:), POINTER :: fixed_atoms => NULL(), fixed_type => NULL(), fixed_mol_type => NULL() + LOGICAL, DIMENSION(:), POINTER :: fixed_restraint => NULL() ! Restraints control + REAL(KIND=dp), DIMENSION(:), POINTER :: fixed_k0 => NULL() ! Restraints control ! Freeze QM or MM INTEGER :: freeze_qm = -1, freeze_mm = -1, freeze_qm_type = -1, freeze_mm_type = -1 - LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. ! Restraints control + ! Restraints control + LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. REAL(KIND=dp) :: fixed_mm_k0 = -1.0_dp, fixed_qm_k0 = -1.0_dp ! Restraints control ! Freeze with molnames LOGICAL, POINTER :: fixed_mol_restraint(:) => NULL() ! Restraints control @@ -524,8 +525,9 @@ CONTAINS !----------------------------------------------------------------------------- ! 3. DEALLOCATE things in topology%cons_info !----------------------------------------------------------------------------- - IF (ASSOCIATED(topology%cons_info)) & + IF (ASSOCIATED(topology%cons_info)) THEN CALL deallocate_constraint(topology%cons_info) + END IF !----------------------------------------------------------------------------- ! 4. DEALLOCATE things in topology !----------------------------------------------------------------------------- diff --git a/src/topology_util.F b/src/topology_util.F index b53ba161c7..0a042423bb 100644 --- a/src/topology_util.F +++ b/src/topology_util.F @@ -1207,11 +1207,12 @@ CONTAINS END IF ! This is clearly a user error - IF (.NOT. found .AND. defined_kind_section) & + IF (.NOT. found .AND. defined_kind_section) THEN CALL cp_abort(__LOCATION__, "Element <"//TRIM(element_symbol)// & "> provided for KIND <"//TRIM(atom_name_in)//"> "// & "which cannot be mapped with any standard element label. Please correct your "// & "input file!") + END IF ! Last chance.. are these atom_kinds of AMBER or CHARMM or GROMOS FF ? CALL uppercase(element_symbol) diff --git a/src/topology_xtl.F b/src/topology_xtl.F index 42f6839993..29b87259ff 100644 --- a/src/topology_xtl.F +++ b/src/topology_xtl.F @@ -144,8 +144,9 @@ CONTAINS ! Check for _cell_length_a CALL parser_search_string(parser, "CELL", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field CELL was not found in XTL file! ") + END IF CALL parser_get_next_line(parser, 1) ! CELL LENGTH A CALL parser_get_object(parser, cell_lengths(1)) @@ -178,13 +179,15 @@ CONTAINS ! Check for _atom_site_label CALL parser_search_string(parser, "ATOMS", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field ATOMS was not found in XTL file! ") + END IF CALL parser_get_next_line(parser, 1) ! Paranoic syntax check.. if this fails one should improve the description of XTL files found = (INDEX(parser%input_line, "NAME X Y Z") /= 0) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field ATOMS in XTL file, is not followed by name and coordinates tags! ") + END IF CALL parser_get_next_line(parser, 1) ! Parse real info natom = 0 diff --git a/src/topology_xyz.F b/src/topology_xyz.F index b01a1cab08..6f881238c9 100644 --- a/src/topology_xyz.F +++ b/src/topology_xyz.F @@ -151,11 +151,12 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) my_end = my_end .OR. (LEN_TRIM(parser%input_line) == 0) IF (my_end) THEN - IF (j /= natom) & + IF (j /= natom) THEN CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format. Very probably the line with title is missing or is empty."// & " Please check the XYZ file and rerun your job!") + END IF EXIT Frames END IF END DO diff --git a/src/transport.F b/src/transport.F index fd9cc1ef24..f13949bfea 100644 --- a/src/transport.F +++ b/src/transport.F @@ -381,10 +381,11 @@ CONTAINS CALL timeset(routineN, handle) CALL C_F_PROCPOINTER(transport_env%ext_c_method_ptr, c_method) - IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) & + IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) THEN CALL cp_abort(__LOCATION__, & "MISSING C/C++ ROUTINE: The TRANSPORT section is meant to be used together with an external "// & "program, e.g. the quantum transport code OMEN, that provides CP2K with a density matrix.") + END IF transport_env%params%n_occ = nelectron_spin transport_env%params%n_atoms = natoms diff --git a/src/wannier90.F b/src/wannier90.F index 24c5901510..79dcc46327 100644 --- a/src/wannier90.F +++ b/src/wannier90.F @@ -672,7 +672,7 @@ CONTAINS counter = counter + 1 lmn(1, counter) = l; lmn(2, counter) = m; lmn(3, counter) = n pos = MATMUL(lmn(:, counter), recip_lattice) - dist(counter) = SQRT(DOT_PRODUCT(pos, pos)) + dist(counter) = NORM2(pos) END DO END DO END DO @@ -776,8 +776,8 @@ CONTAINS DO loop_s = 1, num_shells DO loop_b = 1, multi(shell_list(loop_s)) delta = DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_b, loop_s))/ & - SQRT(DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_bn, cur_shell))* & - DOT_PRODUCT(bvector(:, loop_b, loop_s), bvector(:, loop_b, loop_s))) + NORM2(bvector(:, loop_bn, cur_shell))* & + NORM2(bvector(:, loop_b, loop_s)) IF (ABS(ABS(delta) - 1.0_dp) < eps6) lpar = .TRUE. END DO END DO @@ -871,7 +871,7 @@ CONTAINS IF (.NOT. b1sat) THEN IF (shell < search_shells .AND. iprint >= 3) THEN WRITE (stdout, '(1x,a,24x,a1)') '| B1 condition is not satisfied: Adding another shell', '|' - ELSEIF (shell == search_shells) THEN + ELSE IF (shell == search_shells) THEN WRITE (stdout, *) ' ' WRITE (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', search_shells, ' shells' WRITE (stdout, '(1x,a)') 'Your cell might be very long, or you may have an irregular MP grid' diff --git a/src/xas_methods.F b/src/xas_methods.F index 8258506b41..f14f3915eb 100644 --- a/src/xas_methods.F +++ b/src/xas_methods.F @@ -316,7 +316,7 @@ CONTAINS WRITE (UNIT=output_unit, FMT="( A , I7, A, I7)") " The sub-set contains states from ", & qs_loc_env%localized_wfn_control%lu_bound_states(1, my_spin), " to ", & qs_loc_env%localized_wfn_control%lu_bound_states(2, my_spin) - ELSEIF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN + ELSE IF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN WRITE (UNIT=output_unit, FMT="( A )") " The sub-set contains states given in the input list" END IF @@ -431,8 +431,9 @@ CONTAINS CALL get_mo_set(mos(my_spin), nmo=nmo) CALL get_xas_env(xas_env, occ_estate=occ_estate, xas_nelectron=xas_nelectron) tmp = xas_nelectron + 1.0_dp - occ_estate - IF (nmo < tmp) & + IF (nmo < tmp) THEN CPABORT("CLS: the required method needs added_mos to the ground state") + END IF ! If the restart file for this atom exists, the mos and the ! occupation numbers are overwritten ! It is necessary that the restart is for the same xas method @@ -724,31 +725,31 @@ CONTAINS nele = REAL(nelectron, dp) - 0.5_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSEIF (xas_control%xas_method == xas_tp_xhh) THEN + ELSE IF (xas_control%xas_method == xas_tp_xhh) THEN occ_estate = 0.5_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 0.5_dp - ELSEIF (xas_control%xas_method == xas_tp_fh) THEN + ELSE IF (xas_control%xas_method == xas_tp_fh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) - 1.0_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSEIF (xas_control%xas_method == xas_tp_xfh) THEN + ELSE IF (xas_control%xas_method == xas_tp_xfh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSEIF (xas_control%xas_method == xes_tp_val) THEN + ELSE IF (xas_control%xas_method == xes_tp_val) THEN occ_estate = xas_control%xes_core_occupation nele = REAL(nelectron, dp) - xas_control%xes_core_occupation occ_homo = xas_control%xes_homo_occupation - ELSEIF (xas_control%xas_method == xas_dscf) THEN + ELSE IF (xas_control%xas_method == xas_dscf) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSEIF (xas_control%xas_method == xas_tp_flex) THEN + ELSE IF (xas_control%xas_method == xas_tp_flex) THEN nele = REAL(xas_control%nel_tot, dp) occ_estate = REAL(xas_control%xas_core_occupation, dp) IF (nele < 0.0_dp) nele = REAL(nelectron, dp) - (1.0_dp - occ_estate) @@ -857,7 +858,7 @@ CONTAINS "xas_env%ostrength_sm-"//TRIM(ADJUSTL(cp_to_string(i)))) CALL dbcsr_set(xas_env%ostrength_sm(i)%matrix, 0.0_dp) END DO - ELSEIF (xas_control%dipole_form == xas_dip_vel) THEN + ELSE IF (xas_control%dipole_form == xas_dip_vel) THEN ! ! prepare for allocation natom = SIZE(particle_set, 1) @@ -918,31 +919,31 @@ CONTAINS IF (xas_control%state_type == xas_1s_type) THEN nq(1) = 1 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_2s_type) THEN + ELSE IF (xas_control%state_type == xas_2s_type) THEN nq(1) = 2 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_2p_type) THEN + ELSE IF (xas_control%state_type == xas_2p_type) THEN nq(1) = 2 lq(1) = 1 - ELSEIF (xas_control%state_type == xas_3s_type) THEN + ELSE IF (xas_control%state_type == xas_3s_type) THEN nq(1) = 3 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_3p_type) THEN + ELSE IF (xas_control%state_type == xas_3p_type) THEN nq(1) = 3 lq(1) = 1 - ELSEIF (xas_control%state_type == xas_3d_type) THEN + ELSE IF (xas_control%state_type == xas_3d_type) THEN nq(1) = 3 lq(1) = 2 - ELSEIF (xas_control%state_type == xas_4s_type) THEN + ELSE IF (xas_control%state_type == xas_4s_type) THEN nq(1) = 4 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_4p_type) THEN + ELSE IF (xas_control%state_type == xas_4p_type) THEN nq(1) = 4 lq(1) = 1 - ELSEIF (xas_control%state_type == xas_4d_type) THEN + ELSE IF (xas_control%state_type == xas_4d_type) THEN nq(1) = 4 lq(1) = 2 - ELSEIF (xas_control%state_type == xas_4f_type) THEN + ELSE IF (xas_control%state_type == xas_4f_type) THEN nq(1) = 4 lq(1) = 3 ELSE @@ -1659,7 +1660,8 @@ CONTAINS END DO END IF - CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) ! Scales down the 2d-array to the minimal size + ! Scales down the 2d-array to the minimal size + CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) ELSE ! Manually selected orbital indices diff --git a/src/xas_restart.F b/src/xas_restart.F index 6ecc1dda59..42864330d3 100644 --- a/src/xas_restart.F +++ b/src/xas_restart.F @@ -183,12 +183,14 @@ CONTAINS READ (rst_unit) nexc_search_read, nexc_atoms_read, occ_estate_read, xas_nelectron_read READ (rst_unit) xas_estate_read - IF (xas_method_read /= xas_method) & + IF (xas_method_read /= xas_method) THEN CPABORT("READ XAS RESTART: restart with different XAS method is not possible.") - IF (nexc_atoms_read /= nexc_atoms) & + END IF + IF (nexc_atoms_read /= nexc_atoms) THEN CALL cp_abort(__LOCATION__, & "READ XAS RESTART: restart with different excited atoms "// & "is not possible. Start instead a new XAS run with the new set of atoms.") + END IF END IF CALL para_env%bcast(xas_estate_read) @@ -206,8 +208,9 @@ CONTAINS CALL cp_fm_set_all(mo_coeff, 0.0_dp) IF (para_env%is_source()) THEN READ (rst_unit) nao_read, nmo_read - IF (nao /= nao_read) & + IF (nao /= nao_read) THEN CPABORT("To change basis is not possible. ") + END IF ALLOCATE (eig_read(nmo_read), occ_read(nmo_read)) eig_read = 0.0_dp occ_read = 0.0_dp @@ -216,10 +219,11 @@ CONTAINS eigenvalues(1:nmo) = eig_read(1:nmo) occupation_numbers(1:nmo) = occ_read(1:nmo) IF (nmo_read > nmo) THEN - IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) & + IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) THEN CALL cp_warn(__LOCATION__, & "The number of occupied MOs on the restart unit is larger than "// & "the allocated MOs.") + END IF END IF DEALLOCATE (eig_read, occ_read) diff --git a/src/xas_tdp_atom.F b/src/xas_tdp_atom.F index 87df1c0f2a..faa3fe4633 100644 --- a/src/xas_tdp_atom.F +++ b/src/xas_tdp_atom.F @@ -1186,7 +1186,7 @@ CONTAINS ! Point to the rho_set densities rhoa => rho_set%rhoa rhob => rho_set%rhob - rhoa = 0.0_dp; rhob = 0.0_dp; + rhoa = 0.0_dp; rhob = 0.0_dp IF (do_gga) THEN DO dir = 1, 3 rho_set%drhoa(dir)%array = 0.0_dp diff --git a/src/xas_tdp_correction.F b/src/xas_tdp_correction.F index 91aa6cd919..05fc8df3b9 100644 --- a/src/xas_tdp_correction.F +++ b/src/xas_tdp_correction.F @@ -1880,7 +1880,7 @@ CONTAINS !The SOC corrected KS eigenvalues ALLOCATE (tmp_shifts(ndo_mo, 2)) - ialpha = 1; ibeta = 1; + ialpha = 1; ibeta = 1 DO ido_mo = 1, ndo_so !need to find out whether the eigenvalue corresponds to an alpha or beta spin-orbtial alpha_tot_contrib = REAL(DOT_PRODUCT(evecs(1:ndo_mo, ido_mo), evecs(1:ndo_mo, ido_mo))) diff --git a/src/xas_tdp_kernel.F b/src/xas_tdp_kernel.F index 8524077535..4c4890a407 100644 --- a/src/xas_tdp_kernel.F +++ b/src/xas_tdp_kernel.F @@ -164,7 +164,8 @@ CONTAINS ! Broadcast the integrals to all procs (deleted after all donor states for this atoms are treated) lb = 1; IF (do_sf .AND. .NOT. do_sc) lb = 4 - ub = 2; IF (do_sc) ub = 3; IF (do_sf) ub = 4 + ub = 2; IF (do_sc) ub = 3 + IF (do_sf) ub = 4 DO i = lb, ub IF (.NOT. ASSOCIATED(xas_tdp_env%ri_fxc(ri_atom, i)%array)) THEN ALLOCATE (xas_tdp_env%ri_fxc(ri_atom, i)%array(nsgfp, nsgfp)) @@ -1368,9 +1369,9 @@ CONTAINS ! If on-diagonal quadrants only, can skip jso < iso IF (.NOT. quadrants(2) .AND. jso < iso) CYCLE - i = iso; j = jso; + i = iso; j = jso IF (my_mt) THEN - i = jso; j = iso; + i = jso; j = iso END IF ! Take the product lhs*rhs^T diff --git a/src/xas_tdp_methods.F b/src/xas_tdp_methods.F index 4b35c3fb8c..5383697020 100644 --- a/src/xas_tdp_methods.F +++ b/src/xas_tdp_methods.F @@ -800,8 +800,9 @@ CONTAINS IF (do_uks) nspins = 2 !in roks, same MOs for both spins ! by default, all (doubly occupied) homo are localized - IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) & + IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) THEN xas_tdp_control%n_search = MINVAL(homo) + END IF CALL qs_loc_control_init(qs_loc_env, loc_section, do_homo=.TRUE., do_xas=.TRUE., & nloc_xas=xas_tdp_control%n_search, spin_xas=1) @@ -2649,9 +2650,11 @@ CONTAINS DO ispin = 1, 2 CALL duplicate_mo_set(restart_mos(ispin), mos(1)) - ! Set the new occupation number in the case of spin-independent based calculation since the restart is spin-depedent - IF (SIZE(mos) == 1) & + ! Set the new occupation number in the case of spin-independent based calculation + ! since the restart is spin-depedent + IF (SIZE(mos) == 1) THEN restart_mos(ispin)%occupation_numbers = mos(1)%occupation_numbers/2 + END IF END DO CALL cp_fm_to_fm_submat(msource=lr_coeffs, mtarget=restart_mos(1)%mo_coeff, nrow=nao, & diff --git a/src/xas_tp_scf.F b/src/xas_tp_scf.F index cfe95963c8..6ddd2c0d29 100644 --- a/src/xas_tp_scf.F +++ b/src/xas_tp_scf.F @@ -545,8 +545,9 @@ CONTAINS END IF END DO ! istate - IF (my_state == 0) & + IF (my_state == 0) THEN CPABORT("Could not identify the core state to be excited") + END IF xas_estate = my_state CALL get_mo_set(mos(my_spin), mo_coeff=mo_coeff) CALL cp_fm_get_submatrix(mo_coeff, vecbuffer, 1, xas_estate, & diff --git a/src/xc/xc.F b/src/xc/xc.F index dde7ee5893..d7c24f7e27 100644 --- a/src/xc/xc.F +++ b/src/xc/xc.F @@ -277,7 +277,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -312,7 +312,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -349,7 +349,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -378,7 +378,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -990,8 +990,9 @@ CONTAINS needs = xc_functionals_get_needs(xc_fun_section, lsd, .TRUE.) IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) & + IF (.NOT. ASSOCIATED(tau1_r)) THEN CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") + END IF ALLOCATE (v_xc_tau(nspins)) DO ispin = 1, nspins CALL pw_pool%create_pw(v_xc_tau(ispin)) @@ -2165,8 +2166,9 @@ CONTAINS END DO END IF - IF (laplace_f .AND. my_gapw) & + IF (laplace_f .AND. my_gapw) THEN CPABORT("Laplace-dependent functional not implemented with GAPW!") + END IF IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) CALL allocate_pw(virial_pw, pw_pool, bo) @@ -3416,8 +3418,7 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) & - tau => tau_r + IF (PRESENT(tau_r)) tau => tau_r IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, & @@ -3481,8 +3482,7 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) & - tau => tau_r + IF (PRESENT(tau_r)) tau => tau_r my_do_sf = .FALSE. IF (PRESENT(do_sf)) my_do_sf = do_sf @@ -3590,8 +3590,9 @@ CONTAINS CPABORT("Normalization of derivative requires any of norm_drhob or drhob!") END IF CASE (deriv_rho, deriv_tau, deriv_laplace_rho) - IF (lsd) & + IF (lsd) THEN CPABORT(TRIM(id_to_desc(split_desc(idesc)))//" not handled in lsd!'") + END IF CASE (deriv_rhoa, deriv_rhob, deriv_tau_a, deriv_tau_b, deriv_laplace_rhoa, deriv_laplace_rhob) CASE default CPABORT("Unknown derivative id") diff --git a/src/xc/xc_derivative_set_types.F b/src/xc/xc_derivative_set_types.F index a7227a7135..3c696c4fbe 100644 --- a/src/xc/xc_derivative_set_types.F +++ b/src/xc/xc_derivative_set_types.F @@ -121,8 +121,9 @@ CONTAINS derivative_set%pw_pool => pw_pool CALL pw_pool%retain() IF (PRESENT(local_bounds)) THEN - IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) & + IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) THEN CPABORT("incompatible local_bounds and pw_pool") + END IF END IF ELSE !FM ugly hack, should be replaced by a pool only for 3d arrays diff --git a/src/xc/xc_derivatives.F b/src/xc/xc_derivatives.F index 846f254921..16702c65f9 100644 --- a/src/xc/xc_derivatives.F +++ b/src/xc/xc_derivatives.F @@ -676,8 +676,9 @@ CONTAINS max_deriv_min = MIN(max_deriv_min, max_deriv_i) END DO IF (PRESENT(max_deriv)) max_deriv = max_deriv_min - IF (PRESENT(reference)) & + IF (PRESENT(reference)) THEN reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" + END IF IF (PRESENT(shortform)) shortform = "GAUXC ("//TRIM(xc_fun_name)//")" END SUBROUTINE gauxc_model_none_xc_info diff --git a/src/xc/xc_functionals_utilities.F b/src/xc/xc_functionals_utilities.F index 933ead184a..ac52974c52 100644 --- a/src/xc/xc_functionals_utilities.F +++ b/src/xc/xc_functionals_utilities.F @@ -259,16 +259,20 @@ CONTAINS IF (m >= 2) fx(ip, 3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(ip, 4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) & + IF (m >= 0) THEN fx(ip, 1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - IF (m >= 1) & + END IF + IF (m >= 1) THEN fx(ip, 2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - IF (m >= 2) & + END IF + IF (m >= 2) THEN fx(ip, 3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - IF (m >= 3) & + END IF + IF (m >= 3) THEN fx(ip, 4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) + END IF END IF END IF END DO @@ -314,16 +318,20 @@ CONTAINS IF (m >= 2) fx(3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) & + IF (m >= 0) THEN fx(1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - IF (m >= 1) & + END IF + IF (m >= 1) THEN fx(2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - IF (m >= 2) & + END IF + IF (m >= 2) THEN fx(3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - IF (m >= 3) & + END IF + IF (m >= 3) THEN fx(4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) + END IF END IF END IF diff --git a/src/xc/xc_gauxc_cache.F b/src/xc/xc_gauxc_cache.F index 5da9d0aee3..8f17efff45 100644 --- a/src/xc/xc_gauxc_cache.F +++ b/src/xc/xc_gauxc_cache.F @@ -139,13 +139,13 @@ CONTAINS cache%molecule = gauxc_create_molecule( & particle_set, & status) - IF (status%status%code /= 0) GO TO 100 + IF (status%status%code /= 0) GOTO 100 cache%basisset = gauxc_create_basisset( & qs_kind_set, & particle_set, & status) - IF (status%status%code /= 0) GO TO 200 + IF (status%status%code /= 0) GOTO 200 params%use_fd_gradient = & params%use_fd_gradient .AND. (cache%max_l() > 3) @@ -195,7 +195,7 @@ CONTAINS status, & mpi_comm=para_env%get_handle()) END IF - IF (status%status%code /= 0) GO TO 300 + IF (status%status%code /= 0) GOTO 300 cache%integrator = gauxc_create_integrator( & TRIM(params%xc_fun_name), & @@ -204,7 +204,7 @@ CONTAINS params%lwd_kernel, & params%nspins, & status) - IF (status%status%code /= 0) GO TO 400 + IF (status%status%code /= 0) GOTO 400 IF (params%use_gradient_self_runtime) THEN ! Upstream GauXC does not yet support OneDFT/SKALA nuclear gradients @@ -222,7 +222,7 @@ CONTAINS status, & mpi_comm=mp_comm_self%get_handle(), & force_new_runtime=.TRUE.) - IF (status%status%code /= 0) GO TO 500 + IF (status%status%code /= 0) GOTO 500 cache%gradient_integrator = gauxc_create_integrator( & TRIM(params%xc_fun_name), & cache%gradient_grid, & @@ -230,7 +230,7 @@ CONTAINS params%lwd_kernel, & params%nspins, & status) - IF (status%status%code /= 0) GO TO 600 + IF (status%status%code /= 0) GOTO 600 END IF cache%natom = params%natom @@ -250,8 +250,9 @@ CONTAINS cache%use_gradient_self_runtime = params%use_gradient_self_runtime cache%use_self_runtime = params%use_self_runtime cache%use_fd_gradient = params%use_fd_gradient - IF (ALLOCATED(cache%last_positions)) & + IF (ALLOCATED(cache%last_positions)) THEN DEALLOCATE (cache%last_positions) + END IF ALLOCATE (cache%last_positions(3, params%natom)) BLOCK @@ -271,31 +272,32 @@ CONTAINS 100 CONTINUE CALL gauxc_destroy_molecule(cache%molecule, status) CALL gauxc_check_status(status) - GO TO 999 + GOTO 999 200 CONTINUE CALL gauxc_destroy_basisset(cache%basisset, status) CALL gauxc_check_status(status) - GO TO 100 + GOTO 100 300 CONTINUE CALL gauxc_destroy_grid(cache%grid, status) CALL gauxc_check_status(status) - GO TO 200 + GOTO 200 400 CONTINUE CALL gauxc_destroy_integrator(cache%integrator, status) CALL gauxc_check_status(status) - GO TO 300 + GOTO 300 500 CONTINUE CALL gauxc_destroy_grid(cache%gradient_grid, status) CALL gauxc_check_status(status) - GO TO 400 + GOTO 400 600 CONTINUE CALL gauxc_destroy_integrator(cache%gradient_integrator, status) CALL gauxc_check_status(status) + GOTO 500 999 CONTINUE IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) diff --git a/src/xc/xc_libxc.F b/src/xc/xc_libxc.F index 4c58f994a0..6b0340a0bf 100644 --- a/src/xc/xc_libxc.F +++ b/src/xc/xc_libxc.F @@ -608,8 +608,9 @@ CONTAINS CALL xc_f03_func_init(xc_func, func_id, XC_UNPOLARIZED) xc_info = xc_f03_func_get_info(xc_func) no_exc = .FALSE. - IF (.NOT. PRESENT(func_name_override)) & + IF (.NOT. PRESENT(func_name_override)) THEN CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + END IF CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rho=rho, norm_drho=norm_drho, laplace_rho=laplace_rho, & @@ -867,8 +868,9 @@ CONTAINS CALL xc_f03_func_init(xc_func, func_id, XC_POLARIZED) xc_info = xc_f03_func_get_info(xc_func) no_exc = .FALSE. - IF (.NOT. PRESENT(func_name_override)) & + IF (.NOT. PRESENT(func_name_override)) THEN CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + END IF CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, & diff --git a/src/xc/xc_libxc_wrap.F b/src/xc/xc_libxc_wrap.F index b8c0ed8962..e070d9f6f3 100644 --- a/src/xc/xc_libxc_wrap.F +++ b/src/xc/xc_libxc_wrap.F @@ -105,9 +105,10 @@ MODULE xc_libxc_wrap section_release, & section_type, section_vals_type, section_vals_val_get #include "../base/base_uses.f90" - +#endif IMPLICIT NONE PRIVATE +#if defined (__LIBXC) CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xc_libxc_wrap' diff --git a/src/xc/xc_pade.F b/src/xc/xc_pade.F index 2be8e39fa3..2a2b413b26 100644 --- a/src/xc/xc_pade.F +++ b/src/xc/xc_pade.F @@ -118,8 +118,9 @@ CONTAINS END IF IF (PRESENT(needs)) THEN - IF (.NOT. PRESENT(lsd)) & + IF (.NOT. PRESENT(lsd)) THEN CPABORT("Arguments mismatch.") + END IF IF (lsd) THEN needs%rho_spin = .TRUE. ELSE diff --git a/src/xc/xc_perdew86.F b/src/xc/xc_perdew86.F index 386c1bd48e..559927a21e 100644 --- a/src/xc/xc_perdew86.F +++ b/src/xc/xc_perdew86.F @@ -36,8 +36,6 @@ MODULE xc_perdew86 PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_perdew_zunger.F b/src/xc/xc_perdew_zunger.F index eede7b4efa..c5870410fd 100644 --- a/src/xc/xc_perdew_zunger.F +++ b/src/xc/xc_perdew_zunger.F @@ -296,7 +296,7 @@ CONTAINS dummy => a e_0 => dummy - ea => dummy; + ea => dummy eaa => dummy; eab => dummy; ebb => dummy eaaa => dummy; eaab => dummy; eabb => dummy; ebbb => dummy diff --git a/src/xc/xc_rho_set_types.F b/src/xc/xc_rho_set_types.F index f44aaf8ce4..da711debed 100644 --- a/src/xc/xc_rho_set_types.F +++ b/src/xc/xc_rho_set_types.F @@ -620,8 +620,9 @@ CONTAINS do_sf = .FALSE. IF (PRESENT(spinflip)) do_sf = spinflip - IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) & + IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) THEN CPABORT("pw_pool cr3d have different size than expected") + END IF nspins = SIZE(rho_r) rho_set%local_bounds = rho_r(1)%pw_grid%bounds_local rho_cutoff = 0.5*rho_set%rho_cutoff diff --git a/src/xc/xc_tfw.F b/src/xc/xc_tfw.F index c46167a7d2..57f1d74478 100644 --- a/src/xc/xc_tfw.F +++ b/src/xc/xc_tfw.F @@ -16,6 +16,7 @@ MODULE xc_tfw USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_norm_drho,& deriv_norm_drhoa,& deriv_norm_drhob,& @@ -37,8 +38,6 @@ MODULE xc_tfw PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_thomas_fermi.F b/src/xc/xc_thomas_fermi.F index 61765ad154..32584bd0ae 100644 --- a/src/xc/xc_thomas_fermi.F +++ b/src/xc/xc_thomas_fermi.F @@ -18,6 +18,7 @@ MODULE xc_thomas_fermi USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& deriv_rhob @@ -36,8 +37,6 @@ MODULE xc_thomas_fermi PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_vwn.F b/src/xc/xc_vwn.F index 528117d098..29739a1179 100644 --- a/src/xc/xc_vwn.F +++ b/src/xc/xc_vwn.F @@ -200,13 +200,13 @@ CONTAINS CALL xc_derivative_get(deriv, deriv_data=e_rho) CALL vwn_lda_01(rho, x, e_0, e_rho, npoints, sc) - ELSEIF (order >= 0) THEN + ELSE IF (order >= 0) THEN deriv => xc_dset_get_derivative(deriv_set, [INTEGER::], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_0) CALL vwn_lda_0(rho, x, e_0, npoints, sc) - ELSEIF (order == -1) THEN + ELSE IF (order == -1) THEN deriv => xc_dset_get_derivative(deriv_set, [deriv_rho], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_rho) diff --git a/src/xc/xc_xalpha.F b/src/xc/xc_xalpha.F index 8c260959e5..e9a0912979 100644 --- a/src/xc/xc_xalpha.F +++ b/src/xc/xc_xalpha.F @@ -21,6 +21,7 @@ MODULE xc_xalpha USE input_section_types, ONLY: section_vals_type,& section_vals_val_get USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE pw_types, ONLY: pw_r3d_rs_type USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& @@ -40,8 +41,6 @@ MODULE xc_xalpha PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13 diff --git a/src/xc_adiabatic_utils.F b/src/xc_adiabatic_utils.F index 7a304c6770..f50f1f790a 100644 --- a/src/xc_adiabatic_utils.F +++ b/src/xc_adiabatic_utils.F @@ -134,10 +134,11 @@ CONTAINS CASE (do_adiabatic_hybrid_mcy3) SELECT CASE (adiabatic_model) CASE (do_adiabatic_model_pade) - IF (n_rep_hf /= 2) & + IF (n_rep_hf /= 2) THEN CALL cp_abort(__LOCATION__, & "For this kind of adiababatic hybrid functional 2 HF sections have to be provided. "// & "Please check your input file.") + END IF CALL rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & adiabatic_omega, scale_dEx1, scale_ddW0, scale_dDFA, & scale_dEx2, total_energy_xc) diff --git a/src/xc_pot_saop.F b/src/xc_pot_saop.F index 186d29c5d6..2034fd550c 100644 --- a/src/xc_pot_saop.F +++ b/src/xc_pot_saop.F @@ -855,29 +855,35 @@ CONTAINS IF (lsd) THEN DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) & + IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) THEN vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rhoa(ia, ir, 1) - IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) & + END IF + IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) THEN vxc_GLLB_h(ia, ir, 2) = vxc_GLLB_h(ia, ir, 2) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 2)/rho_set_h%rhob(ia, ir, 1) - IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) & + END IF + IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) THEN vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rhoa(ia, ir, 1) - IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) & + END IF + IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) THEN vxc_GLLB_s(ia, ir, 2) = vxc_GLLB_s(ia, ir, 2) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 2)/rho_set_s%rhob(ia, ir, 1) + END IF END DO END DO ELSE DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) & + IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) THEN vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rho(ia, ir, 1) - IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) & + END IF + IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) THEN vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rho(ia, ir, 1) + END IF END DO END DO END IF diff --git a/src/xtb_coulomb.F b/src/xtb_coulomb.F index f079817d9b..a95fdcede7 100644 --- a/src/xtb_coulomb.F +++ b/src/xtb_coulomb.F @@ -709,7 +709,7 @@ CONTAINS IF (rab < 1.e-6_dp) THEN ! on site terms gmat(:, :) = eta(:, :) - ELSEIF (rab > rcut) THEN + ELSE IF (rab > rcut) THEN ! do nothing ELSE rk = rab**kg @@ -777,7 +777,7 @@ CONTAINS IF (rab < 1.e-6) THEN ! on site terms dgmat(:, :) = 0.0_dp - ELSEIF (rab > rcut) THEN + ELSE IF (rab > rcut) THEN dgmat(:, :) = 0.0_dp ELSE eta = eta**(-kg) diff --git a/src/xtb_hcore.F b/src/xtb_hcore.F index 0e182950b3..8b7565eb05 100644 --- a/src/xtb_hcore.F +++ b/src/xtb_hcore.F @@ -156,7 +156,7 @@ CONTAINS CALL get_atomic_kind(atomic_kind_set(ikind), z=za) IF (metal(za)) THEN kcnlk(0:3, ikind) = 0.0_dp - ELSEIF (early3d(za)) THEN + ELSE IF (early3d(za)) THEN kcnlk(0, ikind) = kcns kcnlk(1, ikind) = kcnp kcnlk(2, ikind) = 0.005_dp @@ -278,7 +278,7 @@ CONTAINS ELSE km = km*kdiff END IF - ELSEIF (zb == 1 .AND. nb == 2) THEN + ELSE IF (zb == 1 .AND. nb == 2) THEN km = km*kdiff END IF kijab(i, j, ikind, jkind) = km diff --git a/src/xtb_ks_matrix.F b/src/xtb_ks_matrix.F index 527f5f20b0..b9725df4fe 100644 --- a/src/xtb_ks_matrix.F +++ b/src/xtb_ks_matrix.F @@ -190,9 +190,10 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge equilibration energy: ", energy%eeq, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield @@ -441,12 +442,14 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge fluctuation energy: ", energy%hartree, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) & + IF (dft_control%qs_control%xtb_control%xb_interaction) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + "Correction for halogen bonding: ", energy%xtb_xb_inter + END IF + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield diff --git a/src/xtb_parameters.F b/src/xtb_parameters.F index 0c79a46c19..67bb511bd2 100644 --- a/src/xtb_parameters.F +++ b/src/xtb_parameters.F @@ -69,9 +69,11 @@ MODULE xtb_parameters 0.98_dp, 1.57_dp, 2.04_dp, 2.55_dp, 3.04_dp, 3.44_dp, 3.98_dp, 4.50_dp, & ! 10 0.93_dp, 1.31_dp, 1.61_dp, 1.90_dp, 2.19_dp, 2.58_dp, 3.16_dp, 3.50_dp, & ! 18 0.82_dp, 1.00_dp, 1.36_dp, 1.54_dp, 1.63_dp, 1.66_dp, 1.55_dp, 1.83_dp, & - 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, 2.96_dp, 3.00_dp, & ! 36 + 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, & + 2.96_dp, 3.00_dp, & ! 36 0.82_dp, 0.95_dp, 1.22_dp, 1.33_dp, 1.60_dp, 2.16_dp, 1.90_dp, 2.20_dp, & - 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, 2.66_dp, 2.60_dp, & ! 54 + 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, & + 2.66_dp, 2.60_dp, & ! 54 0.79_dp, 0.89_dp, 1.10_dp, & 1.12_dp, 1.13_dp, 1.14_dp, 1.15_dp, 1.17_dp, 1.18_dp, 1.20_dp, 1.21_dp, & 1.22_dp, 1.23_dp, 1.24_dp, 1.25_dp, 1.26_dp, 1.27_dp, & ! Lanthanides @@ -116,9 +118,11 @@ MODULE xtb_parameters 1.30_dp, 0.99_dp, 0.84_dp, 0.75_dp, 0.71_dp, 0.64_dp, 0.60_dp, 0.62_dp, & ! 10 1.60_dp, 1.40_dp, 1.24_dp, 1.14_dp, 1.09_dp, 1.04_dp, 1.00_dp, 1.01_dp, & ! 18 2.00_dp, 1.74_dp, 1.59_dp, 1.48_dp, 1.44_dp, 1.30_dp, 1.29_dp, 1.24_dp, & - 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, 1.17_dp, 1.16_dp, & ! 36 + 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, & + 1.17_dp, 1.16_dp, & ! 36 2.15_dp, 1.90_dp, 1.76_dp, 1.64_dp, 1.56_dp, 1.46_dp, 1.38_dp, 1.36_dp, & - 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, 1.36_dp, 1.36_dp, & ! 54 + 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, & + 1.36_dp, 1.36_dp, & ! 54 2.38_dp, 2.06_dp, 1.94_dp, & 1.84_dp, 1.90_dp, 1.88_dp, 1.86_dp, 1.85_dp, 1.83_dp, 1.82_dp, 1.81_dp, & 1.80_dp, 1.79_dp, 1.77_dp, 1.77_dp, 1.78_dp, 1.74_dp, & ! Lanthanides @@ -138,9 +142,11 @@ MODULE xtb_parameters 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 10 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 18 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 36 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & + 1.25_dp, 1.00_dp, & ! 36 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 54 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & + 1.25_dp, 1.00_dp, & ! 54 1.05_dp, 2.05_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & ! Lanthanides @@ -646,14 +652,14 @@ CONTAINS CASE (78) kab = 0.80_dp END SELECT - ELSEIF (za == 5 .OR. zb == 5) THEN + ELSE IF (za == 5 .OR. zb == 5) THEN ! Boron z = za + zb - 5 SELECT CASE (z) CASE (15) kab = 0.97_dp END SELECT - ELSEIF (za == 7 .OR. zb == 7) THEN + ELSE IF (za == 7 .OR. zb == 7) THEN ! Nitrogen z = za + zb - 7 SELECT CASE (z) @@ -662,21 +668,21 @@ CONTAINS ! in the paper this is Kab for B-Si kab = 1.01_dp END SELECT - ELSEIF (za > 20 .AND. za < 30) THEN + ELSE IF (za > 20 .AND. za < 30) THEN ! 3d IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 1.10_dp - ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 0.50_dp*(1.20_dp + 1.10_dp) END IF - ELSEIF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN + ELSE IF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN ! 4d/5d/4f IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 0.50_dp*(1.20_dp + 1.10_dp) - ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 1.20_dp END IF diff --git a/src/xtb_potentials.F b/src/xtb_potentials.F index 36028812aa..07dab22561 100644 --- a/src/xtb_potentials.F +++ b/src/xtb_potentials.F @@ -807,10 +807,11 @@ CONTAINS ((name_atm_a) == (nonbonded%pot(ingp)%pot%at2)))) THEN CALL pair_potential_single_copy(nonbonded%pot(ingp)%pot, pot) ! multiple potential not implemented, simply overwriting - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") + END IF !IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. END IF diff --git a/src/xtb_types.F b/src/xtb_types.F index 51240aabdf..9ec859eae6 100644 --- a/src/xtb_types.F +++ b/src/xtb_types.F @@ -99,8 +99,9 @@ CONTAINS TYPE(xtb_atom_type), POINTER :: xtb_parameter - IF (ASSOCIATED(xtb_parameter)) & + IF (ASSOCIATED(xtb_parameter)) THEN CALL deallocate_xtb_atom_param(xtb_parameter) + END IF ALLOCATE (xtb_parameter) diff --git a/tools/precommit/fortitude.toml b/tools/precommit/fortitude.toml index 71813b713f..f613397e65 100644 --- a/tools/precommit/fortitude.toml +++ b/tools/precommit/fortitude.toml @@ -7,39 +7,51 @@ ignore = [ "non-standard-file-extension", "implicit-external-procedures", # requires Fortran 2018 "missing-intent", + "bad-quote-string", + "literal-kind", "assumed-size", "assumed-size-character-intent", - "external-procedure", - "literal-kind", "interface-implicit-typing", - "implicit-typing", - "missing-accessibility-statement", + "missing-default-case", + "external-procedure", + "trailing-backslash", ] # ============================================================================== # The following files can not be parsed by Fortitude. # Usually because Fortran statements are inter-leafed with pre-processor macros. exclude = [ - "pw_methods.F", "local_gemm_api.F", - "cp_fm_diag.F", - "cp_fm_cholesky.F", - "cp_fm_basic_linalg.F", - "cp_cfm_diag.F", - "cp_cfm_cholesky.F", - "cp_cfm_basic_linalg.F", - "dbt_split.F", - "dbt_tas_util.F", - "dbt_array_list_methods.F", - "xc_libxc_wrap.F", - "ai_contraction_sphi.F", "smeagol_control_types.F", + "ai_contraction_sphi.F", + "qs_loc_states.F", + "dbt_array_list_methods.F", + "cp_cfm_basic_linalg.F", + "cp_cfm_diag.F", + "cp_fm_basic_linalg.F", + "cp_fm_cholesky.F", + "cp_fm_diag.F", + "message_passing.F", + "dbt_split.F", + "cp_cfm_cholesky.F", + "pw_methods.F", + "xc_libxc_wrap.F", + "dbt_tas_util.F", ] # ============================================================================== [check.per-file-ignores] -"semi_empirical_int_debug.F" = ["procedure-not-in-module"] -"gopt_f77_methods.F" = ["procedure-not-in-module"] +"environment.F" = ["line-too-long"] +"libgint_wrapper.F" = ["trailing-backslash"] +"qs_block_davidson_types.F" = ["trailing-backslash"] +"qs_linres_current.F" = ["trailing-backslash"] +"qs_local_properties.F" = ["unreachable-statement"] +"qs_tddfpt2_subgroups.F" = ["trailing-backslash"] +"semi_empirical_int_ana.F" = ["misleading-inline-if-semicolon"] "pilaenv_hack.F" = ["procedure-not-in-module"] +"semi_empirical_int_debug.F" = ["procedure-not-in-module"] +"eri_mme_lattice_summation.F" = ["trailing-whitespace"] +"gopt_f77_methods.F" = ["procedure-not-in-module"] +"fftw3_lib.F" = ["misleading-inline-if-semicolon"] #EOF diff --git a/tools/precommit/requirements.txt b/tools/precommit/requirements.txt index efef9f6b05..ff1aa191ec 100644 --- a/tools/precommit/requirements.txt +++ b/tools/precommit/requirements.txt @@ -4,7 +4,7 @@ click==8.3.1 cmake-format==0.6.13 cmakelang==0.6.13 Flask==3.1.3 -fortitude-lint==0.7.5 +fortitude-lint==0.9.0 gunicorn==25.1.0 itsdangerous==2.2.0 Jinja2==3.1.6 From df8ab74de53a29cd0b976b722f2646c49edee6ff Mon Sep 17 00:00:00 2001 From: SY Wang Date: Fri, 17 Jul 2026 19:05:07 +0800 Subject: [PATCH 05/30] CMake: Move out-of-source builds requirement more ahead (#5585) --- CMakeLists.txt | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 075f91973c..23ce2b7a74 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -10,6 +10,15 @@ cmake_minimum_required(VERSION 3.24) # include our cmake snippets set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} ${CMAKE_CURRENT_SOURCE_DIR}/cmake) +# Require out-of-source builds +file(TO_CMAKE_PATH "${CMAKE_BINARY_DIR}/CMakeLists.txt" LOC_PATH) +if(EXISTS "${LOC_PATH}") + message( + FATAL_ERROR + "You cannot build in a source directory (or any directory with a CMakeLists.txt file). " + "Please make a build subdirectory.") +endif() + # ================================================================================================= # PROJECT AND VERSION include(CMakeDependentOption) @@ -31,15 +40,6 @@ project( list(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/cmake/modules") -# Require out-of-source builds -file(TO_CMAKE_PATH "${PROJECT_BINARY_DIR}/CMakeLists.txt" LOC_PATH) -if(EXISTS "${LOC_PATH}") - message( - FATAL_ERROR - "You cannot build in a source directory (or any directory with a CMakeLists.txt file). Please make a build subdirectory." - ) -endif() - # set language and standard. # # cmake does not provide any mechanism to set the fortran standard. Adding the From 8f16beb0399a8ab5c7d24d10a5343a61d661667a Mon Sep 17 00:00:00 2001 From: SY Wang Date: Fri, 17 Jul 2026 20:14:45 +0800 Subject: [PATCH 06/30] Move SCF MO k-point symmetry transform helper out of qs_wannier90 (#5598) --- src/CMakeLists.txt | 1 + src/kpoint_mo_symmetry_methods.F | 238 ++++++++++++++++++++++++++++++ src/qs_wannier90.F | 242 +++---------------------------- 3 files changed, 259 insertions(+), 222 deletions(-) create mode 100644 src/kpoint_mo_symmetry_methods.F diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a31daadb31..89417a3cf5 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -329,6 +329,7 @@ list( kpoint_k_r_trafo_simple.F kpoint_methods.F kpoint_mo_dump.F + kpoint_mo_symmetry_methods.F kpoint_transitional.F kpoint_types.F kpsym.F diff --git a/src/kpoint_mo_symmetry_methods.F b/src/kpoint_mo_symmetry_methods.F new file mode 100644 index 0000000000..3483dc7889 --- /dev/null +++ b/src/kpoint_mo_symmetry_methods.F @@ -0,0 +1,238 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Utilities for transforming k-point MO coefficients under symmetry operations +! ************************************************************************************************** +MODULE kpoint_mo_symmetry_methods + USE cp_fm_types, ONLY: cp_fm_copy_general,& + cp_fm_get_info,& + cp_fm_get_submatrix,& + cp_fm_set_submatrix,& + cp_fm_type + USE kinds, ONLY: dp + USE kpoint_types, ONLY: kind_rotmat_type,& + kpoint_sym_type,& + kpoint_type + USE mathconstants, ONLY: twopi + USE message_passing, ONLY: mp_para_env_type +#include "./base/base_uses.f90" + + IMPLICIT NONE + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'kpoint_mo_symmetry_methods' + + PUBLIC :: kpoint_same_periodic, & + kpoint_transform_scf_mo + +CONTAINS + +! ************************************************************************************************** +!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. +!> \param xkp_a first k-point +!> \param xkp_b second k-point +!> \return true if the k-points are equivalent +! ************************************************************************************************** + LOGICAL FUNCTION kpoint_same_periodic(xkp_a, xkp_b) RESULT(same) + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b + + REAL(KIND=dp), DIMENSION(3) :: diff + + diff(1:3) = xkp_a(1:3) - xkp_b(1:3) + diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) + same = SUM(ABS(diff(1:3))) < 1.0e-8_dp + + END FUNCTION kpoint_same_periodic + +! ************************************************************************************************** +!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. +!> \param src_real real part of source MO coefficients +!> \param src_imag imaginary part of source MO coefficients +!> \param dst_real real part of transformed MO coefficients +!> \param dst_imag imaginary part of transformed MO coefficients +!> \param qs_kpoint SCF k-point object containing symmetry operations +!> \param ikred representative k-point index +!> \param isym symmetry operation index; 0 direct copy, -1 time reversal +!> \param para_env global parallel environment +!> \param success true if the transformation was performed +!> \param reason diagnostic message +! ************************************************************************************************** + SUBROUTINE kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & + isym, para_env, success, reason) + TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: ikred, isym + TYPE(mp_para_env_type), POINTER :: para_env + LOGICAL, INTENT(OUT) :: success + CHARACTER(LEN=*), INTENT(OUT) :: reason + + INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & + nmo, rot_slot, source_atom, source_dim, target_atom, target_dim + INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start + LOGICAL :: reverse_phase, time_reversal + REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & + phase_imag, phase_real, sinkl + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r + REAL(KIND=dp), DIMENSION(3) :: xkp_phase + REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat + TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot + TYPE(kpoint_sym_type), POINTER :: kpsym + + success = .FALSE. + reason = "" + IF (isym == 0) THEN + CALL cp_fm_copy_general(src_real, dst_real, para_env) + CALL cp_fm_copy_general(src_imag, dst_imag, para_env) + success = .TRUE. + RETURN + END IF + + CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) + ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) + CALL cp_fm_get_submatrix(src_real, src_r) + CALL cp_fm_get_submatrix(src_imag, src_i) + dst_r(:, :) = 0.0_dp + dst_i(:, :) = 0.0_dp + + IF (isym == -1) THEN + dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) + dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i) + success = .TRUE. + RETURN + END IF + + IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN + reason = "SCF symmetry operation data are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym + IF (.NOT. ASSOCIATED(kpsym)) THEN + reason = "SCF k-point symmetry operation is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (isym > kpsym%nwred) THEN + reason = "SCF k-point symmetry operation index is out of range" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN + reason = "SCF atom mappings or basis rotation matrices are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + + rot_slot = find_kpoint_rotation_slot(qs_kpoint, kpsym%rotp(isym)) + IF (rot_slot == 0) THEN + reason = "could not match the SCF symmetry operation to a basis rotation" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) + natom = SIZE(qs_kpoint%atype) + ALLOCATE (ao_start(natom), ao_size(natom)) + irow = 1 + DO iatom = 1, natom + ikind = qs_kpoint%atype(iatom) + IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN + reason = "a required basis rotation matrix is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + ao_start(iatom) = irow + ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) + irow = irow + ao_size(iatom) + END DO + IF (irow - 1 /= nao) THEN + reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + + time_reversal = kpsym%rotp(isym) < 0 + reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) + IF (ASSOCIATED(kpsym%phase_mode)) THEN + IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 + END IF + xkp_phase(1:3) = kpsym%xkp(1:3, isym) + DO iatom = 1, natom + source_atom = iatom + target_atom = kpsym%f0(iatom, isym) + ikind = qs_kpoint%atype(source_atom) + rotmat => kind_rot(ikind)%rmat + source_dim = ao_size(source_atom) + target_dim = ao_size(target_atom) + IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN + reason = "basis rotation dimensions do not match the atom/AO symmetry transform" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & + REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & + REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) + IF (ASSOCIATED(kpsym%kgphase)) THEN + arg = arg + kpsym%kgphase(source_atom, isym) + END IF + IF (reverse_phase) arg = -arg + coskl = COS(twopi*arg) + sinkl = SIN(twopi*arg) + DO imo = 1, nmo + DO irow_work = 1, source_dim + irow_source = ao_start(source_atom) + irow_work - 1 + coeff_real = src_r(irow_source, imo) + coeff_imag = src_i(irow_source, imo) + IF (time_reversal) coeff_imag = -coeff_imag + phase_real = coskl*coeff_real - sinkl*coeff_imag + phase_imag = sinkl*coeff_real + coskl*coeff_imag + DO iao = 1, target_dim + irow_target = ao_start(target_atom) + iao - 1 + dst_r(irow_target, imo) = dst_r(irow_target, imo) + & + rotmat(iao, irow_work)*phase_real + dst_i(irow_target, imo) = dst_i(irow_target, imo) + & + rotmat(iao, irow_work)*phase_imag + END DO + END DO + END DO + END DO + + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + success = .TRUE. + + END SUBROUTINE kpoint_transform_scf_mo + +! ************************************************************************************************** +!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. +!> \param qs_kpoint SCF k-point object +!> \param rotp signed operation identifier +!> \return rotation slot, or zero when no slot matches +! ************************************************************************************************** + INTEGER FUNCTION find_kpoint_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: rotp + + INTEGER :: irot, rot_abs + + rot_slot = 0 + rot_abs = ABS(rotp) + IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN + DO irot = 1, SIZE(qs_kpoint%ibrot) + IF (rot_abs == qs_kpoint%ibrot(irot)) THEN + rot_slot = irot + RETURN + END IF + END DO + + END FUNCTION find_kpoint_rotation_slot + +END MODULE kpoint_mo_symmetry_methods diff --git a/src/qs_wannier90.F b/src/qs_wannier90.F index 33d326aeec..ad9bb42de0 100644 --- a/src/qs_wannier90.F +++ b/src/qs_wannier90.F @@ -57,8 +57,9 @@ MODULE qs_wannier90 kpoint_initialize_mo_set,& kpoint_initialize_mos,& rskp_transform + USE kpoint_mo_symmetry_methods, ONLY: kpoint_same_periodic,& + kpoint_transform_scf_mo USE kpoint_types, ONLY: get_kpoint_info,& - kind_rotmat_type,& kpoint_create,& kpoint_env_type,& kpoint_release,& @@ -1168,12 +1169,12 @@ CONTAINS num_candidates = 0 ! Little-group operations can reach the same target k-point; keep the first valid eigenspace. DO isym_try = 1, kpsym%nwred - IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & + IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE num_candidates = num_candidates + 1 - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, & - candidate_reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, & + candidate_reason) IF (.NOT. ok) THEN reason = candidate_reason CYCLE @@ -1191,9 +1192,9 @@ CONTAINS END IF IF (.NOT. ok) THEN IF (source_window) THEN - CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, & - dst_real_full, dst_imag_full, qs_kpoint, & - ikred, isym_try, para_env, ok, candidate_reason) + CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, & + dst_real_full, dst_imag_full, qs_kpoint, & + ikred, isym_try, para_env, ok, candidate_reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, & dst_real, dst_imag, matrix_s, & @@ -1239,8 +1240,8 @@ CONTAINS reason = "SCF k-point symmetry operation is not available" END IF ELSE - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) END IF IF (ok .AND. sym_index(ik) <= 0) THEN ! Even a direct k-point copy must be a closed H(k),S(k) subspace. This catches @@ -1251,9 +1252,9 @@ CONTAINS ok, reason, aligned_blocks, aligned_max_size, & aligned_min_svalue, candidate_residual) IF (.NOT. ok .AND. source_window) THEN - CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, dst_real_full, & - dst_imag_full, qs_kpoint, ikred, sym_index(ik), & - para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, dst_real_full, & + dst_imag_full, qs_kpoint, ikred, sym_index(ik), & + para_env, ok, reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, dst_real, & dst_imag, matrix_s, matrix_ks, & @@ -1723,8 +1724,8 @@ CONTAINS best_residual = 0.0_dp best_svalue = 0.0_dp IF (sym_index(ik) <= 0) THEN - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) IF (ok) THEN CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, matrix_s, & kpoint%xkp(1:3, ik), cell_to_index, sab_nl, & @@ -1756,10 +1757,10 @@ CONTAINS kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym IF (ASSOCIATED(kpsym)) THEN DO isym_try = 1, kpsym%nwred - IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & + IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, reason) IF (.NOT. ok) CYCLE CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, & matrix_s, kpoint%xkp(1:3, ik), cell_to_index, & @@ -2615,7 +2616,7 @@ CONTAINS ik_match = 0 DO ik = 1, SIZE(xkp_mesh, 2) - IF (same_periodic_kpoint(xkp_mesh(1:3, ik), xkp_search)) THEN + IF (kpoint_same_periodic(xkp_mesh(1:3, ik), xkp_search)) THEN ik_match = ik RETURN END IF @@ -2623,209 +2624,6 @@ CONTAINS END FUNCTION find_matching_kpoint -! ************************************************************************************************** -!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. -!> \param xkp_a first k-point -!> \param xkp_b second k-point -!> \return true if the k-points are equivalent -! ************************************************************************************************** - LOGICAL FUNCTION same_periodic_kpoint(xkp_a, xkp_b) RESULT(same) - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b - - REAL(KIND=dp), DIMENSION(3) :: diff - - diff(1:3) = xkp_a(1:3) - xkp_b(1:3) - diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) - same = SUM(ABS(diff(1:3))) < 1.0e-8_dp - - END FUNCTION same_periodic_kpoint - -! ************************************************************************************************** -!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. -!> \param src_real real part of source MO coefficients -!> \param src_imag imaginary part of source MO coefficients -!> \param dst_real real part of transformed MO coefficients -!> \param dst_imag imaginary part of transformed MO coefficients -!> \param qs_kpoint SCF k-point object containing symmetry operations -!> \param ikred representative k-point index -!> \param isym symmetry operation index; 0 direct copy, -1 time reversal -!> \param para_env global parallel environment -!> \param success true if the transformation was performed -!> \param reason diagnostic message -! ************************************************************************************************** - SUBROUTINE transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & - isym, para_env, success, reason) - TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: ikred, isym - TYPE(mp_para_env_type), POINTER :: para_env - LOGICAL, INTENT(OUT) :: success - CHARACTER(LEN=*), INTENT(OUT) :: reason - - INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & - nmo, rot_slot, source_atom, source_dim, target_atom, target_dim - INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start - LOGICAL :: reverse_phase, time_reversal - REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & - phase_imag, phase_real, sinkl - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r - REAL(KIND=dp), DIMENSION(3) :: xkp_phase - REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat - TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot - TYPE(kpoint_sym_type), POINTER :: kpsym - - success = .FALSE. - reason = "" - IF (isym == 0) THEN - CALL cp_fm_copy_general(src_real, dst_real, para_env) - CALL cp_fm_copy_general(src_imag, dst_imag, para_env) - success = .TRUE. - RETURN - END IF - - CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) - ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) - CALL cp_fm_get_submatrix(src_real, src_r) - CALL cp_fm_get_submatrix(src_imag, src_i) - dst_r(:, :) = 0.0_dp - dst_i(:, :) = 0.0_dp - - IF (isym == -1) THEN - dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) - dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i) - success = .TRUE. - RETURN - END IF - - IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN - reason = "SCF symmetry operation data are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym - IF (.NOT. ASSOCIATED(kpsym)) THEN - reason = "SCF k-point symmetry operation is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (isym > kpsym%nwred) THEN - reason = "SCF k-point symmetry operation index is out of range" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN - reason = "SCF atom mappings or basis rotation matrices are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - - rot_slot = find_wannier90_rotation_slot(qs_kpoint, kpsym%rotp(isym)) - IF (rot_slot == 0) THEN - reason = "could not match the SCF symmetry operation to a basis rotation" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) - natom = SIZE(qs_kpoint%atype) - ALLOCATE (ao_start(natom), ao_size(natom)) - irow = 1 - DO iatom = 1, natom - ikind = qs_kpoint%atype(iatom) - IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN - reason = "a required basis rotation matrix is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - ao_start(iatom) = irow - ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) - irow = irow + ao_size(iatom) - END DO - IF (irow - 1 /= nao) THEN - reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - - time_reversal = kpsym%rotp(isym) < 0 - reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) - IF (ASSOCIATED(kpsym%phase_mode)) THEN - IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 - END IF - xkp_phase(1:3) = kpsym%xkp(1:3, isym) - DO iatom = 1, natom - source_atom = iatom - target_atom = kpsym%f0(iatom, isym) - ikind = qs_kpoint%atype(source_atom) - rotmat => kind_rot(ikind)%rmat - source_dim = ao_size(source_atom) - target_dim = ao_size(target_atom) - IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN - reason = "basis rotation dimensions do not match the atom/AO symmetry transform" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & - REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & - REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) - IF (ASSOCIATED(kpsym%kgphase)) THEN - arg = arg + kpsym%kgphase(source_atom, isym) - END IF - IF (reverse_phase) arg = -arg - coskl = COS(twopi*arg) - sinkl = SIN(twopi*arg) - DO imo = 1, nmo - DO irow_work = 1, source_dim - irow_source = ao_start(source_atom) + irow_work - 1 - coeff_real = src_r(irow_source, imo) - coeff_imag = src_i(irow_source, imo) - IF (time_reversal) coeff_imag = -coeff_imag - phase_real = coskl*coeff_real - sinkl*coeff_imag - phase_imag = sinkl*coeff_real + coskl*coeff_imag - DO iao = 1, target_dim - irow_target = ao_start(target_atom) + iao - 1 - dst_r(irow_target, imo) = dst_r(irow_target, imo) + & - rotmat(iao, irow_work)*phase_real - dst_i(irow_target, imo) = dst_i(irow_target, imo) + & - rotmat(iao, irow_work)*phase_imag - END DO - END DO - END DO - END DO - - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - success = .TRUE. - - END SUBROUTINE transform_wannier90_scf_mo - -! ************************************************************************************************** -!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. -!> \param qs_kpoint SCF k-point object -!> \param rotp signed operation identifier -!> \return rotation slot, or zero when no slot matches -! ************************************************************************************************** - INTEGER FUNCTION find_wannier90_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: rotp - - INTEGER :: irot, rot_abs - - rot_slot = 0 - rot_abs = ABS(rotp) - IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN - DO irot = 1, SIZE(qs_kpoint%ibrot) - IF (rot_abs == qs_kpoint%ibrot(irot)) THEN - rot_slot = irot - RETURN - END IF - END DO - - END FUNCTION find_wannier90_rotation_slot - ! ************************************************************************************************** !> \brief Infer a tensor-product Wannier90 mesh from explicit fractional k-point coordinates. !> \param kpt_latt explicit k-point coordinates in reciprocal-lattice units From 4ca962cc2cb0d831c0227a93abc40b223162b586 Mon Sep 17 00:00:00 2001 From: Jiacheng Xu <13862180016@163.com> Date: Fri, 17 Jul 2026 20:16:57 +0800 Subject: [PATCH 07/30] CMake: Fix dependent option declarations (#5601) --- CMakeLists.txt | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 23ce2b7a74..e5e5b846e5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -226,18 +226,18 @@ cmake_dependent_option( CP2K_USE_CUSOLVER_MP "Enable cuSOLVERMp. Only active when CUDA is ON" OFF "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) -cmake_dependent_option(CP2K_USE_NVHPC OFF "Enable Nvidia NVHPC kit" - "(NOT CP2K_USE_ACCEL MATCHES \"CUDA\")" OFF) +cmake_dependent_option(CP2K_USE_NVHPC "Enable Nvidia NVHPC kit" OFF + "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) cmake_dependent_option( - CP2K_USE_SPLA_GEMM_OFFLOADING ON - "Enable SpLA dgemm offloading (only valid with GPU support on)" - "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_SPLA)" OFF) + CP2K_USE_SPLA_GEMM_OFFLOADING + "Enable SpLA dgemm offloading (only valid with GPU support on)" ON + "CP2K_USE_ACCEL MATCHES \"HIP|CUDA\" AND CP2K_USE_SPLA" OFF) cmake_dependent_option( - CP2K_USE_CRAY_PM_ACCEL_ENERGY ON - "Enable CRAY power management framework with gpu support" - "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_CRAY_PM_ENERGY)" OFF) + CP2K_USE_CRAY_PM_ACCEL_ENERGY + "Enable CRAY power management framework with gpu support" ON + "CP2K_USE_ACCEL MATCHES \"OPENCL|HIP|CUDA\" AND CP2K_USE_CRAY_PM_ENERGY" OFF) cmake_dependent_option( CP2K_USE_LIBGINT "Enable LibGint support" ${CP2K_USE_EVERYTHING} From f6c0ee47121ba28f5e960d84caccff7a3d648070 Mon Sep 17 00:00:00 2001 From: SY Wang Date: Fri, 17 Jul 2026 20:34:23 +0800 Subject: [PATCH 08/30] Improve input keyword metadata rendering (#5569) --- docs/generate_input_reference.py | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/docs/generate_input_reference.py b/docs/generate_input_reference.py index 9a51f77e42..7db6276aa0 100755 --- a/docs/generate_input_reference.py +++ b/docs/generate_input_reference.py @@ -342,20 +342,28 @@ def render_keyword( output += [f":module: {section_xref}"] else: output += [":noindex:"] - output += [f":type: '{data_type}{n_var_brackets}'"] - if default_value or default_unit: - default_unit_bracketed = f"[{default_unit}]" if default_unit else "" - output += [f":value: '{default_value} {default_unit_bracketed}'"] output += [""] + + # Render keyword properties as compact, unbulleted lines instead of placing the + # type and default value in the object signature. + metadata = [f"**Type:** {escape_markdown(data_type + n_var_brackets)}"] + if default_value or default_unit: + default = default_value + if default_unit: + default += f" [{default_unit}]" + metadata += [f"**Default:** {escape_markdown(default.strip())}"] if repeats: - output += ["**Keyword can be repeated.**", ""] + metadata += ["**Repeatable:** yes"] if len(keyword_names) > 1: - aliases = " ,".join(keyword_names[1:]) - output += [f"**Aliases:** {escape_markdown(aliases)}", ""] + aliases = ", ".join(keyword_names[1:]) + metadata += [f"**Aliases:** {escape_markdown(aliases)}"] if lone_keyword_value: - output += [f"**Lone keyword:** `{escape_markdown(lone_keyword_value)}`", ""] + metadata += [f"**Lone keyword:** {escape_markdown(lone_keyword_value)}"] if usage: - output += [f"**Usage:** _{escape_markdown(usage)}_", ""] + metadata += [f"**Usage:** _{escape_markdown(usage)}_"] + output += [" \n".join(metadata), ""] + if description: + output += [f"**Description:** {escape_markdown(description)}", ""] if data_type == "enum": output += ["**Valid values:**"] for item in keyword.findall("DATA_TYPE/ENUMERATION/ITEM"): @@ -369,7 +377,6 @@ def render_keyword( if mentions: mentions_list = ", ".join([f"⭐[](project:{m})" for m in mentions]) output += [f"**Mentions:** {mentions_list}", ""] - output += [escape_markdown(description)] if github: output += [github_link(location)] output += ["", "```", ""] # Close py:data directive. From be2d3823ac7f76409ac32ea047b87eaa30280fcb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franz=20P=C3=B6schel?= Date: Fri, 17 Jul 2026 14:44:52 +0200 Subject: [PATCH 09/30] GauXC caching: Cleanup (#5600) Co-authored-by: AI Agent --- src/qs_environment_types.F | 13 +++- src/xc/xc_gauxc_cache.F | 145 +++++++++++++++++++++++------------ src/xc/xc_gauxc_functional.F | 1 + 3 files changed, 105 insertions(+), 54 deletions(-) diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index 68fb602d1c..ac95bc2f66 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -324,7 +324,7 @@ MODULE qs_environment_types TYPE(mo_set_type), DIMENSION(:), POINTER :: mos_last_converged => NULL() ! tblite TYPE(tblite_type), POINTER :: tb_tblite => Null() - TYPE(cp_gauxc_cache_type) :: gauxc_cache + TYPE(cp_gauxc_cache_type), POINTER :: gauxc_cache => NULL() END TYPE qs_environment_type CONTAINS @@ -1011,6 +1011,7 @@ CONTAINS IF (.NOT. ASSOCIATED(qs_env%molecular_scf_guess_env)) ALLOCATE (qs_env%molecular_scf_guess_env) NULLIFY (qs_env%tb_tblite) + NULLIFY (qs_env%gauxc_cache) END SUBROUTINE init_qs_env @@ -1692,7 +1693,10 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF - CALL gauxc_cache_release(qs_env%gauxc_cache) + IF (ASSOCIATED(qs_env%gauxc_cache)) THEN + CALL gauxc_cache_release(qs_env%gauxc_cache) + DEALLOCATE (qs_env%gauxc_cache) + END IF END SUBROUTINE qs_env_release @@ -1920,7 +1924,10 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF - CALL gauxc_cache_release(qs_env%gauxc_cache) + IF (ASSOCIATED(qs_env%gauxc_cache)) THEN + CALL gauxc_cache_release(qs_env%gauxc_cache) + DEALLOCATE (qs_env%gauxc_cache) + END IF END SUBROUTINE qs_env_part_release diff --git a/src/xc/xc_gauxc_cache.F b/src/xc/xc_gauxc_cache.F index 8f17efff45..0d83d432e7 100644 --- a/src/xc/xc_gauxc_cache.F +++ b/src/xc/xc_gauxc_cache.F @@ -50,16 +50,15 @@ MODULE xc_gauxc_cache END TYPE cp_gauxc_cache_params TYPE, extends(cp_gauxc_cache_params) :: cp_gauxc_cache_type - TYPE(cp_gauxc_molecule_type) :: molecule - TYPE(cp_gauxc_basisset_type) :: basisset - TYPE(cp_gauxc_grid_type) :: grid - TYPE(cp_gauxc_grid_type) :: gradient_grid - TYPE(cp_gauxc_integrator_type) :: integrator - TYPE(cp_gauxc_integrator_type) :: gradient_integrator - INTEGER :: mpi_comm + TYPE(cp_gauxc_molecule_type) :: molecule = cp_gauxc_molecule_type() + TYPE(cp_gauxc_basisset_type) :: basisset = cp_gauxc_basisset_type() + TYPE(cp_gauxc_grid_type) :: grid = cp_gauxc_grid_type() + TYPE(cp_gauxc_grid_type) :: gradient_grid = cp_gauxc_grid_type() + TYPE(cp_gauxc_integrator_type) :: integrator = cp_gauxc_integrator_type() + TYPE(cp_gauxc_integrator_type) :: gradient_integrator = cp_gauxc_integrator_type() + INTEGER :: mpi_comm = -1 LOGICAL :: is_init = .FALSE. REAL(c_double), DIMENSION(:, :), ALLOCATABLE :: last_positions - CONTAINS PROCEDURE, PUBLIC :: needs_gradient_grid => gauxc_cache_type_needs_gradient_grid @@ -139,13 +138,19 @@ CONTAINS cache%molecule = gauxc_create_molecule( & particle_set, & status) - IF (status%status%code /= 0) GOTO 100 + IF (status%status%code /= 0) THEN + CALL cleanup_after_molecule() + RETURN + END IF cache%basisset = gauxc_create_basisset( & qs_kind_set, & particle_set, & status) - IF (status%status%code /= 0) GOTO 200 + IF (status%status%code /= 0) THEN + CALL cleanup_after_basisset() + RETURN + END IF params%use_fd_gradient = & params%use_fd_gradient .AND. (cache%max_l() > 3) @@ -195,7 +200,10 @@ CONTAINS status, & mpi_comm=para_env%get_handle()) END IF - IF (status%status%code /= 0) GOTO 300 + IF (status%status%code /= 0) THEN + CALL cleanup_after_grid() + RETURN + END IF cache%integrator = gauxc_create_integrator( & TRIM(params%xc_fun_name), & @@ -204,7 +212,10 @@ CONTAINS params%lwd_kernel, & params%nspins, & status) - IF (status%status%code /= 0) GOTO 400 + IF (status%status%code /= 0) THEN + CALL cleanup_after_integrator() + RETURN + END IF IF (params%use_gradient_self_runtime) THEN ! Upstream GauXC does not yet support OneDFT/SKALA nuclear gradients @@ -222,7 +233,10 @@ CONTAINS status, & mpi_comm=mp_comm_self%get_handle(), & force_new_runtime=.TRUE.) - IF (status%status%code /= 0) GOTO 500 + IF (status%status%code /= 0) THEN + CALL cleanup_after_gradient_grid() + RETURN + END IF cache%gradient_integrator = gauxc_create_integrator( & TRIM(params%xc_fun_name), & cache%gradient_grid, & @@ -230,7 +244,10 @@ CONTAINS params%lwd_kernel, & params%nspins, & status) - IF (status%status%code /= 0) GOTO 600 + IF (status%status%code /= 0) THEN + CALL cleanup_after_gradient_integrator() + RETURN + END IF END IF cache%natom = params%natom @@ -265,43 +282,6 @@ CONTAINS cache%mpi_comm = para_env%get_handle() cache%is_init = .TRUE. - RETURN - - ! Cleanup section in the error case. - -100 CONTINUE - CALL gauxc_destroy_molecule(cache%molecule, status) - CALL gauxc_check_status(status) - GOTO 999 - -200 CONTINUE - CALL gauxc_destroy_basisset(cache%basisset, status) - CALL gauxc_check_status(status) - GOTO 100 - -300 CONTINUE - CALL gauxc_destroy_grid(cache%grid, status) - CALL gauxc_check_status(status) - GOTO 200 - -400 CONTINUE - CALL gauxc_destroy_integrator(cache%integrator, status) - CALL gauxc_check_status(status) - GOTO 300 - -500 CONTINUE - CALL gauxc_destroy_grid(cache%gradient_grid, status) - CALL gauxc_check_status(status) - GOTO 400 - -600 CONTINUE - CALL gauxc_destroy_integrator(cache%gradient_integrator, status) - CALL gauxc_check_status(status) - GOTO 500 - -999 CONTINUE - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. #else MARK_USED(params) MARK_USED(para_env) @@ -311,6 +291,69 @@ CONTAINS cache%is_init = .FALSE. #endif + CONTAINS +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_after_gradient_integrator() + CALL gauxc_destroy_integrator(cache%gradient_integrator, status) + CALL gauxc_check_status(status) + CALL cleanup_after_gradient_grid() + END SUBROUTINE cleanup_after_gradient_integrator + +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_after_gradient_grid() + CALL gauxc_destroy_grid(cache%gradient_grid, status) + CALL gauxc_check_status(status) + CALL cleanup_after_integrator() + END SUBROUTINE cleanup_after_gradient_grid + +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_after_integrator() + CALL gauxc_destroy_integrator(cache%integrator, status) + CALL gauxc_check_status(status) + CALL cleanup_after_grid() + END SUBROUTINE cleanup_after_integrator + +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_after_grid() + CALL gauxc_destroy_grid(cache%grid, status) + CALL gauxc_check_status(status) + CALL cleanup_after_basisset() + END SUBROUTINE cleanup_after_grid + +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_after_basisset() + CALL gauxc_destroy_basisset(cache%basisset, status) + CALL gauxc_check_status(status) + CALL cleanup_after_molecule() + END SUBROUTINE cleanup_after_basisset + +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_after_molecule() + CALL gauxc_destroy_molecule(cache%molecule, status) + CALL gauxc_check_status(status) + CALL cleanup_final() + END SUBROUTINE cleanup_after_molecule + +! ************************************************************************************************** +!> \brief ... +! ************************************************************************************************** + SUBROUTINE cleanup_final() + IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) + cache%is_init = .FALSE. + END SUBROUTINE cleanup_final + END SUBROUTINE gauxc_cache_init ! ************************************************************************************************** diff --git a/src/xc/xc_gauxc_functional.F b/src/xc/xc_gauxc_functional.F index 50adf633b9..2a850d6def 100644 --- a/src/xc/xc_gauxc_functional.F +++ b/src/xc/xc_gauxc_functional.F @@ -1267,6 +1267,7 @@ CONTAINS ! After creating the basisset, we will have to check max_l>3 as a further condition params%use_fd_gradient = gapw_method .AND. need_xc_gradient + IF (.NOT. ASSOCIATED(qs_env%gauxc_cache)) ALLOCATE (qs_env%gauxc_cache) cache => qs_env%gauxc_cache CALL gauxc_cache_init( & cache, & From 91110302175ac84db4f2acd14af165957a4d7544 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Fri, 17 Jul 2026 23:04:52 +0200 Subject: [PATCH 10/30] Bump torch from 2.11.0 to 2.13.0 in /tools/pao-ml (#5604) Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> --- tools/pao-ml/requirements.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/pao-ml/requirements.txt b/tools/pao-ml/requirements.txt index fedca401bb..179df2da5d 100644 --- a/tools/pao-ml/requirements.txt +++ b/tools/pao-ml/requirements.txt @@ -1,6 +1,6 @@ e3nn==0.6.0 nequip==0.17.1 -torch==2.11.0 +torch==2.13.0 #EOF From f4d43ab54fb36c681db345fac0fb4add1ffefdae Mon Sep 17 00:00:00 2001 From: SY Wang Date: Mon, 20 Jul 2026 15:47:51 +0800 Subject: [PATCH 11/30] Test xTB/regtest-3-spglib requires tblite (#5606) --- tests/TEST_DIRS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index 268a1b191e..b20afb6390 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -218,7 +218,7 @@ Fist/regtest-1-3 QS/regtest-md-extrap Fist/regtest-15 xTB/regtest-3 -xTB/regtest-3-spglib spglib +xTB/regtest-3-spglib spglib tblite QS/regtest-debug-3 libint libxc !ifx QS/regtest-lrigpw-2 QS/regtest-hybrid-4 libint libxc !ifx From a05d36a5d95d46814c78d5c7054d02efd2090af2 Mon Sep 17 00:00:00 2001 From: "Johann Potot." Date: Mon, 20 Jul 2026 11:42:52 +0200 Subject: [PATCH 12/30] Test native SKALA chunk routing across SCF iterations (#5555) Co-authored-by: Johann Pototschnig --- .../H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp | 2 +- tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp index 683adc123c..d2a3f65b34 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp +++ b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp @@ -27,7 +27,7 @@ &SCF EPS_SCF 1.0E-5 IGNORE_CONVERGENCE_FAILURE T - MAX_SCF 1 + MAX_SCF 2 SCF_GUESS ATOMIC &DIAGONALIZATION &END DIAGONALIZATION diff --git a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml index d1858ded5d..5899459292 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml @@ -2,7 +2,7 @@ "H2_NATIVE_SKALA_GPW_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=5e-3, ref=0.0}] "H2P_NATIVE_SKALA_GPW_UKS_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=1e-3, ref=0.0}] "H2_NATIVE_SKALA_GPW_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] -"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] +"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-1.04111543882624}] "H2_NATIVE_SKALA_GPW_SMOOTH.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="SKALA_GPW_feature_electrons", tol=1e-8, ref=2.00000875882}, {matcher="SKALA_GPW_feature_spin_moment", tol=1e-12, ref=0.0}, From 3d5583cc723f17a3686d51f8306896ec5e6667ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franz=20P=C3=B6schel?= Date: Mon, 20 Jul 2026 11:43:17 +0200 Subject: [PATCH 13/30] Revert custom GauXC patches (#5610) --- src/xc/xc_gauxc_interface.F | 4 + .../stage6/gauxc-1.1-skala-cp2k-fixes.patch | 606 +----------------- 2 files changed, 34 insertions(+), 576 deletions(-) diff --git a/src/xc/xc_gauxc_interface.F b/src/xc/xc_gauxc_interface.F index dadfbc0c99..e79a8fdd87 100644 --- a/src/xc/xc_gauxc_interface.F +++ b/src/xc/xc_gauxc_interface.F @@ -817,6 +817,10 @@ CONTAINS END IF IF (nspins == 1) THEN + ! xmat factor 2 is applied by both CP2K and GauXC + ! "unapply" it here to even things back out. + ! This is NOT necessary in the Skala branch. + density_scalar = 0.5_dp*density_scalar CALL gauxc_integrator_eval_exc_vxc_rks( & status%status, & integrator%integrator, & diff --git a/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch b/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch index 62a7ddf812..c129f3c11c 100644 --- a/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch +++ b/tools/toolchain/scripts/stage6/gauxc-1.1-skala-cp2k-fixes.patch @@ -1,11 +1,8 @@ diff --git a/cmake/gauxc-config.cmake.in b/cmake/gauxc-config.cmake.in -index c6c4c2d4..b517ccc5 100644 +index c6c4c2d4..35e426af 100644 --- a/cmake/gauxc-config.cmake.in +++ b/cmake/gauxc-config.cmake.in -@@ -6,6 +6,14 @@ list(PREPEND CMAKE_MODULE_PATH ${GauXC_CMAKE_DIR} ) - list(PREPEND CMAKE_MODULE_PATH ${GauXC_CMAKE_DIR}/linalg-cmake-modules ) - include(CMakeFindDependencyMacro) - +@@ -8,0 +9,8 @@ include(CMakeFindDependencyMacro) +if(POLICY CMP0144) + cmake_policy(PUSH) + cmake_policy(SET CMP0144 NEW) @@ -14,13 +11,7 @@ index c6c4c2d4..b517ccc5 100644 + endif() + set(CMAKE_POLICY_DEFAULT_CMP0144 NEW) +endif() - # Always Required Dependencies - find_dependency( ExchCXX ) - find_dependency( IntegratorXX ) -@@ -91,4 +99,13 @@ if(NOT TARGET gauxc::gauxc) - include("${GauXC_CMAKE_DIR}/gauxc-targets.cmake") - endif() - +@@ -93,0 +102,9 @@ endif() +if(POLICY CMP0144) + if(DEFINED _GAUXC_PREV_CMAKE_POLICY_DEFAULT_CMP0144) + set(CMAKE_POLICY_DEFAULT_CMP0144 "${_GAUXC_PREV_CMAKE_POLICY_DEFAULT_CMP0144}") @@ -30,7 +21,33 @@ index c6c4c2d4..b517ccc5 100644 + unset(_GAUXC_PREV_CMAKE_POLICY_DEFAULT_CMP0144) + cmake_policy(POP) +endif() - set(GauXC_LIBRARIES gauxc::gauxc) +diff --git a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h +--- a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h ++++ b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h +@@ -14,0 +15,8 @@ ++#if (defined(__GNUC__) || defined(__GNUG__)) && \ ++ !defined(__APPLE__) && !defined(__clang__) ++static inline void* gg_aligned_alloc(const size_t alignment, const size_t size) { ++ const size_t aligned_size = ++ ((size + alignment - 1) / alignment) * alignment; ++ return aligned_alloc(alignment, aligned_size); ++} ++#endif +@@ -15,0 +24 @@ ++ +@@ -70 +79 @@ +- #define ALIGNED_MALLOC(alignment, size) aligned_alloc(alignment, size) ++ #define ALIGNED_MALLOC(alignment, size) gg_aligned_alloc(alignment, size) +diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt +index a9e60fd8..29b0949d 100644 +--- a/src/CMakeLists.txt ++++ b/src/CMakeLists.txt +@@ -122,1 +122,4 @@ if ( GAUXC_HAS_ONEDFT ) +- target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}" nlohmann_json::nlohmann_json) ++ get_target_property(GAUXC_NLOHMANN_JSON_INCLUDE_DIRS ++ nlohmann_json::nlohmann_json INTERFACE_INCLUDE_DIRECTORIES) ++ target_include_directories(gauxc PRIVATE ${GAUXC_NLOHMANN_JSON_INCLUDE_DIRS}) ++ target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}") diff --git a/cmake/gauxc-exchcxx.cmake b/cmake/gauxc-exchcxx.cmake index 412df9b3..011ae844 100644 --- a/cmake/gauxc-exchcxx.cmake @@ -81,129 +98,6 @@ index b6bbbf0e..502067d2 100644 + endif() +endif() -diff --git a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h -index f6033886..4bbbf13f 100644 ---- a/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h -+++ b/external/gau2grid/generated_source/gau2grid/gau2grid_pragma.h -@@ -14,0 +15,9 @@ -+#if (defined(__GNUC__) || defined(__GNUG__)) && \ -+ !defined(__APPLE__) && !defined(__clang__) -+static inline void* gg_aligned_alloc(const size_t alignment, const size_t size) { -+ const size_t aligned_size = -+ ((size + alignment - 1) / alignment) * alignment; -+ return aligned_alloc(alignment, aligned_size); -+} -+#endif -+ -@@ -67,7 +76,7 @@ - #elif defined(__GNUC__) || defined(__GNUG__) - // pragmas for GCC - -- #define ALIGNED_MALLOC(alignment, size) aligned_alloc(alignment, size) -+ #define ALIGNED_MALLOC(alignment, size) gg_aligned_alloc(alignment, size) - #define ALIGNED_FREE(ptr) free(ptr) - #define ASSUME_ALIGNED(ptr, width) - -diff --git a/include/gauxc/xc_integrator_settings.hpp b/include/gauxc/xc_integrator_settings.hpp -index a63899e6..9031be78 100644 ---- a/include/gauxc/xc_integrator_settings.hpp -+++ b/include/gauxc/xc_integrator_settings.hpp -@@ -23,6 +23,9 @@ struct IntegratorSettingsSNLinK : public IntegratorSettingsEXX { - struct IntegratorSettingsXC { virtual ~IntegratorSettingsXC() noexcept = default; }; - struct IntegratorSettingsKS : public IntegratorSettingsXC { - double gks_dtol = 1e-12; -+ // RKS density matrices are interpreted as one-spin densities by default. -+ // Set this when the caller provides the spin-summed closed-shell density. -+ bool rks_density_matrix_is_spin_summed = false; - }; - - struct OneDFTSettings : public IntegratorSettingsXC { -diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt -index a9e60fd8..29b0949d 100644 ---- a/src/CMakeLists.txt -+++ b/src/CMakeLists.txt -@@ -119,7 +119,10 @@ if( GAUXC_HAS_MPI ) - endif() - - if ( GAUXC_HAS_ONEDFT ) -- target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}" nlohmann_json::nlohmann_json) -+ get_target_property(GAUXC_NLOHMANN_JSON_INCLUDE_DIRS -+ nlohmann_json::nlohmann_json INTERFACE_INCLUDE_DIRECTORIES) -+ target_include_directories(gauxc PRIVATE ${GAUXC_NLOHMANN_JSON_INCLUDE_DIRS}) -+ target_link_libraries( gauxc PUBLIC "${TORCH_LIBRARIES}") - endif() - - add_subdirectory( runtime_environment ) -diff --git a/src/c-api/c_xc_integrator.cxx b/src/c-api/c_xc_integrator.cxx -index 534eb3d0..f1efc430 100644 ---- a/src/c-api/c_xc_integrator.cxx -+++ b/src/c-api/c_xc_integrator.cxx -@@ -200,12 +200,14 @@ void gauxc_integrator_eval_exc_rks( - detail::gauxc_status_handle(status, 1, "Exc output pointer cannot be null"); - return; - } -+ IntegratorSettingsKS ks_settings{}; -+ ks_settings.rks_density_matrix_is_spin_summed = true; - try { - detail::get_xc_integrator_ptr(integrator)->eval_exc( - m, n, - density_matrix, ldp, - exc, -- IntegratorSettingsXC{} ); -+ ks_settings ); - } catch (std::exception& e) { - detail::gauxc_status_handle(status, 1, e.what()); - } -@@ -333,13 +335,15 @@ void gauxc_integrator_eval_exc_vxc_rks( - detail::gauxc_status_handle(status, 1, "VXC matrix pointer cannot be null"); - return; - } -+ IntegratorSettingsKS ks_settings{}; -+ ks_settings.rks_density_matrix_is_spin_summed = true; - try { - detail::get_xc_integrator_ptr(integrator)->eval_exc_vxc( - m, n, - density_matrix, ldp, - vxc_matrix, vxc_ld, - exc, -- IntegratorSettingsXC{} ); -+ ks_settings ); - } catch (std::exception& e) { - detail::gauxc_status_handle(status, 1, e.what()); - } -@@ -565,12 +569,14 @@ void gauxc_integrator_eval_exc_grad_rks( - detail::gauxc_status_handle(status, 1, "Exc gradient output pointer cannot be null"); - return; - } -+ IntegratorSettingsEXC_GRAD exc_grad_settings{}; -+ exc_grad_settings.rks_density_matrix_is_spin_summed = true; - try { - detail::get_xc_integrator_ptr(integrator)->eval_exc_grad( - m, n, - density_matrix, ldp, - exc_grad, -- IntegratorSettingsXC{} ); -+ exc_grad_settings ); - } catch (std::exception& e) { - detail::gauxc_status_handle(status, 1, e.what()); - } -@@ -726,13 +732,15 @@ void gauxc_integrator_eval_fxc_contraction_rks( - detail::gauxc_status_handle(status, 1, "FXC output pointer cannot be null"); - return; - } -+ IntegratorSettingsKS ks_settings{}; -+ ks_settings.rks_density_matrix_is_spin_summed = true; - try { - detail::get_xc_integrator_ptr(integrator)->eval_fxc_contraction( - m, n, - density_matrix, ldp, - t_density_matrix, ldtp, - fxc, ldfxc, -- IntegratorSettingsXC{} ); -+ ks_settings ); - } catch (std::exception& e) { - detail::gauxc_status_handle(status, 1, e.what()); - } diff --git a/src/xc_integrator/local_work_driver/factory.cxx b/src/xc_integrator/local_work_driver/factory.cxx index fd6b86ad..3547e1d3 100644 --- a/src/xc_integrator/local_work_driver/factory.cxx @@ -241,443 +135,3 @@ index fd6b86ad..3547e1d3 100644 (void)(settings); switch(ex) { -diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp -index 1287835e..91027539 100644 ---- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp -+++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator.hpp -@@ -128,7 +128,8 @@ protected: - const value_type* Py, int64_t ldpy, - const value_type* Px, int64_t ldpx, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data, bool do_vxc ); -+ XCDeviceData& device_data, bool do_vxc, -+ const IntegratorSettingsXC& settings ); - - void exc_vxc_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, - const value_type* Pz, int64_t ldpz, -@@ -139,7 +140,7 @@ protected: - value_type* VXCy, int64_t ldvxcy, - value_type* VXCx, int64_t ldvxcx, value_type* EXC, value_type *N_EL, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data ); -+ XCDeviceData& device_data, const IntegratorSettingsXC& settings ); - - void pre_onedft_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, - const value_type* Pz, int64_t ldpz, -@@ -159,7 +160,7 @@ protected: - const value_type* tPs, int64_t ldtps, - const value_type* tPz, int64_t ldtpz, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data); -+ XCDeviceData& device_data, const IntegratorSettingsXC& settings); - - void fxc_contraction_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, - const value_type* Pz, int64_t ldpz, -@@ -169,7 +170,7 @@ protected: - value_type* FXCs, int64_t ldfxcs, - value_type* FXCz, int64_t ldfxcz, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data ); -+ XCDeviceData& device_data, const IntegratorSettingsXC& settings ); - - void eval_exc_grad_local_work_( const basis_type& basis, const value_type* Ps, int64_t ldps, - const value_type* Pz, int64_t ldpz, -diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp -index 9a2a7cf4..b6f4a3da 100644 ---- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp -+++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc.hpp -@@ -59,7 +59,7 @@ void IncoreReplicatedXCDeviceIntegrator:: - exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, - // Passing nullptr for VXCs disables VXC entirely - nullptr, 0, nullptr, 0, nullptr, 0, nullptr, 0, EXC, &N_EL, -- tasks.begin(), tasks.end(), *device_data_ptr); -+ tasks.begin(), tasks.end(), *device_data_ptr, settings); - }); - - GAUXC_MPI_CODE( -@@ -100,4 +100,3 @@ void IncoreReplicatedXCDeviceIntegrator:: - - } - } -- -diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp -index 6c030bc2..15230d68 100644 ---- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp -+++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_grad.hpp -@@ -168,6 +168,10 @@ void IncoreReplicatedXCDeviceIntegrator:: - IntegratorSettingsEXC_GRAD exc_grad_settings; - if( auto* tmp = dynamic_cast(&settings) ) { - exc_grad_settings = *tmp; -+ } else if( auto* ks_tmp = dynamic_cast(&settings) ) { -+ exc_grad_settings.gks_dtol = ks_tmp->gks_dtol; -+ exc_grad_settings.rks_density_matrix_is_spin_summed = -+ ks_tmp->rks_density_matrix_is_spin_summed; - } - - // Check that Partition Weights have been calculated -@@ -221,7 +225,8 @@ void IncoreReplicatedXCDeviceIntegrator:: - else lwd->eval_collocation_gradient( &device_data ); - - // Evaluate X matrix and V vars -- const auto xmat_fac = is_rks ? 2.0 : 1.0; -+ const auto xmat_fac = -+ (is_rks and not exc_grad_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; - const auto need_lapl = func.needs_laplacian(); - const auto need_xmat_grad = not func.is_lda(); - auto do_xmat_vvar = [&](density_id den_id) { -diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp -index 6a27521d..42723b94 100644 ---- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp -+++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_exc_vxc.hpp -@@ -110,8 +110,8 @@ void IncoreReplicatedXCDeviceIntegrator:: - // If we can do reductions on the device (e.g. NCCL) - // Don't communicate data back to the host before reduction - this->timer_.time_op("XCIntegrator.LocalWork_EXC_VXC", [&](){ -- exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, tasks.begin(), tasks.end(), -- *device_data_ptr, true); -+ exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, tasks.begin(), tasks.end(), -+ *device_data_ptr, true, settings); - }); - - GAUXC_MPI_CODE( -@@ -177,7 +177,7 @@ void IncoreReplicatedXCDeviceIntegrator:: - this->timer_.time_op("XCIntegrator.LocalWork_EXC_VXC", [&](){ - exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, - VXCs, ldvxcs, VXCz, ldvxcz, VXCy, ldvxcy, VXCx, ldvxcx, EXC, -- &N_EL, tasks.begin(), tasks.end(), *device_data_ptr); -+ &N_EL, tasks.begin(), tasks.end(), *device_data_ptr, settings); - }); - - GAUXC_MPI_CODE( -@@ -225,7 +225,8 @@ void IncoreReplicatedXCDeviceIntegrator:: - const value_type* Py, int64_t ldpy, - const value_type* Px, int64_t ldpx, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data, bool do_vxc ) { -+ XCDeviceData& device_data, bool do_vxc, -+ const IntegratorSettingsXC& settings ) { - const bool is_gks = (Pz != nullptr) and (Py != nullptr) and (Px != nullptr); - const bool is_uks = (Pz != nullptr) and (Py == nullptr) and (Px == nullptr); - const bool is_rks = (Ps != nullptr) and (not is_uks and not is_gks); -@@ -243,6 +244,11 @@ void IncoreReplicatedXCDeviceIntegrator:: - - if( func.is_mgga() and is_gks ) GAUXC_GENERIC_EXCEPTION("GKS mGGAs NYI!"); - -+ IntegratorSettingsKS ks_settings; -+ if( auto* tmp = dynamic_cast(&settings) ) { -+ ks_settings = *tmp; -+ } -+ - // Get basis map - BasisSetMap basis_map(basis,mol); - -@@ -312,7 +318,8 @@ void IncoreReplicatedXCDeviceIntegrator:: - else if( func.is_gga() ) lwd->eval_collocation_gradient( &device_data ); - else lwd->eval_collocation( &device_data ); - -- const double xmat_fac = is_rks ? 2.0 : 1.0; -+ const double xmat_fac = -+ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; - const bool need_xmat_grad = func.is_mgga(); - - // Evaluate X matrix and V vars -@@ -396,11 +403,12 @@ void IncoreReplicatedXCDeviceIntegrator:: - value_type* VXCy, int64_t ldvxcy, - value_type* VXCx, int64_t ldvxcx, value_type* EXC, value_type *N_EL, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data ) { -+ XCDeviceData& device_data, const IntegratorSettingsXC& settings ) { - - // Get integrate and keep data on device - const bool do_vxc = VXCs; -- exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, task_begin, task_end, device_data, do_vxc ); -+ exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, -+ task_begin, task_end, device_data, do_vxc, settings ); - auto rt = detail::as_device_runtime(this->load_balancer_->runtime()); - rt.device_backend()->master_queue_synchronize(); - -@@ -414,4 +422,3 @@ void IncoreReplicatedXCDeviceIntegrator:: - - } - } -- -diff --git a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp -index ffc0ca41..0b813924 100644 ---- a/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp -+++ b/src/xc_integrator/replicated/device/incore_replicated_xc_device_integrator_fxc_contraction.hpp -@@ -85,7 +85,7 @@ namespace GauXC::detail { - // Don't communicate data back to the host before reduction - this->timer_.time_op("XCIntegrator.LocalWork_FXC", [&](){ - fxc_contraction_local_work_( basis, Ps, ldps, Pz, ldpz, tPs, ldtps, tPz, ldtpz, -- tasks.begin(), tasks.end(), *device_data_ptr); -+ tasks.begin(), tasks.end(), *device_data_ptr, ks_settings); - }); - - GAUXC_MPI_CODE( -@@ -127,7 +127,8 @@ namespace GauXC::detail { - // data from device - this->timer_.time_op("XCIntegrator.LocalWork_FXC", [&](){ - fxc_contraction_local_work_( basis, Ps, ldps, Pz, ldpz, tPs, ldtps, tPz, ldtpz, &N_EL, -- FXCs, ldfxcs, FXCz, ldfxcz, tasks.begin(), tasks.end(), *device_data_ptr); -+ FXCs, ldfxcs, FXCz, ldfxcz, tasks.begin(), tasks.end(), *device_data_ptr, -+ ks_settings); - }); - - GAUXC_MPI_CODE( -@@ -160,7 +161,7 @@ namespace GauXC::detail { - const value_type* tPs, int64_t ldtps, - const value_type* tPz, int64_t ldtpz, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data) { -+ XCDeviceData& device_data, const IntegratorSettingsXC& settings) { - const bool is_uks = (Pz != nullptr); - const bool is_rks = !is_uks; - if (not is_rks and not is_uks) { -@@ -175,6 +176,11 @@ namespace GauXC::detail { - const auto& func = *this->func_; - const auto& mol = this->load_balancer_->molecule(); - -+ IntegratorSettingsKS ks_settings; -+ if( auto* tmp = dynamic_cast(&settings) ) { -+ ks_settings = *tmp; -+ } -+ - // Get basis map - BasisSetMap basis_map(basis,mol); - -@@ -243,7 +249,8 @@ namespace GauXC::detail { - else if( func.is_gga() ) lwd->eval_collocation_gradient( &device_data ); - else lwd->eval_collocation( &device_data ); - -- const double xmat_fac = is_rks ? 2.0 : 1.0; -+ const double xmat_fac = -+ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; - const bool need_xmat_grad = func.is_mgga(); - - // Evaluate X matrix and V vars -@@ -327,11 +334,11 @@ namespace GauXC::detail { - value_type* FXCs, int64_t ldfxcs, - value_type* FXCz, int64_t ldfxcz, - host_task_iterator task_begin, host_task_iterator task_end, -- XCDeviceData& device_data ) { -+ XCDeviceData& device_data, const IntegratorSettingsXC& settings ) { - - // Get integrate and keep data on device - fxc_contraction_local_work_( basis, Ps, ldps, Pz, ldpz, tPs, ldtps, tPz, ldtpz, -- task_begin, task_end, device_data); -+ task_begin, task_end, device_data, settings); - auto rt = detail::as_device_runtime(this->load_balancer_->runtime()); - rt.device_backend()->master_queue_synchronize(); - -diff --git a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp -index f04ae24b..b3c5db95 100644 ---- a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp -+++ b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_grad.hpp -@@ -126,6 +126,10 @@ void ReferenceReplicatedXCHostIntegrator:: - IntegratorSettingsEXC_GRAD exc_grad_settings; - if( auto* tmp = dynamic_cast(&settings) ) { - exc_grad_settings = *tmp; -+ } else if( auto* ks_tmp = dynamic_cast(&settings) ) { -+ exc_grad_settings.gks_dtol = ks_tmp->gks_dtol; -+ exc_grad_settings.rks_density_matrix_is_spin_summed = -+ ks_tmp->rks_density_matrix_is_spin_summed; - } - - // Get basis map -@@ -330,7 +334,8 @@ void ReferenceReplicatedXCHostIntegrator:: - - // Evaluate X matrix (2 * P * B/Bx/By/Bz) -> store in Z - // XXX: This assumes that bfn + gradients are contiguous in memory -- const auto xmat_fac = is_rks ? 2.0 : 1.0; -+ const auto xmat_fac = -+ (is_rks and not exc_grad_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; - const int xmat_len = func.is_lda() ? 1 : 4; - lwd->eval_xmat( xmat_len*npts, nbf, nbe, submat_map, xmat_fac, Ps, ldps, basis_eval, nbe, - xNmat, nbe, nbe_scr ); -diff --git a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp -index 29878c50..94774eb5 100644 ---- a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp -+++ b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_exc_vxc.hpp -@@ -385,7 +385,8 @@ void ReferenceReplicatedXCHostIntegrator:: - - - // Evaluate X matrix (fac * P * B) -> store in Z -- const auto xmat_fac = is_rks ? 2.0 : 1.0; // TODO Fix for spinor RKS input -+ const auto xmat_fac = -+ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; - lwd->eval_xmat( mgga_dim_scal * npts, nbf, nbe, submat_map, xmat_fac, Ps, ldps, basis_eval, nbe, - zmat, nbe, nbe_scr ); - -diff --git a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp -index 192fe0f8..473e56f7 100644 ---- a/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp -+++ b/src/xc_integrator/replicated/host/reference_replicated_xc_host_integrator_fxc_contraction.hpp -@@ -387,7 +387,8 @@ void ReferenceReplicatedXCHostIntegrator:: - - - // Evaluate X matrix (fac * P * B) -> store in Z -- const auto xmat_fac = is_rks ? 2.0 : 1.0; // TODO Fix for spinor RKS input -+ const auto xmat_fac = -+ (is_rks and not ks_settings.rks_density_matrix_is_spin_summed) ? 2.0 : 1.0; - lwd->eval_xmat( mgga_dim_scal * npts, nbf, nbe, submat_map, xmat_fac, Ps, ldps, basis_eval, nbe, - zmat, nbe, nbe_scr ); - // X matrix for Pz -diff --git a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp -index 40e9512f..ceaaee1a 100644 ---- a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp -+++ b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator.hpp -@@ -139,7 +139,9 @@ protected: - value_type* VXCy, int64_t ldvxcy, - value_type* VXCx, int64_t ldvxcx, - value_type* EXC, value_type *N_EL, -- host_task_iterator task_begin, host_task_iterator task_end, incore_integrator_type& incore_integrator -+ host_task_iterator task_begin, host_task_iterator task_end, -+ incore_integrator_type& incore_integrator, -+ const IntegratorSettingsXC& ks_settings - ); - - -@@ -152,7 +154,9 @@ protected: - value_type* VXCz, int64_t ldvxcz, - value_type* VXCy, int64_t ldvxcy, - value_type* VXCx, int64_t ldvxcx, -- value_type* EXC, value_type* N_EL, incore_integrator_type& incore_integrator); -+ value_type* EXC, value_type* N_EL, -+ incore_integrator_type& incore_integrator, -+ const IntegratorSettingsXC& ks_settings); - public: - - template -diff --git a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp -index 2a5565c9..02126e12 100644 ---- a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp -+++ b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc.hpp -@@ -38,7 +38,7 @@ void ShellBatchedReplicatedXCIntegratorload_balancer_->basis(); -@@ -84,7 +84,7 @@ void ShellBatchedReplicatedXCIntegratortimer_.time_op("XCIntegrator.LocalWork", [&](){ - exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, - nullptr, 0, nullptr, 0, nullptr, 0, nullptr, 0, EXC, -- &N_EL, tasks.begin(), tasks.end(), incore_integrator ); -+ &N_EL, tasks.begin(), tasks.end(), incore_integrator, ks_settings ); - }); - - // Release ownership of LWD back to this integrator instance -@@ -134,4 +134,3 @@ void ShellBatchedReplicatedXCIntegrator -@@ -31,7 +31,7 @@ void ShellBatchedReplicatedXCIntegrator -diff --git a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp -index 3dd43f4d..961c3f46 100644 ---- a/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp -+++ b/src/xc_integrator/shell_batched/shell_batched_replicated_xc_integrator_exc_vxc.hpp -@@ -42,7 +42,7 @@ void ShellBatchedReplicatedXCIntegratorload_balancer_->basis(); -@@ -98,7 +98,7 @@ void ShellBatchedReplicatedXCIntegratortimer_.time_op("XCIntegrator.LocalWork", [&](){ - exc_vxc_local_work_( basis, Ps, ldps, Pz, ldpz, Py, ldpy, Px, ldpx, - VXCs, ldvxcs, VXCz, ldvxcz, VXCy, ldvxcy, VXCx, ldvxcx, EXC, -- &N_EL, tasks.begin(), tasks.end(), incore_integrator ); -+ &N_EL, tasks.begin(), tasks.end(), incore_integrator, ks_settings ); - }); - - // Release ownership of LWD back to this integrator instance -@@ -166,7 +166,8 @@ void ShellBatchedReplicatedXCIntegrator Date: Mon, 20 Jul 2026 23:55:05 +0800 Subject: [PATCH 14/30] Libxc 7.0.0 -> 7.1.1 (#5607) --- tests/QS/regtest-admm-libxc/TEST_FILES.toml | 6 +-- tests/QS/regtest-debug-3/TEST_FILES.toml | 4 +- tests/QS/regtest-debug-3/h2o_HSE06.inp | 4 +- tests/QS/regtest-debug-3/h2o_HSE06_admm.inp | 4 +- tests/QS/regtest-tddfpt-4/TEST_FILES.toml | 8 ++-- tests/QS/regtest-tddfpt-4/test05.inp | 4 +- tests/QS/regtest-tddfpt-4/test06.inp | 4 +- tools/spack/cp2k_deps_p.yaml | 4 +- tools/spack/cp2k_deps_s-static.yaml | 4 +- tools/spack/cp2k_deps_s.yaml | 4 +- .../toolchain/scripts/stage3/install_libxc.sh | 37 +++++++------------ 11 files changed, 36 insertions(+), 47 deletions(-) diff --git a/tests/QS/regtest-admm-libxc/TEST_FILES.toml b/tests/QS/regtest-admm-libxc/TEST_FILES.toml index 640bfb052e..548bfe1fbe 100644 --- a/tests/QS/regtest-admm-libxc/TEST_FILES.toml +++ b/tests/QS/regtest-admm-libxc/TEST_FILES.toml @@ -2,8 +2,8 @@ "H2O-BP-OPTX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.173082884557527}] "H2O-BP-BECKEX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172192115148068}] "H2O-BP-Coul.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172925552133442}] -"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689018060}] +"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689027640}] "H2O-BP-lr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.689871565334784}] -"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754585429}] -"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992387993}] +"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754561230}] +"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992363387}] #EOF diff --git a/tests/QS/regtest-debug-3/TEST_FILES.toml b/tests/QS/regtest-debug-3/TEST_FILES.toml index f5340fcf68..150a32d80b 100644 --- a/tests/QS/regtest-debug-3/TEST_FILES.toml +++ b/tests/QS/regtest-debug-3/TEST_FILES.toml @@ -6,8 +6,8 @@ "h2o_pbe0.inp" = [{matcher="M060", tol=1e-05, ref=0.411901963703}] "h2o_pbe0_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.426369189904}] # -"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.436263865396}] -"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.381688458912}] +"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.445432754543}] +"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.442023635799}] #h2o_B88_mixcl.inp functional B88_LR 60 1e-05 0.000000000000E+00 #h2o_B88_mixcl_admm.inp functional B88_LR 60 1e-05 0.000000000000E+00 "h2o_pbe0TC.inp" = [{matcher="M060", tol=1e-05, ref=0.430192264863}] diff --git a/tests/QS/regtest-debug-3/h2o_HSE06.inp b/tests/QS/regtest-debug-3/h2o_HSE06.inp index 8330db4771..c57938acb0 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06.inp @@ -21,7 +21,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 + CUTOFF 150 &END MGRID &PRINT &MOMENTS ON @@ -80,7 +80,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.0 5.0 5.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp index a96d0a06ff..c46674b366 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp @@ -28,7 +28,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 + CUTOFF 150 &END MGRID &PRINT &MOMENTS ON @@ -87,7 +87,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.0 5.0 5.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml index 15a43ace67..e821736011 100644 --- a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml +++ b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml @@ -12,10 +12,10 @@ {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53343196E+00}] "test04.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102641E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53056622E+00}] -"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101974E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53306556E+00}] -"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102171E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.52845348E+00}] +"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101772E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53053109E+00}] +"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102040E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.51211743E+00}] "test07.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101792E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.55939759E+00}] "test08.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.103120E+01}, diff --git a/tests/QS/regtest-tddfpt-4/test05.inp b/tests/QS/regtest-tddfpt-4/test05.inp index ca5adb36c1..a52cb822b3 100644 --- a/tests/QS/regtest-tddfpt-4/test05.inp +++ b/tests/QS/regtest-tddfpt-4/test05.inp @@ -11,8 +11,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 200 - REL_CUTOFF 60 + CUTOFF 120 + REL_CUTOFF 50 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/QS/regtest-tddfpt-4/test06.inp b/tests/QS/regtest-tddfpt-4/test06.inp index 8ac7bef886..7e9dbaa5e7 100644 --- a/tests/QS/regtest-tddfpt-4/test06.inp +++ b/tests/QS/regtest-tddfpt-4/test06.inp @@ -19,8 +19,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 120 + REL_CUTOFF 30 &END MGRID &POISSON PERIODIC NONE diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index 81c2bb12fa..51fdc4d039 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -184,7 +184,7 @@ spack: repos: builtin: - commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 + commit: 9314cd0194cb79e73b44927e920130cd4379f012 # 2026-07-20 specs: # Build tools @@ -215,7 +215,7 @@ spack: - "libsmeagol@1.2" - "libvdwxc@0.5.0" - "libvori@220621" - - "libxc@7.0.0" + - "libxc@7.1.1" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index 0fcbfba865..9ef7f01b69 100644 --- a/tools/spack/cp2k_deps_s-static.yaml +++ b/tools/spack/cp2k_deps_s-static.yaml @@ -96,7 +96,7 @@ spack: repos: builtin: - commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 + commit: 9314cd0194cb79e73b44927e920130cd4379f012 # 2026-07-20 specs: # Build tools @@ -113,7 +113,7 @@ spack: - "libfci@0.1.0" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.0.0" + - "libxc@7.1.1" - "libxs@1.0.0" - "libxsmm@2.0.0" - "openblas@0.3.33" diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index 8cbf31adc4..01c50d5ca5 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -117,7 +117,7 @@ spack: repos: builtin: - commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 + commit: 9314cd0194cb79e73b44927e920130cd4379f012 # 2026-07-20 specs: # Build tools @@ -138,7 +138,7 @@ spack: # - "libgint@release_v1" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.0.0" + - "libxc@7.1.1" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/toolchain/scripts/stage3/install_libxc.sh b/tools/toolchain/scripts/stage3/install_libxc.sh index c08347ebb0..4d151c2a4e 100755 --- a/tools/toolchain/scripts/stage3/install_libxc.sh +++ b/tools/toolchain/scripts/stage3/install_libxc.sh @@ -6,8 +6,8 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -libxc_ver="7.0.0" -libxc_sha256="e9ae69f8966d8de6b7585abd9fab588794ada1fab8f689337959a35abbf9527d" +libxc_ver="7.1.1" +libxc_sha256="0e913232757338f345830250bf344d8c60feca5b8ff6c0c6b2229c5189eea11f" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh source "${SCRIPT_DIR}"/signal_trap.sh @@ -34,34 +34,23 @@ case "$with_libxc" in cd libxc-${libxc_ver} mkdir build cd build - - # Lower the optimization level of KXC functionals for GCC to reduce time cost - # LXC functionals are not used so ignore them - if [ "${with_gcc}" != "__DONTUSE__" ]; then - if [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then - MAPLE2C_DIR="../src/maple2c" - for f in "$MAPLE2C_DIR"/gga_exc/*.c "$MAPLE2C_DIR"/mgga_exc/*.c "$MAPLE2C_DIR"/lda_exc/*.c; do - [ -f "$f" ] || continue - if grep -q "^func_kxc_" "$f" && ! grep -q "__attribute__((optimize" "$f"; then - sed -i 's/^func_kxc_/__attribute__((optimize("O1"))) func_kxc_/' "$f" - fi - done - LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" - else - LIBXC_CFLAGS="${CFLAGS}" - fi + if [ "${with_gcc}" != "__DONTUSE__" ] && + [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then + # Turn off variable tracking + LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" + else + LIBXC_CFLAGS="" fi - - # CP2K does not make use of fourth derivatives, so skip their compilation with -DDISABLE_KXC=OFF - # Add "-DCMAKE_POLICY_VERSION_MINIMUM=3.5" to keep legacy compatibility for CMake version 4.x + # CP2K make use of third derivatives in libxc CFLAGS="${LIBXC_CFLAGS}" cmake \ + -DCMAKE_BUILD_TYPE="RelWithDebInfo" \ -DCMAKE_INSTALL_PREFIX="${pkg_install_dir}" \ - -DCMAKE_INSTALL_LIBDIR=lib \ + -DCMAKE_INSTALL_LIBDIR="lib" \ -DCMAKE_VERBOSE_MAKEFILE=ON \ + -DBUILD_SHARED_LIBS=OFF \ -DBUILD_TESTING=OFF \ -DENABLE_FORTRAN=ON \ - -DDISABLE_KXC=OFF \ - -DCMAKE_POLICY_VERSION_MINIMUM=3.5 \ + -DMAXORDER=3 \ .. > configure.log 2>&1 || tail_excerpt configure.log make -j $(get_nprocs) > make.log 2>&1 || tail_excerpt make.log make install > install.log 2>&1 || tail_excerpt install.log From a0df33dd6ace3f0789f82cf49f0d553fde41bf3c Mon Sep 17 00:00:00 2001 From: xysun <117051594+xysun25@users.noreply.github.com> Date: Mon, 20 Jul 2026 23:42:41 +0200 Subject: [PATCH 15/30] Add MACE support interface (#5580) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Ole Schütt --- data/MACE/MACE_scratch_run-3.model-cp2k.pth | Bin 0 -> 287720 bytes docs/methods/machine_learning/index.md | 1 + docs/methods/machine_learning/mace.md | 60 +++++++ docs/technologies/libraries.md | 4 +- src/CMakeLists.txt | 2 +- src/common/bibliography.F | 9 +- src/fist_neighbor_list_control.F | 14 +- src/fist_nonbond_env_types.F | 8 +- src/fist_nonbond_force.F | 8 +- src/force_fields_all.F | 11 +- src/force_fields_input.F | 73 +++++++- src/input_cp2k_mm.F | 52 +++++- src/{manybody_nequip.F => manybody_e3nn.F} | 47 +++-- src/manybody_potential.F | 63 ++++--- src/pair_potential.F | 11 +- src/pair_potential_types.F | 12 +- tests/Fist/regtest-mace/TEST_FILES.toml | 3 + tests/Fist/regtest-mace/mace-test.xyz | 34 ++++ tests/Fist/regtest-mace/mace_test.inp | 41 +++++ tests/TEST_DIRS | 1 + tools/docker/scripts/test_misc.sh | 1 + tools/mace/create_cp2k_model.py | 190 ++++++++++++++++++++ 22 files changed, 568 insertions(+), 77 deletions(-) create mode 100644 data/MACE/MACE_scratch_run-3.model-cp2k.pth create mode 100644 docs/methods/machine_learning/mace.md rename src/{manybody_nequip.F => manybody_e3nn.F} (94%) create mode 100644 tests/Fist/regtest-mace/TEST_FILES.toml create mode 100644 tests/Fist/regtest-mace/mace-test.xyz create mode 100644 tests/Fist/regtest-mace/mace_test.inp create mode 100644 tools/mace/create_cp2k_model.py diff --git a/data/MACE/MACE_scratch_run-3.model-cp2k.pth b/data/MACE/MACE_scratch_run-3.model-cp2k.pth new file mode 100644 index 0000000000000000000000000000000000000000..f0ff697cb9f491f1ef997ca38c8e62671ba59e03 GIT binary patch literal 287720 zcmc$`2{@H+*Eeh?O(=vE8A}<8iezmKN+eUt5FtZ@C^9sWP$)`@N~si*P-bCmnPr}5 z+dQ*3wt4t=_y2yL_c-3?zVD~|d!O%nuj4q6)8*K%-&*TB&$WK%T5HqRU}U1BV`HQH zFPAi(Jl#pv!$-{=Ew7t9S=yRizj1Zf9%(!K3szTlSvu^#EMw*BblqIW{K^%37c(d8 zJ-gKo$l#{R4sa)A9Y0Kn_;d&8#liSeZGwIarxl z-f*(FwpKgD{f|Za3+^B3FGIKIkKq1h5VH%v!PE}P{9}}VZWQY)_U2A|<$qgYZ)WgC zR+0G~r>VZ>Kau|NJCKw6t)vULQ9T0<`uF(f@S=1({~P!V=1%4^vTBDU z{~Of*CCl$6|NCP3Yx>W1zxMC<{C}T+oB#K<<*$iu>)+>Hf1joQK5PAb{;idFFz?D) z+WqhGue9R%6RqUb4srbht^R`BNcfExtFC?U_rCo-{uQ41pWxBF$+mxh_rEOn*H8ap zzu)*X9S=YMkKyn6GyK2w|E(`8+r^G;R{vx8@_&XOk@kZrXj>^xJ!miTO!x^|FXQ-) zeR{!J)Yd~Gh=h7BguW4{IUGw0J@QRt0L9e9g(9kZ;DVj#_jR_T;6~WZcIQw&M7nFm zNgWx)gxR+5o(ywvQK2uNn%;nIyghyIHM+n}ru@y5QxhQF^(uBlXa*)fycmJ5U9dw_ z`I~ZI8y;ibn{gD$(3w3PPA#M-9^gBcQD)bQt38(!l9#DC@FqdW+OP`wG`3{yPRNJ% zEdH9ppZWo>Z{Vfu%!e;&aRX6Xd!X$-ug~TKWbplZgyZz)a`ZIWd4+tu3;WGQJkqTu zQAg3se~h;pyRFzC`WO^JMYCY6U}_TTbcH)DP1K=uEI(=g#uf}&+Lvn-HjnR@10s_y z*W>x9_Z!}_4WglUOH=OQJ`9O%n~=J^jH`I|yxGM53^n>tE?2ib44KO2X&Yvf+-$eRX) zyJ|zSUM+AHR9o&Snt<-hABsLJH^PHT!Qt#@lVEQsb$Qxu5)NthqV^X6mcFvvYsKie_-=Q(bz3wykd4={2)ht!{kw0;wN$CM@`_ zQ9FTw*R-N(cMoj5BXaqoO$@FWud-r4JdIj|se?V-MQ~($uCd6^c5o7p*YhhM#oMMI zWV}AqgW}ocu6*+mO!Qv8>Ty3yo{QFIf?78<_9KV zjKwZjXp9U*) zEJ`Q+Cw@ag?a+=t@EiZ(NB)(cQu!0Sy=sS){tdkU!2OT;F9pf)|91XuzqZR)>j<<5 z{2u>GpFgtSzJJetByyOuj6e_kHBW)|#bLQZ$>qP_GZ8lJI-h z-)9m`%!!{(HY$HfeEZNMoz*9ZxO2cdkT4xde3QT{C>GB%%J5DN)^m z5s3L3d0r*62G_bzh>cA4!*%ISS-I*_%x>JjZM%Oj*ql5%A+S(`Dl(ItRK z+M})b(=kAdZ?+w>cYf;AQ;fx!ljxo>J_stSRwff)w&KRcxifoqPGbLDujAWKX<*y- z`td=vGQ1vSAhqTcBXQtjBsaU&Jhm;K>r#0)0c$-@1jm11$ z=?T%7tgFH=dJnnho0y zA8YAAMuBN@!y_d0SG6Ra3hV*~rHiLSR+GSHUCz^ySF>=z(yGs5p%x043@aoZ=HUHa zomI^x6ckgtxjJ%g7D0z#DdbB9Z%czU5~K-K4m-E@E2#y{oktn2srJA%D~_QA>o)im z-=4n9bQYpEK5BfXR*hG+pELN3R)TIb{W;5}F06X+ntAM24UFCvSh}URf@4M8UH8tA z!AX~~Ay2Uvc3<2B#qHB*wsM>)_goRoZf@|?eyQ`r*rJS+kZQ{{LA<$ zMz`ya))|d>ZvU_A>_6hw|33dKUvcn{@Mr;B@z3%8cl^Kn$NzNv{73xbPwht|1pmL< zj~1~1FWT?_)c*gs|Ngh1KKFDo>u-`6KQsdJZ@mAZ2!56wX9uA`Ft{!t zy${lva$=(SyJ5Jh7RzI~<09lV5}_-L(gbe3-XNTp=T~v9){9%q%8~c?YVz?1aI)Ik)94W-v2I zuSQ^e5cx${V$TqUAUrTwYW11{Eb8M?ay^z0cF(gSFlPY?>UWc+s!GA&cG@0WHmXu)^({3 zlLSwglgVVXC@g%{q|<^C!1X>Q;uR>=H21o_Xn>Y8o98L&GsvcQq}+F*9ZE+O%bK+3 zp?hT2B2z{puskC4*nKL7HLKFjUt^)*kd}j-UGXUH`PS-E$3KRbR;fIHcR;h4&xTqOUG-fh$z2beZ`xu zAI$C4xTHQz!MhC3{fy0Xp!MElPH$!aetp|Z>FRF55Gt_y2=Nx0YiWth`0GU~~0w2iRK2fB%N z<{fHF==`HIrc!AJS*{fqXztB}!@jexSYZO+e7P|ZbF~pJFluBlAD@87)1&>Bqhu`D zW|Y`;x)!eG)T$^hmSKraq`=GJE(njd>y4e6fy5_dS&pX@aMU5eDSurbmML(@3MUVs zk+(2ckKib-yS7WRhM5WvS0&szzq1mb?<1`9^qvH^Z*Stwyn4aTb-PznC>1z08183I zksvuUSC4pe0A;dsBA+GY!b11aYzenPs7yW`tJk-PsYNT{SD&?^))rsuuZ>MG?U~?K z@{*3Q>8l!bUEnAb1mAI()2AnX8FLK@|3HPxWnK;u7Yb^aq!qY?w1S?zV1nvRBGinp zTv2>diRH~)-8`A|u(Nejpl3!O=G)hrYVvo2TVRBR)!J^j75QO`$$$(sccpj~m?v-| zY4O)s6a`bS+%Y6_!aTy8Cm}$5?fFl$LpZ>kIlVB)L~L7-e!hh< z7fRO_kKhI! zrb+lDRGzhMIt&acs+;Dsr;$EHQ|2U2A}`mKxfwnZM(Hhg9?~9x{<7<_WG z{|PE~iaMjg-5fBBE6kBUSC0NNTb#2phM=@k_{Gmy3M{?()qFQ-8j?CCZT8Uj;@e~< zJvkmCFgn$I;}j|bT~kM^RH1I%zK7F8I;a;zHH@w&%tR0^{+Xk~| zPAAEiv|#Yl6V{UQi&&bbEblqif%b_&nk|9xOhzp~Jjm6!SuZAAGKDz+0Xv2kn|^?@K0G_q@#rzF!pmW<#VS z1VldPnn@c#-DOFgp&uk*V|ezm!LkH)7;ewmuT+ARqJsLAPqclgdDe>V0R_IS@{-L{ zZNPTQnf=-Vvv{(ALX1^ihEn>CMBYm)SZI4d`ODrW5V-O9uvlsytfq#)UNxML-=k&* zwOUAUbc*`c>J&3Es9hsV_sJ|c_3oO1&Ix=GL5bWc(21X`&8&C=z9OeWXTd|`5wy%{ z%k5sShmomni`q&O6ztw`y(629m%QnW4(1GD@d9f=v`r2+9j#Irt>{IYgq!O$L?_^N zmB(QY;W?~WH>?0R7eG7;Z?!lKAnVy}CRNx4dp((Y`RYc1-K5DkGJhN%|CD_5ymADj zFAaXu`B)9pBVAhH{tYAF$a^(Kqi9m~2$JVHY-_>cx1HLw5PTzjwTf&fXQ28RBu8cXc>dgz3UwW;lcZ~wOo3~=V zB?Xt)i>^9!p%2~>v^AVwj=`EA#;;QHmr*mQd84Aw2Yi~RFCloN6Sw)8TQRHA5kp_( zb$)cO#d8mH*2YJqqyA0KMEiwA$nyR{9p~(VtpLp_4 zg!F{HdnQ~hm&g|Js72P@s`%ql6*&2CT8Q_p!F@iPwsmqc5*tp28hEzX!GLf8*G+>! z$WM=8YrEbDyRNlTdW7@wx!ld^H`PDjYNb0VENmPdtD9|)8&j~0f!;pXwg;C!+TZV^ zQXo?)!S107BXRG_WA@mtW$+hu|4`IL1%qcNvkjHEeV zR|NB2}h_BinH&LkPRXY%`9W3VYj5H-$XAzEq@0l|twJ z3$qN%op?&SVHel0UN|UiQ}JPu1Uz~PlDlK-@s=WcNL$JT@CQz9%gLWc;ZZxi;^1a1 zRriY;3md{0W)3!K4jB++npp10H;HHW)Px6rorFsasv^1*-8ho_(~)z07z&%xuO4h$ z!uPSa?N{Ba!Vgs2zD&MZ+&M?xD6_r`lij8Q8#@NjFIB3a*@}ViPMq2h^ClB5iin)i zEL0eLv14CHF&Wr4&I^ti%%jt?9pugUT8~hXjKTur4JO z8kb!{qhh6fwcJ$DbYB$C{y+gwr|XieFNeTB@`1^Zw$l`iOek)KPdR) zd6;XrdmWtIudg6OM~3;YXQ(a>MEoTBD1*?}ilrKHmeUMlVDtnk40dOs&*q;Kipml2 zbjTcFYjw2Vd*?y+fD5T>=mRVR%O)2+M^h$xc~hCT@lLr1sq({y#)L}4Kr3X6hN4z`3bE<{V34=Bb{R#Z6B%` ze$;u=2mzPfbLsMCA&6UJ`8nMj_;N=|N!u0UPsYxDm#`k_PCpmh7Sju%6f%v^kYHQD z$PwPFJ=k=4a3Y%;148Wg-rjh*f_%-oD@^aHxP`vmluW9J2-QBbIw^KSxu%AguS6ww ztnLg|T&~8aOs(qW8>Zo$nAfNMa!a7-OJ=&L&q&}V759JliG_yy_FF0EqA}alN-0yj z5D9V={t@qLa7b1Z*wjygM>cf=&04)s{FJ4q2=Xy5?2^;fy``|&v+AbUjYQ~c6V_FK zkqL?ST)y5YnZWT|d{mo{BbfGK@23vE8E9FX<^tl>_txqc*yFv3ii`G)v#~27ZTr&;{jCLWb zcg+K~lqn2Re^tu=r414|xRqW=EWj0}k4e%^>A<*AzN$cW0K7+TU-;Ef0av=&!^3ye z;-V|#qbbckNPebk#$8H<$1_6LvK@x;`E0wlZXX3&__(yZ6vx5cHTwm%XBLgeqgb6n zDPa82DSh9^I0&`8BrlU&0@7!%5)SZ;!^UI7)1Mz9zAcbWxm;8MYv!so1Xh;uP|uQt z9d!cUdR~;=xUT|}%KEtXU95+?{AwHK{&GCgVJzllItOoD8~Bp1lThkg{mAm8c6k2z zWHO^yJHGg~bCzv?EdC0-R$s;)0dxE>E6;|EKncm_rf)_gbgd)>M4KVDW!``3x?vtK zT3!p>le-AS_qL+^Q&o7$_rKliWzF1v#q_Zc6jXd10u$?iBWNa1Zcit$Z2KmYlKKh;LekU1 z4M@P@=QGf$JOFPUvW5+}PeN0xM8hNuqIB`%UXje77|R-bI(PCH`n}1D{-iJjWba+a zZGRDQv)-Lvv50se#8mbT8`i*!_hWe#UppWmw9h}E-xtrk`JpGpHvpTGzLcDP1OPg~NP-@WtIXB5^ng%=lYZLKEo;nag{^Yy3M= zB`*H^BF`{fO}#&D+Svh_iTYL-nrp$&t-hWqwhmKSKG+B*PQf7MbSO1`4DJs}emtPw z2U^!!W9g;GK%;D5&|{`5R4!WQ6!{|+`3ygvy|YN;2kWl9N|YhPY{CX^f?6Yx_I;h6 zPOkv|tXjo}Q*C&~MoEWziiMz}S$VmVHy_r$d3^A*VIJHlI+(S(z7NR0U$=#u4Z_>~ zshbB`Q*cXt-W1dF6s|u$Cv`_=0ymDBY&wxkhJz$a6PBb_Fh8kkCU=XBQw6U_BMLiU zHQUY%o@;e*?d&SjrJjC}61)?(bEOvL0t@G69!H_^oujY9H&b!jmNcn-^s`_Y^u%_% z!4SCe-#)N`a~N(LzvhUOuf_NE`NGN(^>9dx*?Br+5*_yoka*V5fyKd_6Gg&QtZZH} zs+XUHFt~Pp{8|g_Ig?cFESHPs(pQs4`5xn^mp5##o23Hwx*W+bVJ41ACF|bz8b-}~ zK11>4{ZQk4p?)BX0>jR!;ob5>aI*XI`XK2pw6A6*yo3pW@aJ1^$Sr~x&z>0Fp(eaM zZo45hqTz4(JGI@63UnN_ObBiKpXVQFg@=D5|L}F4kpKJ^3dqax4)b5?#put`e6xYw zc&dqA?mBS{sKV0UP_!!ztuAl{|@B%bZF5MiY>IXHs~G zX9_+!NS<=s*#P}=FV)Ifn@~CxCE~)eAo|evBie3F;HP{#{cTVZj`?^OuLPH)VSM8L zveok_a`-jZ`0Z2}d-!~7Nofr(y%SnT|8pD^6ujb;S0}?KE5Q-*Yn8Y^Fpc{q3kf8b z*za_OP2vjhII*2-z}zsxhaE3xFkoz$oKRT>Nq(I`3Bxx-3?lC6ePw+bQM}rz*KcBN%($0!lNU#{ldMdGQyX| z-9dtd^TEeg6bJEw^^Qb8p%yg0_g>94ZWwmiBwUzOC*!sKFOw9$FtEP-0EgNg zA77qr#Jg#Ad$m?3;N3|LS4|qv+;4t%H(UAuDlF9S8uF3gdRk@c$Kq~0RQ6?$WK}0P zvtOjo+&v9i^Sg)F@~t4_6I<0I{U7mOn0NHD;&-sg-bdf`AOpo`*-kK4HiCmvwYH5a z1>`!?ig{JXk@P_BXHI?wp61O;&%0C!X~|3kcBKLMI@SGDf>tk2kt)@^wyWn1Yvf^$#zmcERC+MvBL=T=2xDbzYW(_^|ch0gi83z_ip>svDdR+=kvh z{+Fx`A!W@M&f>4lus(3p!wuOZC@f1&;4Wx} zH6<$Ij_ZR#cDsbq4$3RMkkxOm`-}oLN0>XUeoUcmnAyrY(;*0oR~r`iSOptO_I$s) zJVxUSp@I*HpFllL&}(UE5OtauD##h*u(_fy@`FGf98uE>aCaWZd<{*F_MlvBdYJf0 zjHL}uKM}w3YW);Cel-zFTsMwGgXQ+xO0}RQJ~(!IT_cY4w$HWlS6~z|vskf+4EuxC zQk;MGpycqy$w3`DBJbDD8_r$rg!umFMekB5kT57zeqCc2n9?RTS_jW!Mc7-HKFenXtpU;2p#+&0|&603bq4U8m?_qr0^Md5*L33s!4~isN5V;aSKL zv$aS1aNmYAXM1C-(etxReoxUIu)oH3qnbG%EB3CNcB)8$6AM*BUI#{D7ynw%zD`zx zBhQYGl^3&+?A~)_YGV`d%qmkgeW&1Yn9JJdg|%>BbceEqcpCVh=iRv@VGK(jswu?W zX`u0d;~OOB+ECW!{npiWm3Vdsdd^MJ`e{n9di-2j0)3B==f70OaYDaxD12rJd5Wh! zM;eP!JisHSaeNlVx6;kn=MCZBiXcu?TE19VH~M4zo_36~(Yt485eu^^Ci@E?k3sI^ z-B zgD-#dEJSdPg0fQC`sHg>be8fj?mo}}-nWXcrqS|GKi@@Ph*qJ3UT!Y+%iIVM^}p4& zS@hynP5$03oz=jy_n2iY?R^&!KVFPGNWy*B^RFHrUP6z=H?2bidZKl-zT>sP2GC#a zQ8ZB2j3>S3UbtPE2d@_1O&jH!LFyG3F+FS$^aAZP?5>g_!6zl6u3^ z<1>BDIF2_i%6KOAkWlWMcBP$b1yqoN0zWMVO)bDZl6a!)pcV1)w~o|qfU70t>$-jd{Mlh#+D63&WIKA|0&AAQ&N-<9Brm*iI?_xJZr%a_l~*yM7!({-*jxO&$Y&DAS?rKSGji|-ZY!R_8cG~*n-hclo7wtI?{sr^Lzd;AziCyL1 z3pjr0RglM#YTQdTF%y1Nh8Fj>3dvrIgwd+w<*xCAc$jZWon=cc&NL-%*D{#JtRUIa zTAd**d~wV#S9lO&eKs+-(DsLqOw{BeEgy^TGX2TAqj(@@qr%p7Mq(6$l0MUeAGj~s zkUx`s4mDQv4nJ{iN5zl#6NYa3!w2;^cHz_!c=EOEmy5(t;2FK;SLi+lO3mKmx6dph zr{Z96lM^Gs$tUsdXv_d62=j(-%IgMCItBM*qr-6a{ss-E>peiY5Wd4BBn~xA=4Oum z%z~fY0_X2ej>32IoSkEpc_8xASBj5Hf-pYih8odCn78#ZyHfT6iF%PZ z`Hqs>aZr+o$&7Wly91hA}fZI@{{)#W@3#>(y_#-L8eHYU2QZs~%w3 za_gqtjv5$@u`=AgY6#xCzOpTUGk{lGl&jA2R>HXAyku}M6`cJazb#W4#%L|~lC>Ts z=pN*FKs$OGrR!wtOuGsp_+Gm~uwerjhWn1(y+4bG303-{<0P!y6}^^wO%a?BKQP8Z zJ6FU$Tq8*^>x6BUrVF=U_27?V{wqyisCcI?{= z2Yt#SUP;@qgl)(e#!{p@7pp2 z#Vmpw_YPBWo%9rsuV5~?J(I7dE1ZOI#^}bv2s*;W;~}Qo>`9=nznA}`Z$89cE*D=% zTUT*n=UBU%XW(I8ji7JQH{9i&eA|{pgy4erq4#c)FmjLj5gBPlVjtoCtylUa@N(Lw z!$X}xtK{#u>K^ssS7T*w_1C}9iX>}Tvgrk?N(e z&pjgc?Kp(rS=!kDs0rS>9rUhb>4X_n=3su-25aZ!JfBc|p!$hV-J6^9z~Yg<&}Fav04@~)EMixCicKs02gUxx(j0Wehej?A>(HwkH%&{THWQPY+l8)o)Dxsye!>jjBV_j|U3N9MfbHX8qX_`xxF>+?D^ zSG>Ds!oM0esu|R2POo6>d8vj7^>Gk!xVvquR55(^QMghb{1g*R>-^*|jKB~R|Ef!8 z$=J`$@ZQql7u@AFXcD)dfnc4ey?j$MFn}w<`7Bhtu1RsK@M?zqbG%_EgGgv}$L6(X zQ5VLQKGZO&2}9k>?aAxH`cbUvU0$itIH(FNHu>Di!AI}AM|$>5Vl-5xi)hW_lEgzr zm(Ec*@wsSOxqSln5ApD(3ryg7dG7mf2TMR#Y0K%&eXU?Se5-k3r3e_r9*0+!{)D`X zD$~!t)ghbyZrvHX5Zr)ABq7yDNmD+9S z%;C=caQg_7T=unaPtkbvRr=5!4Lw*f`$Ol}_%N@;viBosmx$9T5O5kzk)cIqG;CDm2%X`%*a_DBSlS`b!pw+!k2tb09Yfdw74qc@~-~+AXfHo67QZIp~aIOk{q z%E8>H{fW7&$Qbfym-)zG6TS&syifuZ{h? zUAqVmnFV5kE>9poo7M9^C1;dANVm0hz6VRcskuhxW@Cs}-n@HHGiC;8jfU)+1X-Sh z`S`<&czaW1vRZx&3H0-ABbbBZ5dCx9?I7stD>U5vJ=+@!W z6iEhtW(I=K>7g^-xiuj5%OoeNW&i^66JGZ*Qn7ot_igi{c8K2>G%fyR7Rz)*Q(OdD z2*>w|rA8_&qU`g)z7<+s$17c@b)MLOYmT+3rI}8Gnm9?Nmth#?OKxLs^#pc~ajlQ3 z{DdJ!*-Mj0&t^P~S*i{Xt!Vkm^!I{y9+1f(^zj$L zUwIKc27)d#8Fb+Er_SkP0d&Nj1#tgdVJ38n@wpr~C1bIvy2>%$Jmlqn{pxXN5x71NBllbPGM3RDB`A%-xn?MCBX)5$IGDgoyAhujEeC>dpO+Pu?4)CsM|GG~OL|M8D-84MF{ROgQ+?hpl8BPTU$6 zOVL?|y)!dXN7gstVE?J~7mg#?^yL5#`B4Wl7b!{PbI&6G2HT_Er&6)uanrXrnwK@% z%BRPnRt0@N@^*LG$awO+m7?}OGM+2@MxQJ(iSHy-Il@y0;A#3(O5+hGV&9XP?DJyd z(6Hpmr+Bjpdn-=T`_z(Q@~c_2yW9v4b4xYYx8wm6Y`lN^&J-%?f&m=1Kz&B~T7gB8bSQmAAdG1Lbp80V~{KP^x)*02YA8%$Ln0?`w zrUdoDeRa{v;kH8LnY*dDUat?Xk#?%*(ekU^_J>to-k-(|YlrhH-HDL!?2=AOdp}6N zWy`N;`UTfH!bG1W4`SoaTF0vy&Js`Jw0|`n~WJQ{#Cs6x&g1M*s3KUhx z#riYR5!lLX7cZa81&5dgMMvu)uzv1wtJa=@XwjdE>5U|ySY#R&9s7a$CzX5rSJ#5A zqvVSrTD%Bm-;nXDe*yDdZEYgkYGB;sk>(!%7Az~!3i_T>4a!Bw-QG0Q`c5-kOdJn& zLwVFOvIUJ#9LuQXNW0bt{41H-u&xEg>2t2~9hwBO*vv9crzyxEleKKB^oELnm!BVh zYlVD4_*A@71;W`peEe?*k>IfD5KH|$MEJ20-*S+kf#I^i0Ca+O5C5s#8{4pZ+O3!? zxDNv+^=8AI7a&nI+Pj?LF=xz zLD|lDI1nmqJlom=Y1_X~kp^jf3o_!ukME3t^J)0LFSikjhSIsKDOE7*q~BoB9gjR0 zGkfLU(&`1KDJKVODzL=*%BG`)d5ou%DBE@-3m@0MtQ~wdf~Fj$jR|pM_`)&c=CVKn z2HmmG*O?wcH@6y&0@56E(926Nl@FsxqP5Sx>1m`=9w=$w?g92=P_bv%B5X@n3=87> zi76gGpZe44SmK_Nsy9=~kRl&&(YNh0Xh&}@Y5LF(6I>v*zOx<}1NnBwOI4wVWC3~V?i<+WQrgJLH&v^BSRUX6OjsEK1T5HZ*^0Ie75{ZwnNaE_v(dQ8B04k$zH;j9dYy#xH!11RYE37r}CE zKvm7*5Weyn+XJ(8Q!M9TJ}GrFr!fm|miF<9k<0OxHr3dft^tJ{2Y8?PJw?8kbVg}v z1z;DFn^VSF0mn{Rn<}pA!mSKva+JsekgR2}LdX0AEnBaZ`iT!BL%ODyGcC{8eSX8f z%yY}g&Lu^i>t`TzG)o8>3XH+xnHARM*AsXlMo84ut_fXbIe&@|QQ|#TBB1Q`~+t0)J^|#9AXXuHi zPshf7-$nsd^?R|8Zg!ztls~Vk7X{cYqAAQ;HRxU`ZdVYUiQA?Ef0Xx31KpDwJ?cG; z_~G$79<@z*C}`O%%YWY4%k+564ZPkhPNh;8VQD^U zdmE_+0$$brjJ=qP<(t)}-zt+qJ><387GnyG&MddCcAmh~D)wv&{I&2k^YWpN2fwgQ zRhVH;Y91}Q-bH0ZccF#Qm3+o=HsX_jYLV+{6Trja?mSvN0C_8)Um9(igh21-Zs+*Ej^G~JSJI~RRpp=G?Eh0g?4SO*DtiJA~5z} z%M^Z3>vzA9eb;KS8#6^pF226d1Acw2JQl3eXy>8!s7iMZA80#plQX(t_5L<1?t6o% zmta|FsZGWcCN3A$w~_JvmK|4wu215Q^z%>d)-n*k+Bsde%=(O-UBlW9KE<%=&cn~^ zU8kV%!>ZbdO+Uc@QArUUV=XP;P2#$KJp>*;c`WK5+=wVabP!M;`&&QGdGSiPP#N>l z=;=?m5NWnp_YTF^|U=qp`HgKbZ4+O0h>1uNOd^p0z0!{`LFu>mIqWI*(#4&jNK7e~tW)hpei>-E{)yr1x zV{sU{G>x@xFDt*>OvB;C$&W3hay)IPO3Asugd&>H51kOI#|M=!99v&?V^!HhYsaBR zaIrF8-CM*+_|W3XecPx8w=RphEB&Z}pSPsjrOKyqvIfEH-YA%O=FuDO7{n}bX$8iM zeb7)rGYR7?Xyq1Ao1FT=ks@GrU$qfazFbXy6iY#qfM6|ilQF!o)HN|--H5?UOy?W3 zn!)__c@=(d9n(&DR2FGwz;{RT#kMI(l8y*(tC#-)z)w>4`i2`qtNlPGFQ(XNR^- zCyu=|P3)T-#AkDHS>81NMEbCG#}~V4+`B_&_1(w8@NGJiq2fR(+Eqz0vx{_tyjTS1 zFx>#O%Szj6m^Z-N3a<6{_mAPn_+Vo1nsK~s;ZWvh(gU`mL<0h?e@g4Am40^Y2>Kbl zR4&$tf;zK|8EfS+xUhKn4t-?-9KUbWQcRZ*Hw$^@a`L8-Z_02cdOeLd#n-t}{AwX= z*Sbr6vR(KffzqQLJBqK|<7#*VdO@Xe>)M8W+3;S+3cBqUv5h5AA^HQmeE0io zc#!xgk>S@0yt!}f;I7mKlFn_bd;^AoUDM+3LSZ**TA!JE%0oey2- zZ}1g2;Q3iu=L~WNTH2;&?Dt&6Vt&If+O#^Anf0cv0k?{Tq1D~_ib9ea=-6}r_I%PT%6$fb3->?)L9*M zT%i|_W@wtPp{qmg&74N=mIEM=?e{(QFojk(fBVCUmKQE~CV7pS#@{Mw0-}GA^$t|b-cf5yeza>n$5ffn*5=ym%bO41;TADl|%5eSD%i$ z8;zd}SERnzry{u`n)=pg0QyZT1riuZ5FH+t{v-DmCbnMY+9OHDz{Aaf#=8d4)o1eK z8-4_N1)g<6wiEdL?&#(0`+aC(n(rWM(uvVrPaKSmY3qCI0r_{f-Ke9v=T!TaFr=Oo zwcf(h1sks4&8W2<0Ih0`7mwn)fb64_!&=^nA9_DM#Ip;KxnIP+&V3riMYRPVJr0LF z55`O4arLx*=A(BsI(xxToRJozhR}NI>=f%nJFcuY`4+r~R_9PSy=7K<30|*Dy^!~{ z50f%t>C#lXfV%q2&G&6H@L+t`?Wn_*$Z^;DPINgHStfI~1?*xXlnews4cpuYH_cbo zhDlJ-VaQWe=tL7F8QmO=?CQoH)*h^OM;jop|L3_YO6ADwb-6!cKLuDHO6(V{>jzJB zl9Wt9Ay$|YSgpdkaeU+vPxt#th;;CHLcX$quMd3fyRbw?d#BZ3BRHo~)|SXqxsC!^ z(dB(>&ep&Nj;<1xHw*Z3{pg#5v`DliFTL@xCF3UkOQkOh3UK2EYhQXY1?IQB(%-$R ziS|7-PkOt$T#W8g90}!a1YM5Qk2`BS;G`M<)nQuw@pWp)?ssQfK`K>@*CwJF$~~J! zgEOe;I3n#4;y6^px9gOXd!6|*ynkss&JKo=)3^`g1Dy)K=kL>^fR(1A`8mDt|0YSgf5P z+X-Ysbj5qE3V~4w|C+40=HMVuRNEf!h?$44Pct?iwWng8jC+HuWhK(Jh-ke^>&KMs zi;avPRWR|m{J@FgDoDL7P%AY?d%wO;7k@qK#(hqH&tBQ2RUb-|q{{D}mKdYqFsn;Y9$fdhNkv=nrM z(B@c?x7gV}{QUG;O#pKdPMpZLz7{Z-kn*GbHU#XmU1*RK{#xz!zutYTW zqZm&QP(K#sbS%`+`eThY?!H}%PjykAB&Yu0t7F9lA?UxPJA0>dY{_D3(&ptmp*?K1zTk z?R=M?nwnKj^P?ekyAN!n;TbWgaH`-K+E9ai7Rr0Tdwx=eJ&FukUi4eqNBW^@Hmox#RE?L)R-c{_oI*ym^rd^(=fOu^F8|IUDj#%ko{HMf879Tl<07cFVp(8-6*UcnUi>Zu0Hmz#Ud)SNe`>m zRN<3lakALdJai1)5c8F(f~(xlfo~d@(faKJ%Rbf#*ne~&Ok?9!oOjMn9*Y>kz>SRZ zDw@4$usSg4?vXMqW8oW8x2Ax~!p$}rt{PZ=!1-a)Z3vhs8(EiD58`~UxS;^8{>A^) zDDFFV1DsYBpFGz=LQd-5>}Z!!ET0NGP=V55_JH;=uBy1WYf8?a6 z0(<6_#;VClczeSWR)+o2?8e~?0fAfyPUG1i%ruT4tC$nz7{@?I;K=eiws#QR)Ch09 zs`1#1<%p)u^Dq-@2qz3`;O6m1OrD|LP&e`TO2gC`?DtbM@Lw5&>CKP1S8;!XhF7`% z0-u(^o_qO$wfuKj^?uatY)S`wa;(b}m}v&){b$+b=_bLk{mZtSpNHVoq=O3&eIu?i zZFuK@x&$+|xyY29HY7{C-zcx^z!%RormlvLBhlcUar&D+_*g}+DYjz{9!q!cS;$$0 zxu=$o-n@2&{j7ez4)iC54(atGap%W}gv)^FZHoNTh z*GY`r0BIatR3Q3W793eOk8>wv^bQ5Kp?AW-mRzA0@bA{PKTqq=s)#7Im8|ZCJueP_ z8(%{PT^5FdXv=T#AfmZ6msS_v#FY~KMq>dlIhl6HZ|uM`7en{&;pl-|rxX;K)7#;o z%Ao8*&j=iveW=YBP=xgCY{}V1%V_5nzpB%y89l4tMW>#s!?iNI%h*1Z;=oDy!yyuL z7&IgQbxmqF-o6<9psuI|!ub__PHJ?3&*Slr2lSGmV<=xX_5iJ4?o8tL{*~_-vB%K4 zM4}0q)W%D8=~ckbw7o|@W0vDU)$NGas|}?!7sGBn6vn1L$3%@3DCN7w$GA!>5*-BH`T(M30pkojl(;ICtl4c>V)2JX@F>ed<aIO)(4m&0*`gA}0G?efYy?&yj1zeaIm6 z|4?+^k61oj7`KxsL?H@=q>y}RsDp@7R?A3QM#CyIX^`x!h^&lMRx(o7dF;LS=CSwQ z>%HH9pdWJI&wb8yuIqCt(hrF=VoLB(N4eq_wp=0q8RS@oFnI?q-=+psJ+e#tFu`q! z*|nsc6-?Y~Jrd~|E!LnRPUj=#YA@UwY3&N#7Xv|C7MZeEBS<6XS`j8P4`TO|&6BCu z;JK^quY|H3I3Bv?FBVq?c8i?nOR7%~*nJ-1aPjy#mHEtO)xwXsQw2Z)q6MLIN zuFm4{#hs$2gm3CknKI){iG9Qkj>rmasQ_#e12Ls{a$K2^5lQr$CK2K{$Kw%Hk4Jt zq}-ivHM%qSJKvg_iGqscSh;caNcSv0N)r0&WI8@4?y@&mSwE46@ZF)l-Fw=*agPV6 zuLE~lMmP2@{AzXjLHLBv@&jPIop-F{^uXt@&qs;-MZ3qmU_@I$94xjqtcKaUg z0}m^)9P5=XIN^A@v>?A4;#)LncCgI>^=Xf9^VBAALF~VA>Fb>k9%uQzS7{DC@)f&; zTc%*&OwFYG?G-e9o*?SkIt{cJd9&U~x`W6^uegvy)TG1}MS;H^Wq9wkujccuAuN}= zA$jx3AUygJa`e-DD`eMt?O<%JfxE3y|Hb6x!yo%?Cq9oxuwwGoG_IV7v&uP&Ou?-n z;p)I;R*1+y;D0euXB<^sjrls7zv87AVe^~B`^dl>XJs%&_%y$~)Jo1$2cf67_Rl`{ z;ATMWO7ocka8T9%yd5$HnuS3_Tc1dv$*wc|B60%e4DMYxv9k!gInKy_q8kCO)12=} z%w*id-YR(JSt&%6d=qyG9)X%et8xt`6WHorwmcC-26NwoI-dxgNoIIYcrI-hvX-Y+ zF^i9*h{J{|L(MWSiw4CF8d8yRl>CxaG*+RL&M-%`paQ&(e-N;%pT`B!!?aOJL|*QC zqoTu+cHkXP-gI7VMj^GAj{>zQNXE7@A2&4Sv6Q)JR5zpvGJbz|`)AvL&MudAX)krc zHBmN`#$S18_sw$D`QtE(%|E63_r3vzQn2crDH+OU-NHL8hB4RwBlW-PL2#vs7QVJ` z1HWB-$a9Li0=}1B4El1A_@3QPc7oGXvIk287+%~ap1Yh~=`2qNpwIn91U%F>uoZ4MHAOQgHXJdRL0Q`^PbCeg16(*DP^AW9#f@tbqd& z%1;JkX27;Gu6t`Am8=@2fXkdu9Wo7i=j^X(Lax#-+Kx&h_qg=TFj~3=zeI(MHbysr zlc7(?8$w^>RL(t}M==N2YD($btD7NncOGRyz!DmtbFn`-z5zGn#wFRV)nQSZVdyJ? zIrxuGd7}GKBWiiy@iucG2AYm5FT5-wv8Z>%Bf)eU84Zn3pRFkY*1bISl_E><)19j% zZeJgI2(ks7^qT=w4vtVJwqnA^Wol~nXdY{J%>r3N1a{Q=7Gl5d)?yLCf=#+ zX)|V7BytmWtWs>_xbaGz@<{y>{3mDZa(8x=@Y-;GDdDCiEgSqcR){9@i<(N^;}V0I zGDSVkZrA~TR@f5M{*7at_}y8n!7*Spf3)k~Xg+ijTOmtuKhE!~_fCF7DLXwDJzl}t zfGV`hPEB!Nku*X7UNc||8Hb*Bjt*MP(1>N)R9A|Id_y18Z+6q)q9mCgoHZwDP?0EPeC=7X$ccj(7k;-39ry2ww%6-}?x{rbT5>qf86Xuo_KZ`4}dw+*Jw8Pn0PM?~_EEFUkX=%T* zfWLQAya=mYgO3{Pfg(Es!QkkcJB@EY$WFx6@m(3m^X|fr<;_|l;->j;f7c!eN==hY z6l;W_<8g^5yD4NDIVV~|h~JlC?j&dTyhZE`43T2KI)yW@FTW;?nUH(5Tw6_Q9%Dv6 z2qewdp{XAmX`*`q4*j}WaR15#SUL4H=T7;-1ud?Xdy>R=aKEWX>~&gMDffYo=k9j_ zgH_hF_y z%&`-7wv?i%=*dt$QTFDDX$MHUec}(vECQRhW*_@%D%lGsF6ECNnu9ckPjO=<3s{wM z=iqe)O4-DL8yuWx=E368r|fx;9*8oI{_>c#gh}601=fEKfRW<&ho{Hpz>G;JiZ_Oe zq_R?c;O%8%|8)69)2%=T8E+}Qe?La?L#67q9rFNgFT#^S zsqe@BtAHy_`82!lwqoYpoj2J28-R3)903;dX;gQ;(k@E140E&paa=#t3|)S;vvc?Q zq4bH`hgFV29IknPWr^6YGL)Gv4o|c}ncmxb87d{PXX(S5KB`oWEZMWEzL!ccaD$eeek9 znS(T`Ab+#lT6b#}+t*@bxK+sjS2`nhs*v&NZut$1$UY2X@%_U4xCV6`MLQo>)u05G z)q}fZL|*24oGLS+cV~qDebvs}1}ZL@-ttDnkR6^WqrZ0o#G4!#pE|XGXQ`LfP3i!U zexe+tcXkPl=z=u`W_v)F>fQA>HqFrMCBgZkbQPnOjx1(PSHPS35vNG1B?y!{wWP$j z1&chcA31OVO(JP}KDKt_g4X)^z2_IPjQjN-l$^l(7n2p%etyF1zq(FLKktU--Srs4 zR0Y`;dasB7>q6g9p#ve`rcfh;{kGrY5c<8mOy(|~#f|F}Y$pv{kY6oElYwy>#1#We z=5J(R_PIjwE5viF^waBS<03H^yzB9e__B^#UqaT@wtMh}d(g2Y`C@1p+U{69HxCDC zg_Zbho3Ov^&MOqb+@d5 zj_ICYp^F4h%R&5+b&-alw<=x;L2E|iTn{44?c-WuuUsafO}A@fq1biiHXOi2ma859e0 zuo%2wgtejv4rSG~6TAtYd1>pv_)kjZ-ral?|TD!B%*iG=~n62}#=<(;)F}y4Lvy z3H@t&JVf^o;MDj_o(sb>=wd%E{E2I>U?ch{B z-?a!cSubxNZy&?;f`g+Y!GEx&ASHI$WB?Ry#p}1yx1u90)4hWktsr{ZgoiVRxI2G% zr@Ua80~3cXa$Js#Lt2_Zb#h1)T<>6gcpj#)Nzml(EXy1)Ry8k{6LV2{r-JpXb9wmf z$Kx-I#68V;D=Jr3d=xtP$5z$&r!eW2MAU!l?KsT&vS?6x2snnX#}v8s0>{P?nQMK}AsXB4Gdu`Sb{^@@jBiDY)mEObLGz&V>9pGq z=`Q%18dY$@dls4;bw0bqr2>1(?(htOWq9HCSKGw57PUj4By$)P!||14+I!85p({*F zu4Z!4Z!E>HLSs2%nCo9;vFX9nZ|Scw0zJ!?kBmi!{UP(LGk4XOt{O)Mlurw|M{G;jneXM-4ZL`dx5L+s;E_mcPm~k>FP9@e(@utcC}OxqUoBRT>s_M@;fgg_ zasJlzCX0ONa;?sV#e%{2M*OsXtG~f_pMA zHy#ENK8vX!CrvVpo^Q66)Sp5ARbS?Q?o7K#tv}X306!(S!;bUjgRHgL zWyRSAJm7LJT4kdVBNWr3)zf~%kzumb>Z4|GS1>=_l1d<{{+*=RKGq77&2Cp5WT<3A z%UVlosDI#il{GW-^en8X45=&N$YTrE9< zqjbsYEN@^6Y8(4MQYN@EJ0u+!_r9OQjlO#AdHF4**1q~mgGhdpmj~mj57Wvj@VB<} zIn06Fc*W1sh&kL8{#=M|Lint#2*-Q4d%I;ybjjKSUl)cCgJ$haER3D(1}2>t7CEKmMo0d#Ae4cNm-hVXL?UO#pX5_#U- zL)}8zFhX`(N-(d$>b?5vf`vuMTm*fk@r2J!P-5?nlM861{j}=C-~z<3e`%8%UW1LQ z_h*(kN8!Pmj&3(!6L$Qb9vt^wN-$$cM{W$X0EnjY=0VOF-Z)A=Ppx#-5#SD`q3`iXC zVShaca$=JGpEdu17M0nZNGf7p3+rSXtV@HmdrTh+ORDiTYqIQm{tSN0Ff=OLT7pZ> z^Bb|tWPEK#(<9V6g@y5aF-_@>SlOATYE&`=0ycE~iq&(_sv7_9zq$}$xp;hix}_CA zM-+=HzZk(xmB9Jo?gcz@Uoe)-eh`-vIuFqPYQ^N{uz)Imf&-A8spy=s3iD6i6;J38 zK9avo#Hqa%{AL#CJ@t$54A*3 zdV)<@pOhW(->CtNc5RR5{Fnz?X-OX$!|RZT!naN0))0O$m$tq^u0d(Tx}s}Fvv75^ zl_4vRf@Hhls`Al(p5VWnJ~n-C0M(vX$L1yyeu&KW!E|~m(m}4_hrIs%5GBjY9P2#; z%5{-ftLvmN)!HDM>K6^=7Bb->>-UnB3jX z7n|VmQ~ffZ-UhVrmHF9}&EVTm-)E&7bI3FE+vednLU+7JoX z1M}S-K8R!u;-L)11L<5n1S&~&a^juEM1DF&4Z$Dar2DP?#F0Tf2rkrLMJF)# zvhlegnh|JrCxu3=HbEQnkdLHRKcoS#&vy6#hKz)X${g#0d@1prr^CvCniNL%-9_Bb zO^2<;aTHBqnM!wz4EEEiy)!*4sC`?{)lIqw{~=@SR( zS6#*Pmjl69`eB98^LfJGENUMhNN}~PRiW0?8ix%tH_0(6xV0>z#!fo~48C67zlSza zU&>~{@WT|WC3mv&4D^7|mvcuuITmp0WW^P@(*wz|#^{+fhqsQIEYmEG!&b1Ah$rzL zD%qATkB|q@W5UMaY|#Q}D-3W^y3Zi_LQaKwk`rvFjfYM!&tb!*)~sIcIecM|MH|P| zgV~RG_Ig#;V^Dw}yC5;Q+TE~^dy|ogokt>rwVX(hyQXvK6tVZlT#pU?Yk7Fz;v2igtqpX0#?-?nPf7YC*!nepwE;7#`CBQ8@0yz^<6&MxFOM$! zW7can1^e&v6`lXmg6Bg_t55uH0I9tRWRXX+V5m}kcbm{F0vU_r%8bhKh}gvmGrMuH zPQGyTr)MWhJ^rcRrN4lCn>X^KJ`=t^^VuIKE-b?yd>QilUp_1@zw5nzsSM9Na9c8X z*@7&>XH)bJb>h?*RV#P=Thv^lzNT&4htBg>AtGf1(D!Kfm$Z|8IQdsLS(Bm;boV*U zJfxijds4yyqo_rsI#t*^V?*4t%s7&>h{xN|p21(WA+kx=`e8PD z19X0kVdx3UKi6-sAs0=u{tuI73@^-#{x7fqwa(n;`_SDB+pQ}Km8AoiW0`$fR)_Ex zq}TZk>nuayocF0u8D@c9Bhskb2I&8iD+Jy;4lEhwk(K9t=RPPyDa)uKl9NOD{#Hc) ztsmVY?gldoe1R=7VC?JUYq@d`|hV9PK9S+MZvY1MgZ&cMh>U ztWF3Dwwa$sq^+)JUm8Z%aN&P%ug@X3xoY@9enKZ1VgBdxvl;Rv_D012rIHm9S=QdF zT*N1vUZSNh+E7;J(hlK_GSC<67GJ8K!rU7S`s9m6V48ZOzM^Lt=!2SK-uBD@bz%J5 z=-fFl+5KCcd$JeW&s#qbI7A_PJRR!#RmRa~J>vk6DV=Q9`vHb3g40JH{mC>IunK1w zV?9FxyMaOMKRSV!96Wg7V5!5oEI6F`$?rl#D#Ycw?;X-=12V&#i4c=z=pt7-D83ya z@-Hc=FRdprm7MQCf<If?`Qxj9LMf5rU>RqE@c8VGn+cw0e} zlC&ax(vsrrAWF7qeQ`cOO^Ru(O3q=d$6FQa*Q5xJ=n;|T6UL|Jh~N7#L$A+$*gvN5 z0)N&*_~-E5T709}R&MoRqGgAycU7i4vIT?g$f>O5Llt2DscOf4i+=R-4w%h3n}S*= zc{NIv8^QbT_0AajLfE?*FaBeW3{#PPdTm3!sB!pM(p}AURBmp0cGL7L%&Xg+Pg&~) zhK<7ce4@W0|Ff8SzSb-b21J}vnr%mojgZt5_C@UJ7VUVFISzbF@(;2uZQ=fF?n|w9 z#C$&O5Oefa2Od4&P-IxJLg@V8Pnp|p;M-W$Z`MPJ;Opqc=bsI(O#kYIrWG%`r{z_O0Yy{E!XIobZAB48H z5)H}_{UBBEOw^2GK$o3+;6!sX3iIFH&9BppzdD*!X~XBi=Rxn&_`_Xr`{bt25L*un zr|?{fC;UZRjm;-|69(aRA38~$9LB^fA%BJPRg^ednBa796kgg_9p9%v2P8p8u1UQb zSP>a*N-`LS^3eCcH7jOeS=#rk9iazT{${x>YdV9y)paAkf(ZX(27}_|w+rxWJR@w@ zs0Gg)uda4g`U@jNm5lOx96@FB(}??*Q3x4*c=K%G6iTPcvm{-ikWFQOL_zVi4*tz; zDEtkrhtuh8QPC7*n0rjjf+=Yj^6g~Os%Pqub@UexYr-<>%H1*Owit(oo1!N}K)eY4=^*DmfAcrdsbR##Mj zoJ`~=4Fq53Rw;hCl~)1NMi1js6f1Ex-8-1HI*Y!R*A_0Rk3v#WnsxQhaXg~tv69$3 z2c6XaWuBJK#u4j}e{LI%f*5b_UEZ*MJo8@3CZDqgW8PHl7mr;4QVqSO&An;7K@r!+ ztVK;~o%(FtP0YKued?=nsn+4+dtaAMGlBzXcTg^Oz!_=h#rrIsdf};}=*qrFL+Ccf z`n!(c^ePNZeD&{I0E2YK|4gP@(U`SkV_#i2ru4@~dx?$U!+wsE4-$(YdhXx3fCs67)`8}s-WhOVoV~s$ zjqpeNhY!o<<$}43T}j!sUT98jir&$(4L3tm>JnCqq1Bc{!LWwtV+pbkXZD?dFKq7_ z{R!Q}sEd&~)@Txi*&oumvMi(K6nkT@_$nAWsEh0&a#{VwJvLWdCP6Z-Erxq_8l+EM z)iwJ(2W6t?Hct(=BXyFDo5^Ys{+tzNWgzZ?10FQDr?Th4(d2-MbN(a-(7w1o7EAbQ zG;I}_eiFQ!E%qoygAvI8MYl`wTQj!xX@-37_y+6dcAn&jVYqIoS{Y8ah!58FUHGzU zv0^>^5`EwxuB)%;TNC{NMfgrYNQ|~fA|0X?>^zry>Nq0Pi+DRYQ;k> z=4eP~sFTyv%P2_NntOLj$fZIPYp}kO5T&e0a71vcav?-d?@edt>cj^%dT)h{mN4_M z^SzOlTJU+Rul4rdB2eylpmY?!w2mvhG9%g?8AK;uXR5g^(;3 zmsh3Kfqe7}?6&tH#`gvw`g4ELPj3Nl zJA>RuqgK$W^0e=IGK%w@beTIMtKp3(2fs&g8St|!%9L2o0vo;HTA(43b9(mpt4HP> zCNZi18C)O7-EF_icE(KsmtbG(f+n#{-g=Vbe7_D<-f~yN*KuH5JpB9Qo_w^^7JH%K zSqnj(5+>`MJt#Dr?QnCr0Z#6^+ebw+0XOFY_mNblq4TQ4_hUW?S2&z3oZ0%|9Ru0u zm+&0=efE)>uNlJ~DaBg)1b^_N6W!TqLT{6OsNO%UHb-!MA7A+rLHM!CNxS&JE@RfC z^tngo6ePy25K&$KG5pmQ>}z1(3%$*Mt!jU_p^95W(vVvQ(5Cmw#~9O+UI%~ivzDI4 zuwQ8{J3R*=^Q11jK=C?Mzwup3H{S;CjS_d({TFePE9Tj-8=((SlyXgp^+JjEqu>j5 zLvSU5oyOFZ$opijUv=J_2CLVj3PRW0AS5~>{o&Ux=<$t<7C2tsF{;tX`fP$If2{86es3Tdv$cTfYBi2JY7**Crw~L>)|1}uT^;Bt|W<9V-XY6 z##%+kCh&v5zhyR&_n+})azujr)cfSx%KBMCU-l}#zVc%LL)G(dgkK-Q*qwb|zt^Ub zgZ{%-D_xe$_eGi_fvCwBt#@4CkxpqTT!Qd#9;a)) zXeqLYVVmCrW;ou#>wxzP{YGSD_B`1-t=Ej(D<2B9IH#bF^IS;^PZdbnglpd7>cfwE zalDOsgdg$c;gNNM*O(jhH2#3+Fbv1$|A{JEhC6#M&q%FxfKzsY-p$&Wp2nhG3=jWd18U+XeEUlrG0z zULuxp#|JTD_wLiTT!+w{t6=O#Mh~2P9x`xCWeyWN4W`$W2T>@`WuhR9f^^xNQ>JQl z91TuZ>Q!ox;ht*-s)6Nmv@tZq||!-)GoojMsc z1E(%Z^zM9Lhij>pL#@Vnz`r7N**1C-%=9V3uO-uvm?BCg`^enDiqGl~tmsu9 zeJAaK);wqa1rQu6Ym&nQ15ColQi_X_5ybu|Z4)ipvV<4HoX<_ZsYCO6-F@sj%cykr zTDrj(3Q~scV6E@(Iq0+O3ABBjhO3gz1;UqBphNxFmyoR$a4)Zx7dIzkeq42Cj$AZy z6}t}l`3w*`G>^=qS6d+eFYH-t%R0W{3f9~GYKrJd*u=nNL0E1|aYUc+2Y-$4jggS( zhKpH8%r^!`AuQAMoqGFUl*rX(VGYQK>UaN2Qm*}lI}X{8Z6Azb=6i!vProz~ch$Ny z`{x5lW3G6ZNEtw3n2uIKUk^qP-E}CFCw$Aj!sng-%_EK3+(Cu(Uf|yT@xYb%{><{8 z6E2dU#Iws~&ksCZ!s3gU$3)-ML;XCN=5lrc{!_Xd-Jn~CLP9C5kJ_t&OWMLj@FW=& z;(jZAsmg}u9(gPRzt&J!s91rUq5;JuOK6I7Tj73Em&xgD;tuO`Xr%b$5JtrxYFmD> z1_2YYy4@%8pmj{{+n=j*VCV8)pzro9IyXq&oQ{JFAv!E*owe)zbJ=Jet2yVh04vPH;>`vn|>zJq>$(!xLr z!F_0vO0}L|#=FNa#2VoQWc`fa$N7-(PpwQw-{`7=hwuH)FtrY2E9tglO;sc6oJ_fq zr}+yj4%+n=g|!P_DbtUUOj%zw#Y#cl62w=UEqdqn2^Bysi^*m)L)A z1zgU^Xzs+H+(Wm@Zp;B^!__8fp#|t-y1PP@7oaDly0N4$cXCXtijhUA8{q?iYDo6W(a<`nvpcNT+^-ZqG z5d6SoPgZSTDuN?cvXo%@dIDKKWZ!vTxqL4tPwN293E`TgOYOnE*Lfq#9{;L{fsAu_0y3CS?9?M#f zUpRKdxgP?Ln?#6tVZ1KA-)jyd?}U3&f1icH4HHQ@%YNWILz`;;Y#A=^TiKE?$io>i z-G%>d{@=fJ{x=7?AH06a-SlkBLlX+4=tm~~7#8&+`(f!Io<6NqyZ8PqF3BHtu(~&f zi(?wM970CX>2EW3ekb_CXHPzQ@oFA3*T;7!NA$r&`W*{5exhfAO{}Hh#sG*8QS-Vs z7edsx3?|yg1czl=qgQx0(K9fN^Ze-dXqr)k)a{@TP5P!)kZ~HlzR0+i)jg;&sZPbkvIS+d@V;i-?U-WdR374mtoA9 z3)c5Cqmu1nrPoQiONOiU32=|L5Z<5isO6UHz}_p)Y!mZ!5XYMMN6lp!XASRW8%Nh+ zRw2iusYNo9zcQ#^d7B5!R90hWIQnsnZ(B_FN-bWXj?Bx&TKKi)N^7B;iL@{7=!?n@ zg8GDMf)ByRPN%q(|3-8H#oR(U!$SI?(4AXKfNBJaU)+IHS{u;N=03M4e-g_31t?>~ z2T?d$Te4`d3r%gF^c7bxL95q!=HIlfNVmgA;__=U&^_@!D^ocH{p|Z6FCUDBbs?W} zww=ViP3^6|xWgtgp8W6eJJJ^ZBMb3H63CCcGMPFg8t0R%;S;XdmeFClGsX^i)wPRWJNS=HcdyDqI;p zQULyou$JK&AE>+lud;<$4^%DT<+TVt8=n#gX!De-@gw7OtWQCEjT>6pKGsk8IS&QA(h1m5H60D4SqR= zF3nU5MudLOeWSNx=rE`_pv74W42qJo#e4g}k-fUQCaVK@9ZkZg?rcI-yKKy3 znGKA$awt9_+>E0ag@*LI>fwWHO4IwfL0pN;xUg+QaDlo8<+%1QW9{UgqPJg&{XmPT zgQ*$-G2J&e^c`qO_I36(rwS-#4-E}?aMAVvtA76;nhk=7Cagv?QMG^yth+DqR87M# znGj~9YqcmqX=Qo$TsBf@Qd;wM*5Z>b>F+NsEAZeyzc@$9R{VQ{S?|5k7J3<^{7pNa zgVb(^Hkljy;H!2N+@+rax63-&nP2MhW~eYfb73aX*oe-a7Mexdu6L8;#$Bjs8C2xy zJOJIRQA;j$6tWF}sdfp!BB9_+=vi8w1u$Buwc8~0CFX~s8yM4~H6b}MvCCRWa+XiPT>Jt7E{NU=> zMxADyl%%sdD#4b6L|%`rn0xwa338l^vr$xz$C-fjqH9A7a9Fxpg>!HP>fKm4KiuvI z{#{|KH?q8tE5++)C&BqIFZ-wR%&Y*JKG;RlT9!hicaBPgNe$#Zz8mpJrU6u1*rt2J ziGO$W*{1cO2K;c)xI^Rh8~m^L$K*bu&x86R87K5}K;hl~Cw9h5aE2i*J<@C#L!(c} z6~v6-DZ{JZEC$-a*W%2B*4$N~cs_BnERWz;N^9>lJY9o=LOo`i7Yl$VAxcffq82+t z^mZN%{f&R(_LkVP5L_jvFZ&;emBNel$q5m+Ep$%o3`uMp!+08_u)kV!P^>F%W6@B6 zPIl!oOb!De?)Lk`W$6WIceRR$Q*T1GNA9N=|4hU7Oj)u+-Xd^X?>jORu?!EMbvll5 zHUj65!wKj47O-q8cw|RNHL7{o#hrLE0-O2PL-EJ!F|404_CZ1()|MSG5*8juaaL~r zPE*2%rzdx6ZL|+UV!l;>C360+DPyi~8j-OJJtc0lh7pSbJt-FJt>uLr7GbS`O^^f0^ANon>_6^ItI4(D?vBjFpWGC(SBHAt=-#!1D^oFB z55dRl{88>UL-e9$UgSQuuD^(%ecJWUt8PHz{SU58pNW0}uBRa>zX-qR9pP?{$3$Nk zn+!qFUcgKB&y<)x%@DkdY1wC{17O)8D&SJR1q_w1r5fkkQI$i&gpRWk5B^x*D`c_( zm1i83KyC@5wRdJnEp5ZyfYM33i7f0gSX#ZfSPBN-#&!B$%lPzi?x2SEI>_*x@z{Fb z0w;^nq?g4u))Uv1B^AV&Cg+(K-M4=i<{O?nf>jy+TOGtPEshWO5g=$xc$ zTA0UhjvxHi{aq+CC7;0=4Z>rE7k)ttcCN{Q{c@jg_4UZKP!K8O161G}CEw8L9}Ev-K}>2T-ov%4ahb0D!{!_S^hNy@S@IUcrE zgUx4z1|IbeV5)jG36K!nR9f_S3qs97d*0j| z!Vn|1>~XV6eEst7)&AuH@chyqF{?pI+NZ;L+Lmz%*X_i=_n9@rH0ZG%A$oyTl&o!a z_cnp)XUYUNr4>A2=``)JcMZe}J%3%?HH^n(R{nI9O%Z-~7RI1rV(wzTt-<;(2TqSQ z-Pm<~jL4na?=X@ebj)Ajd4~y~U8Zh8)>jEKMis{oY3MG)=?C`?h<+vVl#>--)rtGa zqrbeNjKjTnwwdYWa$7f6Z{7{%8ZU&_YdcwWc*ddf1#|0{=f!ZBfl=+{+8io}e0K`; zGr^mYOSLaD2whf2HH(v?2|cB^e)@kXhkGH}RpvLEL16CXg>xroq0nEOkIrir+on%$ zG;kGT{|NPG6=JR*jV?Rk!SD&AYxcADE>07)P#;?cl~&6`Zl~c|DMt>goJ*y z4C29OTJYH^I{TOWeVD{|zcQKVYdrDl($(Ef-H;qrp(4}KfY-OlbYVD)=5{}i7z_`g z^`0|DS5^j*B`%T5s&X1{e{(7mB<>4lUS`Iw!`AjoLKDP+TWa-Abm9&%P z#uH$xKE*6aaD4Kwf`mP}2#rrW&GE*M!MC9Pt>Zh#39hYj4r^5=44D~D^;5TEvGVY6 zz_(f$DVFPO9_t5#s+@)?2Oayk6A?zerhLlnH{1!NNha{XcwZ=h@$_X zN-vI(#=$jv1gQk1OLq_)>1TgxX}-NB`YN)G$`5Bu!sE6Nj?QOuk!kmkaqy=cEZQUc zBAs^;eH`i*l!$(ZT~uR}41V>X@YbidP_`dNsa*~Z*(^hA{C`%od>iP={aAH{W*nuc z#wJ43Xk`;Wx0+TG@As1;Hm~)JdQ9_fI(o%z2y1=h7wbBjV3H?{G{4jY8t<^!#t zM{Upd&qvmwf)&#gH<5Ru*If7cb7LFSUq3tQN4yuk_3W3HmkA%3NvWy&$zh;di>e+j zBlu`a$;IumbKp@wb)3nm3?4YB@$l)+!9puHtCD{cE?oU=>L}QYO^36qPk!u#pAE|E zEQ7@J#pK5Ki;C!FbCeKUlV64{L*{mE^(_#1oKUt{_6t3Z&IC#j|BnwDBWs+8s=(5Z z|6A$OIC4j7`|c+4V#7f$nx@2e&4weA?ojnGcKrBBB{nq+S?O%8ZhZ~F=>O_1m31db zgs zk4Fy-a1Fa8Vq}k5q_GFckbiuJOYh-H^k|&R4vMT+>Q01;S9X3s9PWEi% ziznt!Hie!P&q-AHVfDV2VIF2qdL5!rXola>vrnxFZn`d=oo|>o!DIU&Gi|7VjO_^fQ=*{Yqo2(aL>zype;&Q6vuv?n54HTnR|q zUVcekwL_Nq%ay-zqA8ei!FaXBvlo+2+S{tMj3U7raEvurM4bta==HH~6jgJS<{n*u zKTo3@1O%EYD+@pi6RJQ_A3<{e8-+W35pWbJ*=N{h}f5`_P>3kPkjG39>^!YUF(97KQv#DZ&bl- z=cl4d^?7{u@$d`f7qG^TTJ+@p3R{Jni2`=U&GbH#DZ6)V!)|@4Bq90O6_tW&DisF}l zxwGY9+RD`EE;tV{!3yiZH~_^TST=N{iG5Uzbc|#$2HIt>9#*t%!nuhW2V3I`*z$J$ zvB}Z~%4feK;() zcZEc|h+lt7Qs@#~Y1!Xhsh^Il18xi9M3%rxR%$Fh{8F~x)*`3~ia;07>PChMhz z5IIE?mnDkVgkS5XM{Wd>8w&~$G-}Aq!#$rk6!}G4!QmWD<@C@;!awP(_@0{3>HHIn zZfp5M&~=usFGYl(?UUN|h|}Y6Nkx$8u;0RYyE`(jDIuX1pIa+ofn?dNj>s^p=tsS50UB4Axx{L>GvM(wv z_2FWrTB%`j0filG5$WC9fw7?8vS+={mWN9&mW(^yMQ*uHkDZ$WLS~=wH?R21`0d2%J1*&!l1p( zvl(&g_&WTob~jBjoU>#Tq}OkThbPW#Bph8r6;Il-%=AUnIHDpf(>w>x|3y5xFWU;* zliDY0K8<2fCyA?wT!rsiy8dzVWuhqMR^%`13Ha#We#?cr9pByGaH}T#{v0}SbnAC} zA^DMA*hQvAOnsZEn)`v^J6{x~nH&8IKOaB6R0H+FXyDm@OEO!qx_|oQ z*2yvOGHUP&+uMd8p1S|CdD#cDGnUqCQH2=XUAXX8ky7@8)S8-cY8xnivcIZDaC64m z-a(f~lek}rZ`Fm9@RyzDO1`R0%!@IljebG>(EgxCnRLDe^^B~a^$SK{@?d+g~+IcC?gVytW+Q4q%H6wxq3%BUoi2&JrK zWs_1)d+)vX-j}`oUf;X_TmS3vaO1k+hRgeUzt7ik9>?=oc=E}Xf*+Lxl+~V(;QR@B zJBDToK9Cc&9aAp_+ppYeAUF=WX;aaP(ZhJBvBJfzAOQ~V9AkCLA{^b0+tNcjXJM_; z{7$z<8CD()I`LI_1jE)XtKDjc(JTJfp$FSY-w^YY?cAi_XxQlx)q_V!%vY5gFWg74 zDv?v;fOr=gH{2<`NqpKu?@aR4E)t)!@<$QZgUxUx?va`x*`E>~nVohz@jY|tJKw)M z4)3ToiF(GmpfGDdW?nnt>Dxcj$TnkCnRULA(=5^n>Ed<@1;G`Vl_N8+#61H(6z0dT z9*tmU%FCBg)&1yaUw5i4m?isAo5%Z3PD1v8?MNHh7i|4@;hNCrDrn3t ziQKNx0)druzN&;5$ysuFcNlr@-n`a6*L}SegACb%>>kl(?Yk(;)73)yKS%ddt(Nsc zrJiz^L0$kzu3XsP+}Mi+TTA*R3TAM<%^~@^3I(K8Q*PzWjDs2VLC>-AF1+cff49nDt;q2R{P5V9zdnDR^w(_pr`A)2vp#QvG+^&%UbaeRp`3&JY{`aH6Wx}@)%8yvS{Ih8l9Cez1$2ZI)Ja!v0ajJrI z0-exzjP@vWfw_U-kt4M|%5WdhUhNG(z$_POnI#K8%i^k5aCy z$J2Vsu0nTPq4!zyk_z#sw|2=>rsJtpj_&;$sqNGc(j^8$BH=+$676*Ui){}2xvs5V zDPM*6Z7b_9&8V{CJTwKjr*)&^+>dIBu^#mEcUG(&>cov#QWK$`gqOINYU)%z;Z`YV zX1;PH^Ka6c_rLWXNCx44t+_hV?>e=Zy*7%=+P;(G-e2HK2ZmLqE(CGDpN4vQR;1Q zs0xiZ>GcmX%n%+Gr*tpV1ehy*Z<^O2e)AR13Zorkn2~UEPV;CvM7vnt*W#zZXKxeR z;$Y$<`fjtvsQTZ=QSgL*{^Vv676E7J^}uX_Zap+ z8AlEOX^V|{s;tSDkS|%E`$2*K4Y-iiT91McICqqg%jo_7% z#qAGlvXFA1V&UEsqI=iex$yQ#7yN6ld?dTG2efXt6#Qr#Le}Xix>b)nWcnVoKXczC zG~Dw&FA>)P1D+Ds_5$e-`#7T{DZ2z0wdz}%N|Nxxv&M3&6H~}qJekg7I7V{Y)A^d8 zD&Vqe^Qd6qJhV@Uj@-K$4Qmg!ak8i9!DkndMY#bA{H%*Q#`-)2A5XiV>vC!$y^5h9 zj{U16c|5K!KI<#^Zs^ULUQQp%9%{~o{m?21 z|IF|KrT*e#;>Wnd_Vg+(W^MuBs>k8a;^nVVl`~*B;ntw!xQIfJe{C1P{1cKa<4VimC?ZV5x?`u@sVCFvHcmw{mMS#ypGfSp%(#S+5M( zRt|#x!9Z#$ojKT@TJbx3U=$~8L?}K9Q+NaIw_f?)4I3qU3s^R_fk;MWmB6_PXzbjq z|6kxFNEhQ)_bpi{1|N9(ocgf$X_)!Z(E*(KV-)4gF#{wtMz@;thxkB8b(~77Ftxb& z`~P~QG9%=eH%$!Yq8jrofR82TtnG?5c56!|oy^F8!uWbMujo$Qi?EyHM zEPRW%qXrIjw}~8jG63!NMtj`+ zT@<80?sdbJa02=-hVGx}g*qD}<_~{r;pxNIO|69gaN;3L#g;nauNXhcbLY!6xn92n ztY)X6$B`Pr>lbR!eukypdRrb;M0BUprA?qqg>c|7-3TU_On=F|QiHB60)`y}8>q~h zNVB2606c}0YY$8)NRfUn(0)6BoKq!&W2{<{iGDFPATt7am6`v~MDKhsI zh|9@pF5vmNr)QW*pRa3l?_tADt$2Ls#)^MF1^Gh!YU{)4v-}KgY4=SmfVMWB|N0P> z%880gJHHz*VWhuR%qin>j8nV1ND<3}MVd$AFRdtec>2svXRay8^0qy7es2o~`xq46 zw;KT&8EK~oB@2wA(b|n~7cn=WD33pZ^j-IkTzNm;4_4Cae{Rzc!0vIQ(~q;O;Z~C7 zFGl)Ctee_Gu^bz~PbHqQ_WOr$r}KcmrehNr7@j@DNIs9QxE)*v%4Z>2u(eP-n9Ly$ z&$s>Vs>knCF~=IkOJTeG3}*`A8fR3R2yrlFAy}Kp>F=LI538iW9o%J5wS}Kk{K7P< zryF}~UuXyYlYM@z@ijo5+QqD{IfCr>tiBB%4h9-gx3a*nUMR)rTa{}G_@8iURolr1 z$m{+ZQy#wp1(N0ldJK!edc`4cj)@MHFB4;AVfV*w4Wv7vyMM`j)Pg^v-^plRr=e+zuOJ zy77yc&b2#7&1eEkIal7fwhY1H?t7|<>8oHtU7s)EL~^L}U$|qcYMGoq&m;JH|Q@m?+d5lAF^QN=~&9+Vu ztTkP}UO{^GR%ZnmB>O@BaCB6EU@lZw#uQE;nuOGX)K{8PgZNIF^_MGs9sYDGGvB=U z11d|_pI}@#Y&Y@e*&u$NExY{;(#Bg+>Xlgcd+Hfji8iyz>`DPaFHP$`4u!CnWBhi) zS{*z(@wT(&IN>QrDqWH%{w*(?P*!RUm>Pf@8Px@h^C zjC5l~dUnJ-7mZ5D_I6>T4l@5K3UxnKB0fl;prR1}BoGq`SREkuk zh--8QOuQ`NAWk2UdVfGOW<5z6aPZ zxtx*?nZa)(Zv0QDX|pc&&`_1^*g*P^`_#1qOfS!rAprduJH>u;I>Aoq|pE@KQmkfa6#<<_FsOS&=<-z{51D^O419 zo4ogg9^s;T*WP(gIot&irg|dsniVkCuXNX*2qC%RX%m@+_6!N4br>e zC_MokcS_QQ++Tza(%+wi=HGF$ae|A;@nM9=n`#lWbLhWNRu-_Mc52|{4V&g zukk81IS^nzHu<7x7_Z9p>WZZhpFQ=7pQ^fTIO%>;yQ*;%E=wBPA6_jce&_36++k@ zQh)ju1(!N5X*t?aWmOTUpx!&ex!t&DPxWLRKC_e_ELfO;kUj3>;?m3bG~cnTU1u6a zK5*^HC;Z7{=r#y!sjLL;4_pCB!7YYlWmnjo)4Zq_0Gf@7RWC7CK7r5?G$;MXE~kj*TDT zNXM5J|39CZvZBAL1?hLYTHem=rm%{EqVKwDKK4K+NBC2|$OeQxde=S4zVh*zsaI_8 zmT=?Qp^7W^BVgd&VMk}#4k7m#I-a{!K@3Zpkm1iNyhN?}MEAoYhHBmMzEV#(`M?;@5lQ|D{P`GzvQfrUHEH$MMUX#dXD)S~z1~|3ajA z8BVCMw!YrkM08*Fbit(iR>^5Q>K9C|N$!FLt|rrBeoW!hjvN@Xef zWhRE146ObVPXYe!m}e_`#D9MM(x>ZoWzcste5u!X7Qfs{Xl5pyxTpFy$4rB#p{`_s zZl3sN!jpSOoYif@i4`uknjzJag}G|6#R3 zklDp}C%dQ{&kS&mc0Z)a>NrmA^>7zC2LvV5owKP!cAsd!f{=cY+G$mG*1i;O%irTQ zF`XpmwkQr`!pk{Gk)Qa_GY{;X65~e|Cm}jXBU&+}A9tvKjD9iR46g^e5C7+w2&JF1 zJO7Xz)dh71#{T6CsZ>r>RR8-Ip+aC}Vce2W6yA9uuR|{r`ROuv4!Kf2e?MDa_}$FZTd-$Y-AV zxfbFVYGgL^i-WL}j!M+od9c71sXUPU9Xa*i=TGh+`s;U%I~l~^96u*zvP}GM3HF7I z7i-7S_I3kPdwvD{ZTgm(`==fA%;zrZkQ~Ru=Q%d*QFEBc(RnGYmPRF%B~3KoO%KM% zkH6m3R|@l!_q)R!@-ZdpyOT)N6qE}IMJHNR;kGrur*ug}=qO4cK#kMD*IK-r^F2sM78o;6Vsl&`?>#?yy`)k=R8Wl4khr+-u zJ$U~!gUA`PHel`D%(|&;9&YkqS=&%2z5>@njgD^pSoKKu6C2@J?(Cc3Ox2!+&nHx_ z7Tg^Ixk2gHR=y^9oo^96z&`+VwjO;qxF>Ld?dUE`(g$Fvd?ZTOcL`m5gokU+E`z1g zBmV>Ug5cHB@@tGVGqB4nX}VFO6EcGt*7PmLAT%&iXuDblM5%-aKNjx6o&U-`X4;#P zZIjJ+dHZz~KhTtB_K5-}vV6Daw=_Yha^oI)x_RITI-IK2F%JVVxASet{wIo*_MML! z1I6wGOpBs(p!kpe#XFKee{=N4rO=8owDAyc4TY@bz!w_&#(PEThYP8RIsRe7B7v_=k?!8gKSTYkVC{vUK#(c zCT#l}P(M1Q@0~`@31OaGa=zp|>#slgxpWP!=4JbTxUb_5yAd7ssa~YfV2Rw%x(ew^ zr|md?kY2@FixbaXr%)zC#wtE*0apc$-4%|E!Abj1$c zm>s?PO@=!g(rcpz8B%7^YV+piiOUOE_K$-pz`GCc-@n6^EHFcKkGAt%R--uL9D2p{ zJL%cD$@Wi#XBOSVYq=)m3qW7w!ePURLX;Y(J!R%I3{4iub#ic1mS4Wk4eFi&c(Fa! z#W!*q_ijYBJxg1GA7$#+W=i?E@wzSKZFU{3I?u7F(7i>8ewA3ZrWI%n%BK1CvKC%? znXLS5&w?P%C#MseHfJTh{?>G^au_zC(|!Z;GNwc zOs?sV;dh^s3x*7JAnM(H{MCtEtdHo=sJ`EhD{K7>uRMm(n|)$;u^iz`X>y9*-PQq& zJvskLkoyc<i3bA{p+2C$w<{k>K} z8LGY(n^HTzh%PFVN6std;8Au{SJyqG5bLx0#c-_`X4>uVh~3U2J$OAfLu2i5jLwMj zWL`E<%^lF2(Ps&Nb>-TM%TmD6HGlCMQ#Z&{wnp;z|HA{3S+_4_<-vC) zhhI#@2gaik<+n$q8}`Pj?=)tgL(I6Zc$_7faN@UY|3K!ii>$VrGX69I?dX3o#z^MD zy5Rwj3q!bD@a)^&;{}lLsp-nn)_%;~>iNTtCkv*dBObHRw4?mC?(m^cBXB|PT2YDB z6zCkeap%g~Uo@`1r@?Vcdc-D_=DC9bIk?+^P_( zy}3OFCH9P+dh;y>EYABaiCA_)>=2#0{=N}VQ~Arxno`*d6J zmQ0yst>p|JucUXDBzmT2TET6x_w&Hwe@O1%nM^XLB;|czA-)|M?iM2)0aqE5*Uq7- zQ0A5SMeTS2$wOvArpJt+;M zn`(j6jVyn{{0JW_nvQyd%+<-iLb}IRa$&Y1^7NCa0r1%r=Kh>#1*dN+^@dqnfs>?@ zt)y8o>Nuvn@unTbfKnP(sapk@sITI9l<=;_ehS5|*QUT^rD2$WJn?(RP<4ABu7o9? zS2n*5)-Z!RBlcpD7fjgkHd>MU+4i$O=@TIosC#qr606uhn0P7UA}BlxGB!`;*PN%Y zPJ3`-{&zDj_Jp<^JBXeH`9CED!n#pw_60Lu%m(JdnoU#}QXx=ViC+H3 z1X$;1Hj3`8Lsxn2&ZiC3DihOxWVst_aMFaMh|^^pYt<4wEUD8la&HlrXGtwC>2m7o z*-XQ}SL;DXuXmy4TlJEt#SYNE_WO;#)dI%9({_nIT#f@4+&SlGis5vaWC&aR1Pr_X z5)f9R&SFz_ma!XZMO9@VV@Zu6Y>!d?>F+QL6}OV?np=lSUT8Adnx_uKCbZ<0TS)(N zlG(xV!_zR$ab#(2j_kd2pHUrSONK>@lfPMWx`9Khs!aG|6&}7=yuw|#08(s;tH;%6 z@Ll;Q>NQT%>nnBG($Jf5YQO(Ivhz_b#0+ie4r9$lMhoi9LqmkCIC$(*R9GMByKOe) zC4P((L%|~#hQXvZwg_);P|Ka~$7EFx#H?u0nU|bFFo1 zxmcI*mQ{3)0uQ%r_pNg-$6?RUmjC`$;_sU+C9e+r0X~K6&96jyNlyR4+=6Tx2-|WU zYz?Txp%c4RYUO6|=GK>!%DWTLdP6AS4)*|D{JpWj!LkHTWUS3~5BI{ZW}kiXA>$a) zU&D3i0hP*a>zJRC8|}Easp|cV=K_vb>+>D@@D=io9OgUlClVfa9%vWtD1ZrV)|VQa z8Zk!rew5gidgO4vWorJf1NP)Mrxq{H!I_J48HoWKK;6b{e!!#-+xL}~yxiCTXybo# zEp-6S$5FX%jIBf6cfS7c!4>ehQB2GAC<+`)VyHE*&BBVCRQ0~9PRKc%c(}u{27kDv zPHE>?<1^dizxR;&k$)HKexLS!c*ABjXCyF=0{3s8EbJe|WyaBKZl~&yq8oi(`%exy zg`GcXO8VLKj8$Bydx9b7mLg;Q+e!5OP|nW#jDnw7Jrd4N>y%P9qfsrZydY!W>1V@;&x_SVmd}xc%qs_fDq@%+KaG0CO%jQ4;x- zFOT5+>)PJYPR+n!veRV2rUP&6s>!=fa^_Kq0fCP{lX-Z&dZ|Au8?H-fup#>m-dGs{AA1G@%ve|E~<93QtSl%OQEA z)Vr~6MCag=f6O-@^MU-m7k5XCcf)~TgU6B=`|y~rH*EDFJdEiO4qw(R@X5<+W1U^b zMZ-@nFG7PMVSV7)mrSB_olJPAu)hNO#-@MJ^;8m_@Y1$-8>C;fwme=gw;D6`Ogh=|!s2x7KCa}5<^?}~0BSufYk7IC6-^*cfvY*yII~Z2b2MX^?AGK9AL!Mi*hI%|M{o?-AVN8m~a-j(H zpVmC0J@Ofjop@T@Z<7m`lx0rEeGNvhY+d6$DouEK_Wg@(a)H1S_OT-DTR*-yADfn= zF-&|=X+iE)HQ;`=XXfMMDhRE9btk%Y3{1~Pirowxfs4B*ukO!w!LaHa*~>eoV43yk z12N*yx7~xjPR?Tx5|zpj#7FkX4M|nb0xP(|)w482TMk>d9h0XELD7(Il?sV5yZ<0QC zdP<4~jnxn=l%_34p6y5NzRp+rL*$9Yu^6Cq;rOQ#;}5zN?6PIxjy11>9Vxtfv@dsKhl7m}9eoKNw`Op+J3{;sL3|dv zUS*hTG5NuDq6cpDuuV+6Nx z<@Ge8i^K=+dpTMGI*F~9P5#D%D>M^+MK9VU_U3gK^g^bQp1D@`FbXbroY?+r47R!K zmR#+hMn+-%&O13nxcT>6t#F}nIF*{-8n3TM+hWFo1ucCu8gZ0a7s8#!kCJ`%luZy}SF!23EBO=kIW zv#J&PQgwS-h=1a-sQ6W0a(+{7aX!3vc$D}-#;J=^rf^GiYwtd)c}%ONO|mW^bKkuW zi}VJh2kBnhIVr-x5+dUM|tpM{-c6=pm7OL)j!k}m~1FLx*q8`#S zARfasxG%mBU#omByj0x_w^tTZb{&}l*6PdiUm_N9q3hh8v4$!1&(%Jb=T{2Jq1$N$ z5-E@*Sm@y~+C?_v0iRym)MEASuWtmH{(#QE)IUwp()b(^-D$f!A$w zwESk%@S?-GTx(_!_6#IQbCk#8@Ry7Sw$(G>Zpo~$exwhMqG3bCR5#i<+I3OiBsp>i z1-_WZLX>NBa*{kxfe8MLCdivof7(4_)J znrRGkk$duB>m*FO2hC>Poe$F}SLC z<3teYz4Gx8-g|Zwx+gMabj`b=Q7Q9}DEAo3{z{jWB|X%uv=o7yeN)(2`8F<_sU8?D z-HmU=48zgn?R!fDh(E~rEzLXLTJ*5J>T@u+4MWCgcbaGy;g1(fj-T8+@TZrR@4^+@ ztaGE$C*H7E!mSvU&(X))z*JJ(gLgNz%7M{$76!Wt@%j5ddW|RRf$OCn>^@I&KPLs) zwb<$)@m*Y8-9Q~uIdaR-=8PfVp4(LhRjnvv{ia;;M=x?ZSjm2s?Zo%&m-YA`)}mSH zOpzGQ;g9=rXYzeVaP*%*+zRP2JGPVf#fiV-M_Gm8hpl~(w^vRyoaAozP9Fc&<=X)2 z9Q@HAL}&1zP{x7SlS{x?{vxsQSrs~D4hPFH^~2xt9rXHEeUL$&CZioi=oA>!@nfxqOEG``5n&1>TmE!&j5fhe!9ANet^a|r$57sn zhy~Pi_+9>6oPwxtzk~0|FmkZuokIAz_Hj`w21ElqM#vz_Q6F?XofHHIcu} zewFMk?%bm)cI2kX+P|gnpIvdUdq^9!W004w#TVTk2hRQ-Me6gLISsfvQQ-Nx*Bs=% z*@Zt3KkgjGXM%2H@xK>=_jIkqPqRUIF1YR8AkQ>RG%nqJeXj?u%mnNSAvrJxs`|;& z&?USe=`N`^)q<~e8DD!2Q}6vWZKhn_QLK2xE=f39<=GpXp#vS zfp)8t@0Se+f%6Kd+euaG!_1KstCE+k*=dr(>Q z#-}kz^Gxlsv#Udab0J=90)wDdD>*NzNqGAq*J+a($ALcj+b@ehJy2crT$`zU29Eey zai{DXKnX>U{V$`(@RrMTlCd^T)0I?J>|nYZ|Dk+}^nb;dTec3s zc>0eq7t)W|?PZ|&lWhv>wm)%cshx-G)2ANoogBc5bLMt0ve)5)8uh;sms#*Bmvsv- zAbDJ)OSdim^h0*k(*ynPS=cYo-KVUzg7yW$Gp`advEpbrzai<}?vkmr7m%e=5tV83 z>|2<|{7<=`c!*E$*0BDK-OW`Hki*$&;y~t|VfQuLL6R?UEHWxKqCm&9iZ)X+x2DfC zMT;x?<9p?Jj%TmlV{$5&x@zANEpL zD#XU?Lr=;Rs&HZZq+w7?F?MXW$?^(Vf-7(Sb9qG7hA#Dg^7T|nk8bZ^e9gme5Na!b zndbf^a{LtbmnEM|?=+K9&R8QP(dOey%v+|#)tdL8e6 z4%nstk6i!8%w2;!DZuhfv^!aI76euASM|SHg?~9tHqU$~A=&7bjyv&<-idJ0H91Ur zUidHn=hQa?kE5@i5NpfDqyL%O@Y*(FJ(a{c35jM5z4P$gKDl)W@3^4x>&OJO^2gA( z^9ErmOYXycdug)#cJAI`y=fNa7rioM3km=1*x%v>%W15C>3!9WaEYeR3;FLL`@+53 z|5!bKv4p=FfBh&>nSmK=`yr5A$0A7qaYnuobP&GE@2O%7(S@_Dds1rW*f<*JdDHXz% z5%Jx4?V?$QOLfPuZWvDC-$+%xZHW^gHOq3;g?$1K@^(IZ^t=g#L{wkKwtd0Whb2qn zT0?kA;+xat;W=<}a#s8&T!(5Ow61IXCFg>7n_u4BHG@G(dgpF3P^qwt3oi0SOrS-_ zb{4(;%fK@Kc%{)R7QX%~d{#mHWRrM+ndC`=Z#UY(A{_~ot&3zU;Uuk za=jQI)=5=MDUrQRCtt$Wyd@C1rS{-4%OK2)WKt|Pbph`OBP)Jp3WTvnX*{4S!%(aB zB~Q5twC*o&e0Z*j^ufFIx`cFr$4UPe!K8=zh>4!bXT~|;4Njf@Jhg^pH%xnXJ|+Fe zMcjWj@iD*7%tKy<4%eG61B7eP!1P6^ z3cbU3oU7Ao#&-XJo)ZC+@SuT~3G|mBrD49>>DN3=`URs~+z52C>5u>RPJ)j)x*GL1 z6o|TUdWYZk5m2W)u=4hBF%Dflw7B6)_$|S2a|VA#0Q*SoPWiGT_(AP?)Tx?q&mO(E z{*+pS?P{lT$1>ZXr_1@;ZK43rgQB7|V=82MrN zxhJFLfM7S8{`X-28W-uy>RjA?T%7nwenusvQW8N;?&0{X^e9eto=F*Bhz99-f1MMT z22d~Ybe{xc6?*7ZpMk4%DmOTdubdnihttw^NgXW|v~;X_&;FfUAGR(>Jf+5f!Qn5v zWm6S?^U%G+L7j#3D>4G=3ba`{KT}zQ$aCm*XEW7t_F)YAcx(4#t{-q9o!Q*2vIKY< z-|zV+GJuIOV$&}e<}g9b_sMzgO31qHToAbn@p+V@>65Y<)Tog1{x4?&jV)cZn=R(> zajzJ!2-#27&}{c)s*i%Y$kztn{>w#=m_yFP4OA*6E{inz`TaPjtxTk^8ECh>Yjfb; z2v+weK9;l|!rZ_}C6|R^)EW-X`0#xk>gQz+*R^CIdu_yC#kN@-Nps!^N+h`vjx6bW z-&){IZE$8#BsmZBlpIMIr^-q)H?6O8r^*_8vf4SxGKEW(d*d@RNxpn$%-}%44AAqb zEe`T6Vu$CBzg4_dSiNd22sBM{+$adaYY4icvsoVC>`3a&kW`(TQK^L!-9&UP-0j;H7#0So-fQ z{CX`f>HGl-1c|2J7uV`VQ~tMmqJ+lr()6tC{0jrsqXBbaeHIyC)I;sbpDc zS6~tFv`%sy8XreD-Jf!tq;D*}I$`rb8sT+{1iz4oTmjy}+DwO|y%_aHS9fn$5?beo zmuqyBJiUNf9{nQe{S=61l`-o>Ii7dkSJ_D}H*V<4+3)>mA0huiH+cZ`)lOaGp9+Id zStqWF`Bs6eM`%u_o`@KCiSlRdbqn?~qU(${gw&F@)e9Nf({=F4_U z1cTYfmYEWS>$+yayluJxLe>sW1cokxS*w3P_pKQy>fTlqn%WQ3n^(f0RSiLtU;Vm6 z{u21PcOEp{(*?o;0}~u~r*PM#pQPokDva@G&e63R!mfh1`NKh}Xw)(j^Zj@o7-VWi z@I)=cogK$6hRoKYAni}C2!S;mP~GzH-7LwW@1*Sh^jDV3&5|5 zJYgwo12C1w(KXgT2RT{ptNn*-#0{0 zYS?Yq8BP3CN9QcE>|5Z0QV-z@{x`x zw^u^s4oSYy`m`VHKDpk0p0$WN(r)AdHGt1E&R&|hQ-jI|^ZWees?n1FnvtD(6F$qf zVvhbra#Jt&XT7?c2~;NrjN5Sod_sAP)$aBH$G~jG_S8ar>nIm1IW&wLZ<=xypLL_j zttWxBH%ei@cs~DUN(jbi#kKMO?uYvg=k$XZXtK8Vs&jAin+HvaUujh1WPkJh)mlF} zj~?^(RFHS9M7Bmxog?uhuzX>e*JXPTx;>CoIQp&Nx9(t==9gvc}iQhI^ z`!B|K!oyw4m46ziP+9fy->+=bKrN>C^xMNaP`~2LKKrl_-VHhh2hn!mTj#}bYoZU8 z(%rt{mN5%ezDF-L7iXZRvHHOtHo}*@rgbsfVG7(7WJ;rk5R3Hh2AYTuK$4F9>x+BH zTq^OMk@r_0CeoET@GLf>snw^aUhIUowrzg=Z8zy#>E(M{s51?5V&Nxp+J|tp&iK73 z(>GjFjr(SPa~*9=0;8Jf*PtqC??mR}0^FUv60J${G4;*VS7~lFp%lXhiqq{vRQtu_ za`iT1sJp;?T(}2S0mU752?}>&q5@>!_4K+F$krf zBo#>Cnd#L4jUd~0{OCW(ANznh%OQg6bU{cC2%oNTzG$$3k3uF^4iIkhaOb^8M{l;` zGIgq{nAA8P_dCy-?>m8)(i!)xvQa@d7J~P1X=Ic>Q_QKU? zI<7YPZORg@ND(SNyMn!q|9(;e^iYOB;7w=C2-vmcyUjIBgXVT4)!eaREImP?`52cB zH=T9pOH4>!ZYQ6H)E=6wgPrtkMS*khQ1h>0M&dkbwV%(pBCrA0b2&Pnw)tS`o>zBM zKP-c}xA%-KO$$Un?-NP%&OleYsbsGG?a+SYTiaOQ)4q~0-5Om^>Df^Kc6n4nnv6bw3 zBTMfMAC#NMWRV)-$=Dh!sB0Ik6CTHb*HTAi4-J#Pgf9UKy9hs&tt!Q#KNAzEoD-vn zZp$ojwL7z&Mx`qV7(Xulf|nkA@$HPM`1hVueYMXbo}uYD8C*PsOjlp~$DN+S_CI@c zz3;EX;0@~HQJQKjxU$ni85V%sZvM{TMl)`H&vMjp+ay>Ep19>te6BIv?Y16w2xnhH zna%Rf2s$aKOa!S@Kr?n}DZs2B>Qh4Rm3J?rjI8{=*1>5oe&&@;H8%q6^p8Z<26_SG z?}-T|62IWQk;GGme)zWbNa=-g7rsoDpgFvG8Pz1zTkPz}xizJF?2Jb}p5>Pp7&obc z-3o_4NwIFgvAYVD4?~(zXK@C!SUWJ_SEGTuS3PbKxAaUA>xBn0`ku9_-GEJ|13H zT_Sv*%KWlHYNFSCxyyBHaTxXYPi8J|t;5^|gP?JtJ$TB%ht3J;~gOCCN_V_vUzxkqX=1>%> z1Rn8da_fOda(r*X_s@f(>*>ggtzB5A(pn_+sSz4qvdAl_O=4*nQ+55Le6UO4Hxal` zfq9kOzFo=FU^3?FmO=Pnu?O$2K4Gne;G@?L8InEG*U9kkju!=W?DbAJc&>7R-Z#Z z>&M11geT9U|7*)fc7`nep6ODd8&M$lG3jcmUMsRi{x190n1>oFbE#AfoyhU`y6I&n zBmCFR`1N=O@$Ej7-NsW%l||#r^K^#;@z2M7vDYU)>QkD$j^&4^VC7L6&(ZC(C?84T zyEv6b_?vRCO~m@(p?Nlgef|tQ5x?f(;n<7bd#>0wxpkq-+BMa1>vpug&Tv+QkUw_S<4&Z!Pe|x5& z7mKPgehZW9z}5ILRVwM@P|j#NNS)IOB3-3V>co}+`G&IBkL5u}Leth-mSxaPN<942 zei1wO(tHm0kH?Q;leHah>Y&L^-zt!t>%2J^>fGh#py|QU!8ZavIB+k!^eOQlFKvfo`S!u|5w69@ntfiwi;oV)j<&yCJ0tL9=Y}zJti}0aa z>)g{#iT?ILr;DBFCiVQ6G+W3%X~(IETUFzPAC_=0SEg$mtbZLp)uG>kW8Tr58vc>} zgS)Ay*{dmV@B70vRGy0(eL?wb4MV6X#^5%1p$tr#vbGvI4k53TZK1}8Y1sR|`bC{t zFLv}czW=g1NOA=SbL4L(AwTVHYaK(Pi&tx~EqGCo%G!VXx!whcZz;GDLrZes$8OLZ zv0Q{ILq02K(FqVZxNYdwLI%8;-P3t@p$M;Tnin$n)r6A*kGap;uVCC9lgiWFQS|*7 zySa+956Zr5Z@8j8LvmpM1{*CG;Mc`%R2Ltn!>8{t0kf;M!1CbplXKJEVDB#Malv;O zG&Y`yt(>G*d7I|UV?IE*Ok%f8e7DhLJ-I2{fAaSvoN|3rNm=d%gQGN)XKogvd_jTl zdAc4jEZfcaue%@miZiZ+?xs@tW1IQ`&QC)?QDx0zI)5;>ew*_jnFrOi^MaX8ieP-` zWJpT&Fo47Rb>~N&C~o@p;S}c-rVRek-s3tB!G#Cd*+Xhkx9WzoEk_j!w{XUH4HCYy z=@AKf$v)6vzc!Q_T8!tmW^51t(}<@cFQuAQ5uO@Fn*@)EFS)GY`S)*ANa=gDZ|jL+ zRIZb`eb78Cq)Il&T4c+f_TI9E_=mmZes!l8;%fAkqQec{xFhg^5nUY710|LjzZ`7CR9kng z7~m~6u}m6eyHsv|gHz7!N+(~s8+J?L2(Q_#72yY`O9^{AW~-l0bPAJPd9 zTgKD}@y7ReK?_n7kkogyJVI_BKh{&u&@VRQG1F!<+R7<(ynixRQmGkYUYc#bY)7~g zj3+;eJ?O)z&vL0n8^rffDv-9;@f$2I@-w+BRDoGxO7~4N_vbAy{p6Q&0=@gxcFIOW zz{;DX*+n>EH}=`Yb{r>u#);}3{xZ|RuXIxPZReQM<@~nQ}5iw%TbP>i#?nSMq5@=UvS9 zeQWLTJLAp%fxQ$cVcvO>nrZ>L27+|w@28;DLzZT#{$9+Csi4|Lav7&2W%SPWlf350%N6yF}U0Seq5bgpNn!G6mT;dP=jQ*LSpyx^@z zMUmTI8^$Q0{-fQO=K=+Vp2($h&Q-z;piy*LqdcK~nx=cjCu z-h&xk-dyXRJ)r(2*zaO;BRVOcx>xHIhNV{yyzMP)g+i&8SK;~VXk75b^>0ldy1j-I zdM1g8yq>1}XeQu(Ps_R8=N91I-w>BU;sfP1VsGCsTZ=xCMnR0PX0XJK?Mpu+an5h6 zQ~9Y*lXa7uo!V-$3t!iZ&b|9ULBRm?H&U#9xbli^`fyhRGVSvd(_*I1Qa^Q4eEcoR zf64~rHFB)N=jIH$d*LdyUt^)1_pHHL=Dj&vE|h}YkgGNIPbw8fvA?pj z+SPkRF>2uueVN+!P z;@tV43^H74<)6Q9vvimn!n|~I}P>}<8yA?kXuXx z7?<4eI9n?hoSX|Z?VQG;g7Icq8Obvk7ELh)k4>ZFTlY=s?SxBQ*zuEcVj8;QIa_%~ zTfp%2yphLb4kq0!62Fn&j%HyBnfxhTaJK3kn@N8Ua=Zwv6|z~t$BU`c zkjm2Dg@33AI<7Cv-L)A+RSpQ%wj2Q~E3@Iu7hQN*v2D3Qp&h@zUi?69^?wwdhd#@n+d+)s-d%gGj7x3YE zzTf-4uJb$&dk~2*qMqABysQUpVFOzk+-wbukY%MpO2nGU=fX~qUA*X|Lh>KwTHThl zZ|Z@Lqll8iGK_(Gh8-qfLa}c1&Bv?1tB|$yS>2C@QJBfHy?%*8=0{&_bve!zAj2ny zz4@mX;gyoAKo-eeUai-C*W$1Or}qW1`H|;8*9a%PJ7Z6 z;8ssb&yI(cu)wO`dHH!g##+CVU~rfrUJRMDjT!YQ<)G7{Mf$l>D$I9jz6`^$>7T_m zzll%Gq?nR#kOK#9GBS7>(8*a5BoQykucmo!p}LgJVRG?zKD{`SrwRU5$Z>TUr8_Qh z@VR&4vR~HAboo9sr{pC6Ri%|1oMEl8SndQ5*KZEzA}eu$j%%3dNiUvuWDU=3Yd~oy z&*u;BFJaBX$=90Bb6A&a5HZ=Ygd<53e>upxS9z);L5rsYXPL%TG~HXE!<28U;Epz2 zlND;9iWC0jF1?qML(}k*Mc#q)AmNPi@1^`lJe^M*`zwGi`#tn^moE9YiQGbVVE;PIOW+lZm}UgWi)tQrbN7p zY)sa!B}2I3XY#50#0%_yRzBqUW|E&`R(vH!jYFecy>p1tjjZGj{POD>2NA|vARoezP7vkw&f31szui*bj z@Fb)6GUm`({wGK?g|F+QI$6!hJ%mQ7NjSq53r<#TI&DpQria(wK8{*~(eU0kvPtCo z5NF^h^tTnl{*KoB{*8uy8G|2pU030I`;ST`o*uAov^m5?AB*WbJw(@x`*7Hk=~BRY zJ&cVh8c*=_qfor;Hd@0~{81^dUS&)}VLIBs{W?<}9=ES_N^cm144uCQB7r^d$7F+< zd3!IE#FhopJRFD9$-GL^WS`hG>#S!*nyw3-6^3-P6$R7_CA%S`5ai@rlMZ zO~{bHZ&yg|G&C@HO5IgoB>d*cc_BB_a}+*um0o`w9K!}S_LcNQ;LEYwI)vBQ)t|i3 zwsQdzIbH0Yt53nf{jS4hCd6a;&a?Sz^%Tx9I~3#|o5szOy^abu$zIk>V)3RUqMzFP?Y9nhpy{EBf0nTWptqra{rQBIE=)rAu2R5_{=WxHVb$Qr%;+Y4XbM;~`nE66wZplK1Fsg+ zo4_vMamef9My%szY(cxPPsdNRn@R^F~5eyLRJ zM5}$8Rj6}G$Wlga0#oiJC_cC}3nMMfk@3Ba__yq)huDV}U<_E8ozCmQd&;w`pV$j< z&%3`b(gK?C$a-X*iaz1coIcR7VM8Al)lRD|IJM!W3%xORvSeNx*03^@(ogmQ`#mfz zd{9nyqrpsY(iu&f=%!84xJ5K&*dLU`psomIY3EnL5{dyupBX`|U z??-6%6e_!E;$5{eC_Ivr^QtEYPG3un>WL*h@7dtXu~`EUGep&xxkR2XqQBcy`eyKE zui1Ewa3M~MN8Y~`K=@o`vu?|hLxkt(a(U~=VT{|H8XieFEX{dK?>vqV054-#_4N-u zsL{RDSmHGTx~cN7Hy6)B=@5I>VZzze-Q6`UyNwD0uf~}JyVoJLNxzz|X%Ng49JeRj zt^rfGVSWSiM)-C}?rpnFH_|&Oo!@kD5g5G;JzSF8&{f^-+0sSgU9hU%&8XFnHl>P^ zdL%FY)AIdPd}arFmmYg_GP?@cPA<)37HFDjW{uKpf3z#ls%BCVHnNc$%|Z*9>nQcL5B4W>4$fM3;&zYAscE-k!0N+`XAKpEw{Z4w-hG~Ns8sY| z+$GovtlpKnEcL>>BiEN;R27&8$Rc3#M^k|B}}y z+*uE6-3kKUEy=*uY$l}mARAvwUVFRAr;nV6Jeiy_$KlzJuQmcRH6ZGB%I+A)6c`+_ z63B8Iz`-zXdLNG}@Vo7=u*|)Np{1Aql#%^p?S01m-Cx^aZ^W4$W72Qb5rSZSIsT?b$xGbXBI^n=#*34RV7s&tV&G1(10li`Av_PA2 z(B+<49?x&av@5Qy_XzJ{VNTPxk?;}S8jIq66-wdDveq9xS1P=Y;m|p{s~OEb^A)qI z$$PEcHnGOD9%jY(qE(BAAkjIq{QRb345Ynr*5wGDoPx$k>&RF;I1FVOOV14<*L|Ta zX|EShy5i8Y-G97bOSV~sjz}85f19Y*f4v<}OcwOSyY!#}UvkRkvL4tSV$>D0o$$^~ zw)L+T%|gRVsk0v~*1=8gytqPF7xGD*g7w^flu8q3I{7;Zck9r!7wdMT*n5F4nrFRW zU}@2EGGqpF^~hN@dm6Oebu@@E~O_XJs88`o(IeHoOL?TlP(nWdK!Q*K5pjPm+AWVJ*4w5(o}_ ztJg*R!h;iput#+|5qUK@&-?T8RwhFKA{ZVM$SBBa8v8kAzYRj*xI+V4$|%`H>l3_z`|kOD-8$TVfmGP z+4HzT&}S`D<0JgloeRtMpF-#Ii6R9xR)ekZ-_Cp0pL=f71V zxp2t<>c*?HP;gq-G}|E>BMuwVe7IH#$_9(+?N3G^S6AVhjQRq6OYNYU%Q){b7r$AYczy<7GVE@hz-0yjd%Y*=XesnF z{;W9RXzRK1ytkae*Lmh2l9;E!rYBJ6_gCUezyDS^<;EcHt~&W4mTj!{1#Q#y-qk*4D)i|r-w+7R4Hv}p|%-9fAR(gCQO6*S#S08tO?+?Fd)cE z`u}N#J18FP(-8NS=4sXQCRkXVd3CPc4FkSrxb&Uj?Cqd6T)UK^ z?jbsfWT>T8Y`Z{m5of4}=4OEE_r(=A^BaTG3T!gkRAAFIVUrRS>qR9ezTv#kHXO-TWmVv!*bGBC*63M zrTF?Dt!#kg73b=B{sD}VslKFXkPXrIgWkK6^I3V4#+&7eVVEzNic#t9hi6CLf4E3; z^S_iOW50wkQ6_6|D(giI5xP{MjtU3%&r9XC!Vbx z{3Pca!}L9Pu@xPB4g?<5n?d`^u$>R=yTSaS;q2zpA#l2Bzj?dJEPnjuOy|&4iW65= zUY(hoL!sSQ?`29>q9R4~4Da|TzGL10k>W&rEYL3 z$+_)8a{+8E5C5)VLOkXEf=W+_FYPA%Y>%U39yn;%f2i8ggZj~PDi+ceAkXX?5PgGq z1DhO=nv%YB{;m&FyA@KQm>NI^_=6a7>KG%dJ>fqVS1xLi{K6Nu8%^B*JGPt85G|1EVA_gxQI)7-KGj74Ubd5*Ng zrY%wXeyR4tj>ust;gwNzsOF>Obs)GsS@$$6vQ%TkOD|>6w3UOoLuCwy&3XDecq>gNMPq z{>AGgz8Nt1q}&lDIS-;eqlMy{)0h`W8~kj15bHc9L_H>ZvGB)ein_ue;Xi3~91<5i=||9=jsY*gc|!fKZ8;CJ-%Ku_~w<^fwjHu5ke zWL~0|`@YLDrfz`Tmn)v`)99W<(Q4}5j}J)i>7fVT?TJZvr*nDFreDp#@Y`79@*v4U zmb})fPOZk4kItF$W=qKTC2{u2Xa`VtezI`o>BAHDkI^J?9$w4~=XYn*P@>FP_+Kp1 z$c<_$rTylK!gJ~z(P`t+AZ_fw_a@0Pbsf+8UXkq&%ldatba4(Me{h(FpaTW>F|k`) z(b7_!HQa)QE%LCdAn@Y6S)h>AU zB=wc0!4xc=t1UhDdk78$yL3DeX+e!^=WcTi6Ytg5Z&h^_3E+2r)9k$v;?sORK!2fh z7JOBoFjah+0_%I^|I3gIladZRtxQSqtvhNdh;If*p6rn}X|2QC)(`GT8}@_o77sRg z^Kz6qbyKA#tQ+q<=_@@?M?-ODi07poAbZK5>4UkilQDb3W8|I>73kRZFw(E5Luh%C zv6UKme!EBOi6zp>satjAcZ?GLMf8J+;r|A(_T1iBoJ#4A zlRHPKB-dOsmd+R|?+I;8p-+)(3*XFWZT_d!gt^hO$f*iSvf(BBRJN>7hwKP`n;cIxKt zQ$fJ38FfLwx)18Bk4w?GCE=bDy${}k6L_RPm|wrVh0HCSt6!1#y|~ggPsWGDpSk4U>imeqty>NYJGUA_Q*AAd>8o5SvBW! zbV94K<0uW;gKzb&9=I-5M|x+xYtq-!P=08mWINe6ub1DC&snI4>kqpEB$H=Aux)($ zcJK@`2i-8SuIonSt%jDjbW>3N8po)vE*c9}8%jlIdyn1l{UM$IL-n#!FljhtgG6Cy5{B+L`MEoC#5A zV;%KYKA1{GtB$)KpEyXUDJRV#`P65TN68U}{{#@t5@Ut2-u9fNW zg%kc{_yxfqf5`c+MgB@54GqQh*PNwI`V74E|4(1}`80U4s@-T2D#25?wzb|XnTGxu z`@!8bO{m8BLzgeO6H;4hMwFkBzC{+#RVy-&<_D zx2D(FLfHgb5ADd_`=AR)*e82lS2n|EQB{}dqa*lh^v?MMAL}t&EMhMENd>&Cmm61P zqov$6n|C-S(SW7ZPnHhnP=VfS(A1K?4^MiQ+XdYt+)>-+{~Sbm!J64$oa0~{K26D$ zR5(@-%?%Ho|NLEmBV2ycA4}-uwvPNfcH_+$ghn4dc2|f3ckT3)rASXq!(MPhao7m_ zVtc_l;`IOgdG!{}ngX)F4|v5Ing{`6CX?N5i+D;``QbGs;>A)>o~1mQ!YDZwyS0cC zR12-z&g%kxviYEB% z$|at_#)w|4l44j*{5$CsRD;So>u?y2BiCY*wW)*4FtGRGbWg5DW6kL z#(EWzz9!T8)@s>G%$nAia)T-;Zhvf8tw($mn*=`ae(Zrm2|D(#Hnanj7ujBR>VgVR zOHIR}B-~!iQQT?u1CFn9^0Ew1piRMNheyZPKuO^eZQ!L=6m~g!Nq?*hdgQA`ICf5f zw+l$Vu=c{UZ#Ff))oX>2;UiRAA;P_F;?%Lh z_Y0ZZbB;7sLpE^qsuliy-h%-{-`RhR)5t0Q*plH}ODiWIGx6`TJ{3Of>(4*&_yg8g zcV0PkEFP^Bc79jkW}q-TxqrGQHw%BN*ghRgX@%HVbaKT_G;(Z7mSX(3I&iJ-Onno} zSAg%2IPPW_VKbvRL*HaI7NyYo{o~HZNp1_SJ*ODux?Ie5M82BBqSciRZ>hrjB?oEu&_5vJf8~eK1pb!}1eOKZYe!}I#pJJD_r(n;x z%gc<5(?G(RU8(=kP&Up#ziakr2E2_}wh5WGp?s^zInQ4m(1@oiE^u}sZ6@`WQfD7F zh^}n*?VE&xZ?lM(7-9@7TLWqq_>XjQ?Zlu!zMQO_7u^Ny6pkZG2}|LVQ*` zBBPy84B{1<^Hsm(i3ekQEi2^%4W;u(Z|JIR4(9N22lRy0!g$#GzpkYJTHW{1=TrDR z2=!GZp6jo~V7Pf`H#uLQf6f|S{xcXJBrsa*8+E{_*hMn%??=@?j(dUlH>{b1XO##q z?#OR7w{NDYD95s7&^=G`R?eN$`<-XtIEUXKAN~RG?O>}ea>*ec>D7iqc2v|4lz8Le zIfxPwL27@yh(9w|ZTNyJ=?#jUk}N50#K9-eY~#s(@bG2ze*L&H^kVC@yIDg=dCFH9 zerESHj`{uh=0v`S;xXWU$(@|nRQfp?q(>lTWHib76X`+qs6UhbT?j{{1*O-<($SA* zH6(In3{CZ<*%O`*LCR3!!O$_SF{&! z)N?L*RcHaWZ5C|blrRMXQFgW$bz0%nvw@yZMm@;F9la~4qy#+=SpIr;u>|8COHxlf zTf)w>aS`3bx5j&mRhUbGa2npMU0IQz$D8@i55hQearOOy!H;>JINGoNfNy;e#`_Aj zTO!-=O}BJKr~NEGH4Exj%$P;Z=F^p&eq`RVOa6u=^Ece+;H=8R$3U5xo!Y1TU;&F4 zPDbUd&teuIm#kB23DgJ%Vo%#N2-yr+8o3}>n^^zrb@cf%F9&|`JW$gTmNy4#%oon8UTrk$&kQtfba%FymG zZzt-z(T17^&cJi7l9S$8ifq1a+M3_{ak6yxztd#Da!1F&@B-n%a@NtSs`yaR;A!A# z>Cgo*b<%p@d1C^5-8Mb*qnU)G(ajOGm6K@y$WiX`#u1pheYSDat!juY5$(_!D#oqc z9-A_qX0gWotcD8lqFjEITXe*58urB0O||{MUtD?l^naHJQHkeOdDGcZlx*Btl4!RC zXJmOZ1K+iPl<$(!nJtyrarNZy71dVE9d%K-GD0g?RAg;z`y>e4#7j-IsBJL3<0OZy zTLU_N^~lIHTtTG+xty+&`H>E(^q1$7DEEJ(PvzS))%V_m+?Eoa9K`|r+cYOq<2{NIf?K|4^$^d3 zf{`d4IaeGpF12Y5$>#W!iR|y^X&q%ABRpzaVwCTh!m79Q-1;Pcbp5U-OtPgz zd}GpctwO@{G8@tFu`PqJ{KEC`w+To1#1%*Df1^+l`E;SZw+~X^u&)R(^HRSD|+V*lW7N0ie?e^K&1{}K?EMsctKxXrup@$RT1T?+Nv*IW;K6&LonOy=VPXZW}E`y{V(o%X2x?M^gO zpDUBi9)grl<&Wx$XMk@UkLcACuY+;n{*37=T$S&+y~lI_jT_vup1vo0yDICu-?yxS zw#J7yl|HRdyBPak=>d5g6sTX6KiiF;zCHhWS85vX8?~>MOZ6d-z7&NiH32R?3chq- zEC=WFL_M3y=WoDIO1+oA0MBY3Pb}7H!yu)_T#-H9s1ou?nLlz2J#r^x)hmbK^5s{@ zo?Ip8%%l6N?1(S%M`BDg7vTjLojKrPY+et-_7U$sT%H3z(cw~uu1fTNd)PDJN&{9m zT@zfmN_f*Jx8Czu83fiO3WZn;Aruz4Q(U?BK63&~h3~S(Y zSj+sF`zX-Gr?p81rJx$^NyWo-zahu;>P;4=6o?V4`KlT57xs=8Sc!6Gq0p*+ew-2M znPoof>o9r`N3G<m6j>}XlLEuM7=l< zKxJpWUr`Tll7gaULgs=CkVuRx0RUU|02Qux02yygROTDdCy4#RA$++b<+=rD2mX6ub~wwX9AsAA)!(Xh<2g$!TBd0ONVM0E&){9h z{Y?G)$~F-G(AuGsKH~%EC42PVy&vT7GJUO?!TAT~=}N2S?3o7XAS2_`)5H(dddx`m zYAl4-^M8`(+#t8YyY4L4pATo2ox3g`?L^ks$E9|)ko|F>o#X9$y=Zo6x3E=E9ej9N z|10>?B5KA>9JuC9^6pok@$6Aq#gm$8Z5Ap$a3y?ki~Vvp9^_;XycjZuwujnwz6_p$ zO`$^jk7RU#NEx5*sMRc{(~Q4&II;{u4_uCz&5gkuZT&o>li9fEDVzJTBgJIiRefRu zKjE)y?v&f`eE<@w?U_WS$v)2fU@@P25!ig2HP8#I!cAP(hhuD$VOVmbw(*J?jy2|f z4@)6l7#?}IO`m%p_VfoBGwlTR>qnmGIM;&l#n!7X;a%9Vto6AevH@<`Zgp&Z9fy3G zcYh1IlH4lK?CN?;7sjbhZ+0O)>$y+)#Z%;dcD|4?{|Max2rLl3$jB)6Z!|LwFf0Pi z6t$~I6vx11(~()`G2+?cIooYjHv)HS_1P3>r{VakjD4n$n(&9$wE4{QR`ffvv&k-Z z9*3T$KJF&@HQJ@`Gv!JZaQ*Xoyb^m4NUZoYY#{vJu({$so}3x558*mJ&9s1ToVi8h zdAreexBL9#>;4$6B33izzm7lk1T9ry7Qc=~TYkBhidN$*zC!C6So;2Sg?1jDg5s)4JD%{ z)5=X_9EQ&<-WT5Uw4HEWo#LxPI^YlO!(6$#b$Gm~*s|zJEixaBvOn+L zg+AqhcV9HML66+$#_qXp+;`C{s3S2Mx4r%#uXu0(dD~3=@x>UveOv0LYc+_ahx;qb z50g1Sh4-lA)dBDq(o9Urr$T2thtV4G|Cx6`yzR1)iuZRcof;M;-kIy|0~=1)V`2PD zom0MRc*A@oGKBb?!@0B!d2S8kY;?-w59tk{C%DMn`=SeL4%IB(b(sPBrs3J{D^%F5 z*xMHO-z>NcSSYMGlfH;6-K(aG7FfOdmVPv48Ls#7js=R9BUePvCWmXIASo$5_Ku#+ zNxc?S$M#P_!`-pL$t}PwKdF}3Q!OhJiFS>i7_Axz0WMS=xebX#B8*wp2 zFm{2@J&WkU?Nq$#)^g8s;xC4E-bqs;ep|-fTT3dQ|z!F}(g+WGrZoZ8gCn49VFcc5^gd_0n}}B0FIuzNyMRZEy)U$5 z6he9Vm+T@ZQB?8ND^ms1kI)(&R1j@KO>yrzRqO<{+ie9D!n2wAvX%EgMp_CtqrlFx z!1_1MXZIVGU~2Mt z`mT09+)+F0A7fIAgX+tc_P6qZM)CPt%b`5v=#stry|Du1j&3ff3Fv{eoFZ;_336o) z5uR78sKUzJr_T?1kX*mPwiEx)864y|aq{JtMfl}3bdIjDA5~7?_vD>e!o(F$t9QQ% zcks2}@V=!0jHTS+rBxjR9j?%G?crTeP_xVN+$^~-a`65 z_tM{9EPY#_dxug1b5pPMO82$``4&ewK3xN=_@(Epm%4y*cy9AT-XxkP^H7W9W>M+S zqXWD2x?t4nZe9FPDn8pf9I35N#U%^BQ?B9d7zF7IJ3koW)|1|rGvD&?R3@Q`?bp8fUc!UEVqPTi zm0m83{eZlX^9T%M)G>+1QJl{96SsUo!MxHx+*K*$|9|{7U0Fa9{@9oN?9rtj?4!|@ zl;|lXerv;D^i{2ROi)I1yZ;PY+>V?O+Pn&rU3T(&vnQY}C@24E$}hZ1gsodRm(VT7 z=U*Dn5^_@*&8q_g@Qz+zOzKb?Mt2xX?V@}HhEtjWmpz8yn~_4pFTr&(w=PUbWFUMx z79j&C=6D>u@;Wr4xD?GKUSv^nY2`kL+&}$=^qAwvQE=a29~AtTGeY@Nh2|r+T^@vk zuXgBD?@szTs49J})J*QVrrQjb*qI7YW9w`6zjU;6-bd3WSaK%u+Tyt^Hkp2W*tF@^ z;{8_m@k?5mYv&ZQW^yY`#FXIJ$I<62<)j}VlfU-23!XLxF0T%+tI7LADzC zw#)39mRx|>vp%Ia$UG#v4<>IyZGTk3S;o^BU9^X*uy zkPE~UM+a;T@`)SOL6=c~bqx)YRxCQVFi>8!oGdtv>vmYeUy5ZYh#YxCvr!f3jO zrDmD+P$U$~GfMg)QeLb68Z!AXY%|!L)H)8ghF6{*y*W+1xMl|WZyT}6`__p{rW(}j z&Tb0-um~G1Q-n{Pn?c8|s$JcxJvbD#@9pqfE;L*c{=|K_1m$!qek=XW($Wj zVwSa!yjsv4ZneD{q)PI&zV~7{3pXW9VP57PeXyc~xU+ohVO z{bOP8$6dH4+RLb~j-%cf$v#V?vLlW4GFod~ZA9f3UgTX7bPWWHK4dlaiX!RNm+`Bv3+ z&^jJbFcdfskA8QG?+F`5Yq>V5cAqXZ+*+Ct-s}R*+EV)7UbA@oKJSob$Pzq0wvu?x zb_D-EnwDR<*9!ew+aBE_o{$DH@marJgfH=eZS}1|gJO7~#+&Ayjs7iJ(|XRmjQOeZqU3^Ih1-*cr%=g|Idy%=~aa$Rh2gWRHqxN;|d zGaPuw^rv|1G_uV3+I_#-2gSeN{VXCrgQrjJ`XY0OAgo5a;Em@byxg6baiFakR$UZs zp878lDYGwj-q}p<&Drrfb)S0hyNmXHrmZ~~r)a1(D3l661;c5Nc?^QGvC8|;-EVP_ zK2{)8Tw8TNw0yL0Q2Lf>$9 zQH0S8+F;+!TOR{tx^nxJe1gL(~Fr!s3u%!pez6#%s+fU}G^Y^X4ejI>@TpL@0O%|YSw;-EF zXaiKGemj4~ejOybm6>;`3?oleqK-Z3pJzqOz7!2#f$uM`KHzPihbP=a3wMfg0l#>% zKJ=iaxb%2suACbJQTFjs3)6g{PA-i`aEMeQmWhz?W`|^77t8=(MHzYcl2lQsDt{a zsw=smxW%k3P-h&|Snj)XKkkG_VWs-n)zjE`eFw`~!aaFYkT03BF#_wAdlEK#w?W^I zh{?eb-ldK~^L^;uJ%>=k#;ZWpj6bJQDFvn7OY zU3-sB>l5LHZGOHbJtDmoK53mib>@6G21;s{nkIJwN`DHw=Ticwj0aTAPEx_-)VVkK zc@qAxTpie?OwOx~oF!ef!>A7m;otv_U=3Z*36@s~-9H~XRqm&u_!z6cXbyXfFPvL0 z7#>?emz$sSt0E?G2Rq9q(LH@|Jp0G_JgzFBV;@nT)SQ8J?z9;HOT8$xV|_Q(#R_nS z+T|(GhiL*LV#2ke^}76h^sffk1b|oGQ3}N@eHu&$W2cLClYi^qkGy zPrpdNO8mjfWA#j;@FN^gY6c1^^mP!IXJhsjn~jolX=}=cp=zly>CiS6vC2sP`5qlpU!^ZGS@Sj!?b#}AcxXP z;6Hatg@hkL#miJAEM~bni+V*xS<6RNPh<3F$a8?6X#ED#H`*tYHFKss? z^K8>TpK<-hUWjAgdvY<2@KlV_)^1*D!U~7g_HB#%6+br#STU2B(g6(Z!e-uMcIn*e?$06F0@Z#Kcieb z*T)?@1p6TD3nkoKbqy+yYfGrtkz~w~oQxX_R(R*SFyy zzPDp<&hnJ}16qx=TX${_qLePpHJKp_?r4^pZso{Di`^DO=FAJQo~@a=L!=5avIN)? zJ`vB`gEDP*k4X4kpGdpy^a#ccl!&T`QQ?MCL__wCNlc-XmQ(nr@a&egf5U{+=yoS( zqZf_<_nE3X;pTZfdXq=$OVteOhp#%hbVPx$xR-I;d^f&)ZB^+oPD_bd@uYXn=|Zf{ zyRmw)6Yso|Fxb*L1WIfk-kVfu-4q9do6A?pmhJzTn#&9Gb+Te;tE|4m5-A(B^+Kk(tOZb>nya zXe?Yf*P!`ub3Z(AwViTvp`yT<*Pj%BE&{iN#{R^z3=Ev7TcZ%(dD)%4#`m%a_k3^P z_E(BIKs{Ea5;0r_#}sU6JHPaUCO`da17WgPl+@!qu2qdco9nG~1+r0$=K0ZtnhrR^ z@~PvmVEy{8L`h==y+a*@?!KOdx$|OLBW7)AbS>m%`VHcpu(XxU z;9drW=gERcj|^e&clIXd%~Tk2VZ}>!}f^7L5 z&3qRvg(C4wM&;}{gdNfyOS#bl2K|5TvUCv6(S%jvC$TwzOS}Dh%S$lislJwXbuY>P zrhbWUTS84Hv3@9`;$}DTg;BRj;Mo$wsY~Wb8MmG({rcJtZ@?yO)qfmB9>>O6{vN@F zN!mVYdqA@3fOzit1rBOrWtQ zn)HEb`K5EtPNG`MI-4}{gGJGZYI2(so=m0eupZ9{IQ^lsu_0U;lUGvlr++TMa`u|h zOPjA~bT0hDSN}egYPot=C9@bkqi?yCV>1+`KhfYI@3|M3yi1e6b|dT7b*DGl!{B|? zLy(VV3N8e0mpEDL2UgK0PfP>z(8hscSm+T4U*wn#E+~;+sVd*i2SaUmG;4c7m&+0` z{^6S~+?xc!y$1zvyzPg?y4(I>H4JrziCaC|%W(1q?SZ$<s1&pDW|oqWQ~y?{Wj2Kj+V4XcY(e_NPl> zR4rQHl{&SpY!F6wy=r{8)CXTrNi!#?j^gCrj?}Z$HOOi@a_PW@0W7Y5I;?zV8VsHy z?X9dTjA4~&T6!@Fp`KIM%6mId{H(E~+J6Jkel%D(GPD@ePBB{N$2ud`BRA1p;4gC7 zUD1;JRRtfcZ*m4dTt*togT=3;hb(+Am^QDr1wv1IdYwB&IIi2LoB5Rjp_s!?A zu33)q6I-X3tjdtlzn(Yj6b2<#Vg}efVq%oht^@l~zB&jH3 z>D<8Zy%NfnSOq1>=lizTrmWD1&A?arRVAG4qx!^4A3tP9l;;Sx{iv9AsjG(TXGBDV-#5Uynq({9;z=-kbL%lxA{FDF{5O0ymkReUvnq#6 z*CCo-z9z~+e0m%IT^95Ig#$PDObpmeg9tTjhfHe`B>Q~(eJ;8W?R4X%z8)9>J;oT}(Tf4+NEj=FFhHXf994uW67_;+VX`MN5%Q(P{K1dj?(p z^jO)-YE)&rYQ6bSC4M&=5xaI|5?ri(?Ifg!p-4jeS%76daU7Y(xjPaMHCGOQ$D177 z|BtJoRksyq1h^BavAytUaCb*>?-DM*Q5hB>y|qmJ_uh7!hj6pPT9xKRC&c7e*Q@rE zy!K)`lh_TyQM&(FJ-}xTMh`SuzGzrP-zdG!PaJ3{-+t0=*HBo6Gy^lm9}maCc&dE= z$GR!JTi&GarPPiyVjsRO#|*;Vn%>Jsk(Kb`p;EiDC_<2Oz(J$0B=4%xA3y6dh>9Ef zc6de)K=GcspS`Q3mmtESE`4$uHobaes2CRmoe>*qOqknIuU64U_Q5z#^28WQ=xmZ> z4P#!X^=XGOPL`punh|7nY^aV6?1q&FG3p;m4c;|x%ItJ)#~voJOOhAcu&gmfe}Fj$ zerfMMx8;`~G>oZV8F8(G(*p5t4pnDh+s{)X8`Y=rR7&!sW&IRnGPedFj2eV6X~U9K z^F|!b3L6}KK7#N4&OSIr`riG-&@kX1?0jd7sQd5=H!{hea9WS)4q^ty52ClJG&=$g8c{|XPdi3V~xHEkXx> zJ1#~473}+U<`n;zW&AX>aI`y)@Y^l~WNvdM{fCd5NqnyJxbAP(kZ3=I{uT?0f$aV8 zAxO|w>e2*WS3kjjfIJtM-EPxN(8q#!h`6i|`y^7N-tTXGHjDYc?r8ULl>iSl&CP(! zKX?x8+sWY6h4O7yO;NSWAR^4*V$?_{H>Kyj&vI7{zPMTH_x9Ha{uzA#cO~>Md>;K4 zzB9fA&dk_WQ-ss8$@A+CH$fZVeC=wORKEx_>?ZLo9V1Z3OcBoFS;4`EpB3I;PqGze8BT$tFKoe)N!(0{`YDIn5n-9d=pwQMCwn5wmXB| zC=Pz8Aib#MBD(jS`_^%$>jwL2lQtZZVyf2mrQ(H!hy>h|1@BA}HlMuQfm%Di_M86c zgx!}z=*2!1q728&+K$0SP@=rM(?qzMGpg>l*Pc=d~5RYK+*=!B?U-0X~kt(@z8@VNHO3 z1q%DYo&WjsFx^RX_4SbQe*Fu%LpuZmL)X!0o@2)$kzz>7^9~d4g4B{;F)@-RGS=p zzx^TG&ki~{>7@Xl`2GpvS==1kL-H_8%}a?zk8_aoJWEwrbPK9yo{i~EorU76C(n00 z9m7hkz^2`OmQtHS1)9#MJXZcx+!9fMp_?aRuyi>s)`bE;&j0zyBGV0q9+PD* z7RxY|zcy#2*#p0aWJ}HuCgaQ9r`Y&?>fmxixJh#S5I(Eo5PPXt11x)M*1k9`K#OJd zuJrY3U^^dtF}-jA_~r-h9O~%D>d?=ebHOxnS8nAnhkv7!({+0yYC^jLJ9?OEGiw$> zc84EheE9}BFWz?(S1D8oP&;_%lUx(tPjgX-w~PlW^X1_GE)GCQzi;txzGi6u%>Q!z zN;hzN)k{9SIEY3I?RV_67LaE2^UJitBIxbu)CdDwIZL@*zMZ!JBkw%JxsKnyZx)gf zl~hJU5>Y6G^A{?mtWqf}q-A79rEH~Ak&u!tN>Z5_r#-Xx-h1z@`}05UXV-)4xUS=V zc>j*$dpLOH_Z^?_=RD8%`~Av?*8MgjF8gM{;iF8`F0Vcm{NOw5Xf%MbdG3GN*M?!~ z)t~#u{0;CaE75h4t{DA=?cV%ZY6blS!R;IORY9run-SY5B_Q;|&{sOQ7x_dUEbu)b zeB4l~OZ>_kv(DKzt9`vWhuRlDz7Rasf`2o=b6$uhoWwF3MyU^fanCJ*+i6GUL3rgu zM5X2!@$rl*1yZK)md_VYwPzDxn4@i2Y150B`+nV6m&$`v4KR0xdkRg2C$me%sIvyu z&aOOybp{4S87es(n8w7@+h%vy^kKL6p7c@1Y3Q;LKhLd0xNNs=idSmpN&cl< zM|DaeWNxwL92jXw&WfE(F*k? zpSgW^Sb@xYebhYX+hN|nuyksLaL8sIoHT74(04@dz)lJ^g^M>0smYw^<7}N}5~t%CqUN|_%!v*Fa$Ueh-=>(D)Myx~9znHw5!X|RpYg~I#vKU}|0 zp?b&h&@$CZ6z-~_;bW%D8jb!MqbV{2;c+ibf2j09$n$R%!cBw7_Nx6X4c8FX`1*Cn znup_)d(u%Z%KgBT%}^@I*n_hCOdcg0x^eE$Mhl}2fAKS$x;?kE6Fl2XSGYN-7Wo5) zmu75N;d7GF+r_gZD0$@wRiPkVcbjK7r-I{vwRk0Nm z^cosRt%z?#TT4`~a1nj7#f-i`m;ovd8HPKgZtx9aQ49NBhiqG?EKd@@(A2Se!A)-$ zfzyWJY<$f$(&|b2)9sS@-lAvHK^Wz^puxgCn zmNt&3HG8G6(RZTik-5Dr7fAlEg`2_%OAOqQ9;OzkNrBMwYZr%EHTdpLS}fw6p`Q_qyDce>)1&Q*SZ)K@CPB>-mLFx)G>!4OL!`wZy60hz|Ze}NWM>4Kr-;=K`LX7gR zPp=feU|EmL%*W^o_{d9@7Pub2SxQ>Mb}S&kNKBJ zw|$qf|5l_oJIQ~z|D#{2lTxI&+6g$KTlDbJ+1g} zS@P8dk$N;g(|1e;O2G4qvZTZAd2pJEzw)%e7phw#!lQliA(npNg1=S)m)TCZ}?JJ<0n|=3(Wg z%QTcX(r{foD;f4^9AuRb_r*GGeOVzR(&yYS8uui25SOy!U(WR};O!q4R<1b|rgI_I;rRH5(<==g9%zu5xkFNs-rIt0e?OO(q`g(D;f(|^Ke)ty?&kX8_ z$Vf2@j$*K8jTfcOhmRm_F%5MMpt?ncd(B~aA#iDz${08`&blLjWEc*G(4 z{#Z{Jh_;J}9D6Z|b=H4htbHc$ORGa_8P935*w=#ob~V<5{@uNQ4s}mJ>eGkuAHI)Z zWNL|=&xSU5!VlM@Y|Ef{e8F71QJzmRM_K(|4z6nJ>_ z59by{;T_52+2KU*?VR>2C@Q)c!Y^Ui8*(3bh;!T%eO-*!C*%q|Ooo6hG`>qhVF9HW z1TM9>bm5T2?`vBLH={<^Ys-e^a(rKT#>!)65_7Ba(oc$yLePO<4FT|HF56Zl+^JK?j)GCUZ*OwmXp_ob_!Y4GxKpev{57`hrWuButK;`G}T zCAMEAugpZgd9{!5)>y^3u zw`1>Pu|)V3Qk?sS%<)B^OUN@_Uxyt7vi`Ccvan-A($)~d8?@BQm*T%&LwFVPwQ^6V zVdot;hCbq3)@$`p=MQQ?7GDDc*A;5Y#259iOnYbXwfV>FcrKFXm}%Z3b7}_F#b?47 zTgds9`0g=NNkj39PsM|z4&rQZX=hNZ!qw7^Dl#92fcZ@4vB{5Ns2lWe%gVhjRCrx} zIeTIh1K28qgUu%Kq0FA7j6%XO_Fj@pyWa)LwF)+8-}m6_IErpcP&+!?1sHxmL~_dR zr-a`l@23zN-5cf_z2LWSDsqwZLmKq_wjV6&L++8JyN)wW(Ca;~z#!Lvd(}*hd2<(l zzQUp_)TaTdZoHP>ZZwbVryjekGB3cYQnt^o$ID1%&b#H%-f4iN1Xwvh48A*DY2&M= z(59-(lp}l|irQThT33Ift^qaO;r@EmJbiy{U(y7G4ovBf={4anld5L2;1q^Dd{LEC zI|OmBqHD6lXem1ybyZZuXJG5t#)uW`THrpKFR4L8T8Cq-QcYcJXqUiZ%|$&98@Rsw ztI=%5^BdC3t10U^&GuWnNooib^F<0Jou;w#wBY=Y!Fe1UC^_Rsd^h@YIlCUnm4k`> zukXRGQ+PI~)ZF;dFmj%&`W9l`3}TXw`xxqmuq$T2UN7}9$alSO$We#W1fokE z!;9%V9gt^immXk4`sM`|FIo0y|2foEXz8e^7#PTJ|K+ovN`&gdNySt8)<#x0Y>aN}TiKe6h#xkyFurLjVs!uL zJyGKuHaA3%9yzUWkm}n1^z$g@aHDPznd?}T|L9g;0Rta~>kZ`pG@fwzP#eC2_Phb3 zVl_Pw)mfdqygvaee@F*x3K)e+kBPX`C+qRf$nJ|HXS>kk>i$=4Co18mmSpK~vLB9C z6I1JcH3!%KFok?i8^c=%2w0Bza<2t*iTODUllN}bq3xfEpPONuzH-G1hPqr~>M&cx zsjENrrXRP%-AbiRZ}t1I|59m47k@2eZ`~vHEGP-QZ);c@PqhF~P5)By!zr+*37B6! z*$wKgx_c?+J$z?pH*9*hj`*m<&37bCcCFzT0d` zU)Nd!o4>j&oTRQm8Lm@lyN9R1?bpyn4F^VwtluqKYKLs3G5rwZR9y}91%6=2)q}py zgkYpN3`1kNIX!RJL8Nn|CQ~$7FNC8h-hYN6n@i=L)y_Wj65e)CWoQg$Y$JKqYZp<# zTw?f(z!2JwStJ_`0Xzuh4n+L_Unp;r2ccK&A6pYbV1V5HijpwF#T(If?r=2 zI6d^UI4M1kPbcXYW~J7V^@=#Nz{&t#xxa6FWUw_3yuN-z?tK?#aQ{}XD__KC8YkMu z4EiBVG{&hsVT9yX@x1sMT7-XFc*jPW7eOypP_S=H6P#L$8VzfzgVu?maK7y{lxKCq z548U-!*eFt`A5_Xkl=WWBZc^6{O@g#*cR4^Q9T+vZjl_EMot|WD&t0UoH*Z^sXhig z+ZL)e#e1WD&9@p-*rA$ng4TWN7HB>&YN$`vU6--wQ-(p~XmVCSfT?621+`gdSBXE_ zaMo&UI%$mPX{sTrL=OIz&}`UeAkWmcar zmf&d)1)y$dfyD%Y)>4ZDwzqdDn#H+m4+{q+N%7R(*$kd&*$>W`LcVc_s`q zSH=YD51^LQC5~OWbHI=V{OY22AfHx5)Y-QO1n-I{-XR>_jb-|`Dc)i5>GnxhM#6XR z?=|{WM0nRSJ>8pv&Nsu%W41?P+H;V9>VvL=a2A-&+UmE&juQWmw9J#-NjS79c=otN z4MyxEm{!8I33$`XP;r&aCqcY^IHm;$PBXDzr0T-cZ9cni&9B1nzat%YI6J^E{%D%Y zauZ}2J>PZYb~9e$k2qS=H-{7}_8+U_)Ra#BhB5}K4(QUU^SR1Pbl`G&4xB{KdR^?_ zjAAX}^zvDzXq60MZp=5sD(@LomKwsaDXj#>T{LTe>YxI=yH}dO@^jd9h!abIs20v5vqEbWgr)Rt~cvOt<_K7^Qk9c_GOxT40bltbx z<;?3LjJtfrHZ`UmDlRu&c)7bBOqjHJC+LRpak2fnR>?GMQ~r~8?R5(n>M_4gc~=i> zQCEBE@BW0dS1o=v4XK=lN;J zA-K3jefdpPKaQxxhrT2}>$5#Sxl3O3L9MLX^FrY+7*j3%`H!^#%a!XTyiAvY=4Xvc z!Kq&K7VliyKD_|D`6ht<$rw^yA3J&(LLm8oFtcq5;rJMC?M`;9g!vC5l>7`j%HXbV zTgvS|flEN-Tjj%%Sf$KpBvViWBkb1u6TbK0(MI*`=c_bXL5HjB)@I^C<@x!l#+hc| zEb!S=(AWbj*TibikeqTC?b{uG{gZfc%A``drVb|rghO)si(vEkdkzZG^YC%)`qFa4df$yg_@sIhRkg^-z7$WTe}VZeP3l0)fmHqvINQw9paN;FTcv^JcAAKDcVy% zNFEMv@ACIARj6;xE8kI_4exggF75fU1a9+oO?iTJlrz0AZd|ddg4y=8_Ph?FtM=A< z`{;WZs2V;r7FnRDG}kLg|2Z@bIkzQfwXp}ottSP9<7*MT#($Yr4dNrC&3hBH7vPf1 z2){es0PZqj3Nv&izNq#0L8GU8(3yYv$(i6;c<>`A#Bt*Q(7Tm<_(|sPK88wTpT+8d zRZ4y9uOF{4P@yPMfR%8H!Wqi=i0((phVQHa+dNii7$04#S;j2Ir_%R3sIxd?%H$16 zZjPLxQ=8)Ya=eCw%`P-%u(kIP&mtp#B2=5riG!*!gb^4`cu;TP6 zlnB&1h;3ZLiqt1Il(-(ZU;LZWgPB5*w$Tob{eMoPJTBIA>6=XPtJe0NY3zT{jRG{eYo@L zY4$fu)!@`N_q;T)3~Zi9_}I~s_r2cc!@(E&aFXjpOe|L`$MsjZ9Q!zdS@CvPfn!O5niToW_Q~zo@Q8SZeuY%69#u}GWHYr8B#2-Qp?9J zz_8vXH_oex&|f3aA4ofcMP(vOHJ8?aviGcQ4HV-@_0bq6^HTWn=_Z4X%@o|-+I!SM zyb1Nj&-%4bkD#dEbJnIWb-?cYP5EZYH(=Yl%Boyg4gM6qORaxU$^ zO1>AB7;>72eal0VS1tWzhq!GnvYywyl`~A989tF^0QPg^OKdFB-jC`v*D^Tog=xH<3 zC+S^3$-2(B4)GmZI^T0HquJ)^ubgVc&nY(;1-4_bs2q}Ye6$!pGMqbl;#?_4tmnN- z<(h(!}+|0OP7LW~_K1eof8R~{xQdG~LhKym# zKsnoF$`qC?>@aF)B7MNXUEe0s`=G+HJ0{a=00urOI#;L^;bfY>=jNp`lqvas=yN&A z)87@ow1vF}qfRpF4U_$N_bGux9`Phc{hXiCkDlLfh^feh*RBmb#2$vf@1dfU$BMVN zdgj8;`8zybo%wL@#NC-oiZgh9BAJ)btqHke>u(({%Rpfrjh85obO zTy)o2N2+)+d*PeCu-CcwlQi>RxS3I4cq4`6NPLu5wbWk$@qa3Fu7kOF@{-Lxe?e-> z%z&;zao+%5)PB(ZN2e99dQ5ZdJ~n_$AB(B19a2$8IndCE@Mp)p+pU9zYfhz1vq_SdQyVMVmtMVz8$)51 zk4q;qR&m=!`55(I?a*>@QR+P5QAk|oGi#h(Lh7pQ&dBaLaBB@vd7RS=cdmxyiHUy0 z0Nd=&suIH0kuy27qkpCe6A0+9oEOxJ zY{`y3+Ei88)1S~gYt;p5zxlkjcL%{wzMqX^B~v)DGv#60wqdC3|EB-RhUAhM>`kjS zO@sAhHK9D#2Ba2sI&e^C5sX(-Z-!E5!Rh+91^44-@rLpEix?S0OwD#`6(stfdn3EJ zQj`%tr*)UUeliU{9+E*k;Z;C?nT zj@@jF0XGJTzDjcI!j;S-=u#d~NKYqRx!Dc6mKPc!fx$EU4t)>4=+gds;6?}1yl}p0 zxjcib#UARqZ&rYQD(=Lyt|iD6IjY{A(1&k1M`$;cczWx0>9 z7JU;_l2~(^f!Aa1{(+@3U`^^w0_h2eP;1Ez=pmd3j>gx)zRM67sIi*d#~U0sU9;w F~`mDKPT6?Ubq?mgOwJ`{KQo~1c3qYPc$_qr0ioGZV0 zz3hWKbk1{|WykUTjORY9r+M%*!erks(nmaY^zOn;-~e{HkVy3{}W<}G z6yCY{cz*Z&X#D$0u~@D{_4^rvxSK=FD{9dvI9hiOZB zm!6NnsiD))PM*#Kf3sgQZkxJs?FuE0`fMATwAtOyxYdoHs*b+(Kh}+j{|5GksVBhK zi)>tWUCZEYG4{~;Z4JB{DgW8XJ_CVuW~j+BLh_zC&a5!}gOIoLW09|O(P*u&=aTdY zEF5f58f%*cJ!6x5_ec&&G_yg+IR~Cld#rXltCo{WiUW*W-=w{z>=EsJm``$hqJ2I{iw5k z)AO}G*XqW2nqGz21)`I`CZN4d@&Oo|82|Y!k%*ZMyMjal`eCj>+rUDApk}GNo>XKg{8s7q-VuP7iK05ZL}$Z5~ZSe;({&XvJC;UvAZiQ1bi@ z*z*|EWNnFkX8KO94mGSe9UMC5;j*2_z{4+#7(X)_Ir#Yt_+~V4{Yq{|>8(*as+kwD ziaN&P+Zp03PbzFZ|LZq?n*RA)Xrcj%SamjV?Hz)WqLI2iH~-;=zO@H53sX>i55CG0 zJ=d8ZZ>wBGI-rF4smNmb2&D2(9doHViPAo%9Us!_apkOf&*qoE@PxEuaFSjqXa`v< zs6|s#_~u8VtBbloCQfO?0Amfh>+nzOtd^sWX=WYsY6V>BxWSOCF$tf1B?{>`)PeYE zDa|Ui=fLWBV^bl?;j#@ESjn4ChRwbb?_K$`fzcr4>$Qs+u#g`7GU#a^Hg+Bl?{ApK zZDwcCXJ&8>qm(aLe&-91gVk_MW{LZ#|5$${~JZm4EH#Q?4`=x$CNq<7`dn z|9tET4Z|=n#MeH$;GY0yzG3IL-Wnhk2-6rj{b#s17 zD{urQWPiO(MbYJDDc2@_yw7|W`PROzVy54@wg*FmC#dCI%@Wm%%~j!Nt*59dOQfwR zB)x(Zj@J?FpNKvwdY0z8Wi1>G`mQ+jXd1b)d~Vj-5Z*PD`2{8m!nL3qbr=^Nf()T| zab}ZU@FL7;_j9*doQ%tijY^xugLCtf^N+jX@uhOzJub7DG4e@~-zyy>?;U~+~DX=LEmHcWpg{FICw}*2K;NC+X>~h+@ zKvgx6eE!BXrn@OOoFKdpHq$*pc)1O~tCgL%=cJ+>i}+n$QTY$m)GXUbgB?#bHdtGH z%7c(S4#8(?TJh4DCKbk(Vn%;ofO#?D0IM;@nOKne(R^S1(dJ1!BL62Z;*aXjS2*2V@$I6i6sXwsO zI9kc@MiCsmyITA;ISa%!y_<8ArolSm^^GJ^DvE!jXQKAIQG8Mh;_t^>VZ*JPC-kM3 z(Xz^(iO<*pOP<^j|6IC^QSG2zQzcgjF9~F z-ee9OA5$#Y<%y1P^iZl5nY-1cQ43X&by?c)<^Fk9!W)&Fb)UO23kSIG{k>N`hWruT zKX`Ro05eOT&kK|DecM`c&6xPWb*+#0ml3|^xNX~RxkA`*VuvABGU4tpUHz6ci&W32b#{9P$Q;EOraK_eR39`Se z*u!V+xdJiQ2LkuFhGG38TgK?7Rjdx7zq%)J14U6R-6CIS0oQb*vKO7w@O1O-i@Oa1 zAjkRulPMQdmdXLUREE-exYeIrTJE}tV;32hWUtR4N6eW7-K#CYuG9BpbNUj#M_(!H z=uuSrDY|%S-wY0$b4XQFDnW#5QsqPD8gM;PvXp!N3pyx~Q*<{c;m^dATy1m0!#m;K z`eo}sD70#ejPfD=R1@d-g|8d1xWFYgIJgP>d`cRV_RrvB-SQ2`=VS2EczobD%Xpx& zmwo0%^l9a)=Oqk&6(M~6(IDE<2KQf_t1iDZh#y0=13Kpx;d*I+u!HOZSe!DGEe`Aj zy56#}(AGj|oh{NzNcajB62;vXmqJl&=9k9xXC20@^|LkEH)I9AuJ`** z`m$N~{w%Qb5dP4$JHdCWr=cu^-+AT+$$7c(g_X867m`e#3$ko%$4z$o(npl$v5e=f zU8vFsaL|+Ko-5c_ffJzdWj*cvBvn@17Y*mV%l{xw zQ@qic=vjGI=akW~1{gAOqJB?R;AYl?7x&CfV{jE&xAKOe;E&~{3+7qqUVnDLh&*T9 zuclsFiGG8$r}x_{*(#wc=f&?ir8zjkGnAjf+zKWJ4-Tv|CV}oXN=B980vzpVv$EaP ziU!~LZ~Ht+!PX;8>cc(#7|T#xXgIfo5Ql2qMM`De+86x%+eU(EVb zdEpm`X$#85tjq%+wQbgRqK`G3U`_isIgV?WvrEtF=ivrjzMY@8rr^v!zhm>~i4WtY zu5L!iI3$KRaA(QB1b!jsVJeR^T-`X zcj?#n;D$;gtk5FN-G2#3?%pYFG@OEbOMfSN=tcj@)8{wSbm2SY zW63NIRlw5L94+!E1Xy-0cKxN9MZR;ZOZy{9-l}fYdVR_eTD<)6XAks)Y~IqDPo71f zeVo-}a-bIbR!;Cq^L7A(hp*!Uo?epM$a|#Jv;fqbp6w2`%Y^fPP z^tBzR+WSGvz_Sa)MsNDWXb(W?wWAYJZ#vM~TS>7+a2AbER3F;zt8o;{%J!SlF?JaVPO@ z%g%J>ND)2I`KS6~R^)wtz~aM(gNrS2lW-?a+$Z(vhuO7bp`B>H-_eaPvmcJVGff{Q zIjp%2M%k5z*GP_QAf32ZKYqYUffT|s%XB{QBkvO7axiZ{W4Uh}qIDjZ9GM*e#Syi; z>_WxB(&=57`70YkWm>Z)H&3GMnUB3Ew>3ahWJC4g;4yGp)f}64AH`-3{x}czarm+N z+QY284tK>it5chjK2^wri7fgOm_Ih)cl<*Kb`CtLl;SAGH7kvcR|!v2Pngz@Y5M}4 z$}kQ%;Iax|GM5|9Z5T#f0sB*b8K-g4+to-UdV%B*aPxlY?uPilaEq&)t>`SvCFd|U zgtr(kd5JqtV@6ZX>C<+LFuvtbm97-wTA$+kY<4gm7_}XnJ+>*Kxn)?>&;{a;DXltx z&2$R-isyDzUHbPui=%pTLbP>;*Z={4^-yYb)wW%U$Y!dv`mXY_t(9!_z$ zNRK`wdcsu~&41^}yxJn<#0yqBO8Z2WFhx8YBI%;SKHgmfRSM;*$k8c?kUQj<8}tEV zy%pyC+6kA&Tq9`LMZ$-*-B@+Hqz_ADtSusiyb$)3VS{unN~}km`mWJW>TI8FF0BjLxnJk@N7GCY*7&8SdvYEul+zE@ zJJq3Fe+G7`{wh2m^_SRD#XFVLpd#`Ooo1;)@^W;XT}dQyerEH1~;b{SEVMxOgpo z*=2DoG&|r6&l*s6I5TIGLUbelUTiLQT12)xoxkO( z|Dwv4W6xdowZIm)gV|9<^jRJLw{84R_QQ@jYR?lSPf~W1L&yEuDYRg4*qEt{s5xHt zUcPJ)wKDkP$46_BXOB>8)oLEpJ>`vRp;Tc;^I3EVZ^J;%_#NIK=V4=Z?P=-IHJo7@ zs}4WgkLCNzM&@oWLhwXw+I$6>o7@_(zLh(LE0T@tdl{DS_~u}d+Aqzpld0)uNBkJ> zSQ~yM%en>=eROz<3S%NxGsXc0$8epC!VygQ`9sEas0IoXrRD48kK#u=+ z{lU@ymHxnxU16s|{tUh|O0~RB^eu1x79F1?^A%PrrEe>oc_1}eAOFF89&5NBD^ZuW zfVv#V;${ZINwQp|+@c{|37>wug8W683v_AV$V`PB3hoK65lx_a>}aQx=`6hZcb_Lf zA{njcd!jW&){((+*Gd;XUDn1~a~?)Y2Yl{7N7+VK0`V44Ja>zh;_=5HzpG8uplD{2 zd_S41J{F3vaM)gsr#bd$%+vOR$$QgA7ka9!;jWZmPOo`bR-L)ld4uT5cT6L*{F%xY9pO zBtP`um_hFt5r zCI}DqMNHn86T_HC_rz`M)++F?yl2*YG9K}l%+{ZUy%;LqL$PvhgQD2XDtbyks;*ox zN;MtEXMW3{EJ7!cNn&P4{O4)(dZKF+T+#_b=YJ`MIDSK#P3>Pb4^dN?IR0!@*h}r<(@1U}jTYh(Sjc{Q^_lV7^-HyIb~$%!BzPQlZn{#`T+j1qtwOpyPhN}c0_NWy&)^QO#yE$@4~OmYL1w<&!UHv7)OoE9KPA}aP+44B*d&8 zKVWr?~a%dH>& z`RE8|-6*wDZzoKW*hq>wTx7>s2veK{K70>lTg0 zV#)~0yLIQcg|>lF4fD2lFav{TFDU#vO&D%>_(;vpbu?p3dZYEHA9csi{ae~uj4YkZ zGt9(4_irs~s8dPW~Lk15gg)SGPyP#U!AF^NAl;9Sc^K$|8 z9sMl@PLt=EtUqH{1jMO`>ghkn|6PBm{vY&D;{U7l=f7L;7$XX@b z%Dk}@v<@bvvHTtccVpe9^12n6HFnK9!$tJE*>Z_LID5cG@XaoR%^k4+)X`gxY@x_H za8Th$;0QABXxpA_(2r$4WtSxLnsJP;;I3VMA(SsLS&G%R!IzuT*Q^tXA3`!Yy0wAm zSB4*~hD$C1U!Bfco^uu0G;Y=AFewG?`|Ih)P1ca7=xnA3nQJ>JJ(~XBTM37lKP3bo zY=vWS)jsPz3#j}gh3&!c7)N{Npz}DIuC9)9YwzvEe)gF8__y+DdmUTD&aEu+om)Qfk$(= zz5-7LEOBrD_D!N4=v43D?ukys*LGAlmaPZztLfyI^~6Td6x#o)%c>jY?7bh_FxJD= zn?H*5;<@N9y`sRI`WFWF>)@Wq2#o%H^92`IBpSwVJ5%TO2CsE%_6nR&hvoghO_21# zU)8@mzY^XH+^+ZcRb=cF+NYz&H8=@pW>)Gjc!9KCj$&-{txazP&mv(&t()=2f zC|gNCE-NEj!>JGSW=}f=-k!(O{tx%8UsmCeq1|QS0B6j&I#9vMT#GWRN=fx3|7o{z z#gVkS5!91C=$9he1LdM()cb6^k%2ea?!psNhfQ{R@`Wxz>%Ka9oij5SQ2V?fVX707 zC&IGmhN-f~pS?aMUOs@^)B+B62aRC13$t_C$4M|xFX*?=oP+jr)m94`lDx!`xz$Oz(PzR#+RPTjPzkPC7P;IU=^ERs)~q&w1cOyra;@7G5nO~`eR=?`M$Hx6%ULUvpVK8 zS1!1;!8JG8cZYU&VV2LB?S{cYJp1^|+zR6Ygs+E&(sk8A|HmImiRY$4)gff_TkmD~ zRK5I418O1vBE8Kg`*t{8YQG}O9RhN$cXue5&cMy-llu!rhfropG^)~S5^V0;b7jks zeF4`&RGV-E1@40{ZQ=^?gsRK2Ma~KQG{hWcpA`)DNz*TNo5o<_($;`M|9WT%>E3-g zfhOzJqW76MJYA5;7uapSXAIfZuNbxkFN1WygLXX4H0Y>OI+~fMNk8_@fXRbNSiNVk z`JHACuAUC}e!@Qw1z+vYq~9wc{q2du{H!Ycc61YcY)3!PA3yL&b1@UnQ5?c|^U`Hq zeG>OLII;%D@~Aob^OqpEEVv-zRU25B54!Voc7XhRmE#VwA9K6hpTL?`iOI|_kMTy9 z;>p*Z#t)q;KrVS-a&B4ygw@cbXaxSlLBYGW&p$VTscCa1_oX(FO*r|-esB!sYZxN6m_^p$zVF9F7vd9<5J&Z6qfogI|>`EX3z)$88ZDU?a>wk+tbhO=8% z1A`fBKqOZ0zWP)zD9d|YsM+5O?jCH?uwey14M+;)g!x05Dt&4*PQm)e`ex=?!u5Qw z|B5?Yni7QuItFYPmw6ZkrqRSEnyRoy?NcH$BAH7 zn6%<}w6f7~ZwUQv?mRRYNjUwYToOgSl`ppBbm1>8g*C`L?zwU(SfhI?~c(cc;vga_Qu&(%upITy8REyf$5KWh1nSR2ehpxYiXB1v65XzD!`NV2ZS~Q!?%An`A?3SlodDv*p zyQ%CI;gF3E^mWe;U}^%DJ9TpudQ9=1w=f;Uejca3or?1yKKA=sE4dF}7my6}ct*-; z#oq(HoJ$z_<*Z$0x_svGmtFJCuLse|LesyBkN7SOvl^@R9U z5|a4z^C9-XGhkKl`HmA~9QrmL){JqV0=gi(?i8XYiTtQcuUM6g#{{TUpQKGg^6xWy zB4kVOh}?p?YU>{m;5hboo8}b0=CYFW)T7R73Dt`!_+5!CyW5}7*n}OYf`mgK%;LuFi{`hCCrN(AG>e#HJI>j* zT-~qR3HG99(^hwSLE;#@!5Ya~jomB6l^imOdo4f7H{6+o>KzW&_Ef{rhkH(RN==~M zh1YqHotv?4#Kd1U{`nJWAB*4SI}Dg3mXLR_oOTzhS z_l){}7?`p=k=)Y&X`b{f!!VBed&cW?N&`W-Q)|(L|0Q~gZN9(aG6~BUWW@iN)xouM z*W6PkGokK1>!Sw?Bd`|35$(wN6$K3)W6T*AP;EBN{<(A~#Q!_qe;BiRw-XNeH$2bzM{;Ygo^2(NY-ot&dvw`+68X0dIvf-qBRsd~ zC;D8*VdzotzD>)mkm~EBe>Ob-@jxw&OT!?^?>Htt?Z>Kp~0 z5At94doDus>8$pJ~tcX}v1K*ulfaUd}{klya~;TeurOL`(!5 zhz)_XS&g7MPb%!@QlbXlDcHs%xhs|Quk|&mitkrfBU}6SCPT8nyU6O{&~ju3(ipzi zXC5Kk6_)&@VRCM!zZZZ^^{78`0iS$@3jgP%*{n;S*SQE}7rm`7TR;Nf#5ocGog^dI@e)i*T* zuInS?R0n3D?s|pq50X!ywcF1w&U+eOoOJt3W!4E#8amQ<2Nq%4hw99?uiMdLZyL8S z$yJs2>eggwC+9E5@vqg#V$k_@>UO&N2(ZvHS^BB0V@ui*D+l6p_LR_gSU=beS?-@3 zSFJ12I#qrur;<7=c;IJ%+2wiE`dVWgeTvNOT-cIZS^mI{ZnwAYGv)ZWM1zg?OD}X5 zy9#Wuug9{to3l(N$^Aj^+!$?Kj8aSNR9ZVm!ASgSvNP2XTx-;P-`z0@G9$vv>Lvqd zeq|}rY;qdA7`8t4>?wj#<)c4m4Jy%KcKkE%;~I=Tw>?>Npcl1vOnp|>OTfPc)^{$E z{h^4ORpZBmArz1QtS9oK6x@~0a2WUuBmLg)vom!au$_-}cWAnO-XPQ==>z%(xWt&`j)IE>MIX+ z7J#nErW+5ho1>JcCx59mnNyl7wJhqcp||mvZ#r`ZSpViN|H{w~dfds)whn`+<5#G6 z|JV?0oiBTue3|GHFs(G?bREf;Jj)~~GX_Uqc?bXD9RmC0#ceqm!C<)93K=4S{=$@IA#hQ>f?UD{Jzr z9z4(8*9=@5KyjlBLFd^q)TP z8v~LXw?4kGVQB^97`7j!mhXpqVhtHrbY`%}xwA=#eF3s=KmE67xf%`L-rQb$G!ft0 zq?>%@9LMb3)4u#>E0FC@t)+a^8|C@iBV5UOS4cwXOP`03BX>OFC%G<%y8=Y^@?_%k z(0_sRrIF~(EBD1Jm*h`YSif#xrJ_8&lWM)JO#Fw5bJTQtOYmV!hp5l?nu;Cnr*HiwWd87(IE5-WLzFxxC6NjkhnnOX(M^wN%nl_8hATyx6q8IEniYzP^ zN5}~CH5=0zqD!%RW;#Ip+(u8E7oKdH!;Lp39Tj{7;Bv!elGoINdJ%~esE`GL3pdZU zjrHMNM1ZwqW-n$R&0r8%{Q~x1o;COuQc*I4jiwC_cR-Vbdc#;x656VG1#{i(#nExQ zi#&UBQAbyYg}o>rC5)nYzEf4egSH*NuzD6;6dj*(o+a~)kq z<-(-lG>Pmon_q3>C;T+F&tAJe{>G))1aHhXFiR*~Gs_*)-VSBWm(W_9ar zoyY-AP{-Mgc64z_LPj3vF_S&y5qVc8*7e^J`=`R|>sQRR@6+-KT#^H-gf} zuMxe`!%$rsx3{oi9!$%mzH#iGfM>UbGSUtbT`u)2QK!`^oZ1r|{q;9>R_6jsKBMwq zj7=T9P*FqX5={>RB)Y?3nWK&B@P|hHe8j*q%{v=aW5&;)NhJID?&!8!lDBIi*)yZt zJP!@jjqZ;YS0Rm~Y~>&E9k(8578Uawg%>!_<-frY9tGL?Csp>MiJ+^88QT!dd~)Uz zf3W~wS0rXM&ZMG&z?)E(drKt0yj^xOtQy@maIQr))+1sSd< zt#I!o*N5wr#^C;X9O2lt{i#74ay)aR`W@Pb*Pr^@J}=IIlzpx<&NvQ#-`{3SF`34k z?~L)gHg@2iv;8HNRm4B9cSkG8cM56xqAzpFf5x=jCQl_ZqTjI-e`IGc0N(l?TY|68 z;#6Rh+wdnBWQvq7xn-Y!`v^^KO2(M)%sO!NP+_a0zT?OeksMFj!HUQs|n zK#^W8gd#-|MFd0<#{mWgsWS|Upn?soDA*9YqKE}MDyX4IkzPb8(vhN6=^}8m_Y`IT z&+&ZkdGGf>_rLnEXC^yYSy@?0R>?{_;N}@dX>(WI0Vex)*{+~|gGDWUicUR6uqZ3r z$LT~pK;w3QynZv{-+LO7AKQ`qe6%k8+(+1_6CT)nryCr8X#aCHF(1hHZn!3?&<(2E zf0c}X@D)17etx@jTRmK1A@wX{aW#B2W&62Gryd{!EW*#Lw!^cEgQAtMyg_611_PxV zc`zV+k7dl$3Sg=4b0tPJA80ObEjTDz37!j^85}HbfUg#GS4Za~xva?bjB(^w5bk`x zr+T0gjNRrTE0Ep-OfE>go$Z?oRDW&f-%P6j;d+4zy2uZyc}A` zzdz%jRl}U#TU@0CJ^lrFD%CW$ysQCos|O<;1JYpR^;6@< z1@wWyG~a2i%c@|zTeHW!-8Z3@*wl{D!a_iJoGCnQ3_2H2{Afu5I&bYkX7Umtm9Ox& zNtmDM9iF((B)hv(=ziYS4`!UI-ERRBmk(U|j_f9`W*Vp83su0W<^x*p0%cHiu-q=< zXFWLOtTA@_g-AHFDMPX}DJ`eeB2DQWZWZExV&px234_vQd$ z+v~eUceR4~pOU#AEUSaNe?_$MzdQ*iKl=3QIX*=NwW$nU9sZwIot zPxdHRtA%1?{VW<2(0vc*cZ`8DjqstM!xW{opKwlJQEJw$1hBp?g=&~{5jck(iJ^)Q z!0SJDyzHBt50>AFvbc1&A3oHNS!6${7R1I*z9YRP1$f3j8+^~(0In$e8--Tn!R%7e zJLUIzv=g^@-Rw8Yg)z#apEgbD2E7Wl{*fkKP&@nOqSxNx;G4m|==JCvwcRV5g!k)K zfZ8vWSGdu=wC5LBO2kh@@p7{hW zTJ^%EUAmHJe%E|BxRBsIYGUa_9+;X{0A=4lqnEO_)Ssd60-gaajKD>)J&VB1E z!!PK(2#f8LX=Qmi;85OnyQZz};Kj>jl$nE7aDwFh>0>^AgFk}g3%rBSdMWX^)YBsk z=06Az@tpDlZuD8=`$M}IK3g4_dLy?IoXI$_<92T=m@9q$c#B&P6x8*W`rgw96~;)P zbVBqKI_P7fydu^4e65R&BCTKNXK=&|;)JDWj)XxXuya7$}x2w=8(>pFj zh@!ZtwI@@aPs{;6vTl3k%YK7iZ94P5IuyWeLKf<%gCJH)s&4v%GWa3Isj!-dJMMZ! z_o49cK9GKYZLZ4M9;j`UJkD(EGw_WkbXvr!Pms81o%fXWX#KnD-qov`15BoVo2Xj) z4$hbIzm^+^;*kux<#Za`z#M~>lXn>-du_sl1g>#|Fwh`#`K-Do7`-;TYkYGa5Qw`U zOukwSQ>=~`8mQHRO}%5DU+R1hCMEv#y0yF=`nzb6m&R2BULD6?%iy0-D5PX|O}kZdA%2;6nDDc^59{ z>x_vTfAOT7?p4(PItdrdQJi4@1?4fR#8zNEU&(Zt?ROZ|@Wp)o*cw1wV3rxWxEy-K zIEwu`{|!9a+NpR0&4c1|S7z8`JJ~frs|$EtW>-5D=r|US8@fgWl_A-904N3SNiA-(Rz=1Sm@nG$figLBms3 zpQ}}q;19j^JA@W}gKvx&S6-1hD8(&TrK3&X3x#;Nxr`_p3KW*@h!>vP6wqZ?p*3C`VcQi1X5$kGA0G4Z}v zF^Y?P;?gmDrS$-mFfBi(nU3Oq9;lA%us;pc&H2`CoLCJ$KTACJhV%v=IabI)6#ZGaPxn^`SRb9K@o;qs zC|A-5{IsYNEWRNqQt<}epK-zG<|U_Ikk-HNL3(2j_|%tB zZm+C`iKajFC;l9-9kyux+QJ37u!&aW4pgzS>*IXlrjPnwYq`27YMKsA|k^ z1JdVdhyC94!g{}wvw80tq4v&&C$=6)fwwZbYT63X{eKTnO>`E`g&`RQ3l46r119MEixt6V@+1dUwBKE1Cs)~x z6~AC?x7YWAz9JZFwdrH`$x4uCXLfV8c{qqVZsEX-?g_eibn?!_2UEbQcB4yEkbhq! z=@Jo)Z3Z8wM_s>vaBQ5ShtC$%taxa5FYci~Y=fs#ecQZtp?ytx{Ry`&yaz&jXIJJu zZ2^8;Wm7lA)PZq6ikmd%e+DbZmbi+ZDFXQuS7iFcJb`jZ`# zetWB(6JS8#xQ@ww+0aN?a&Mz$CzPC9l6rz14Ryup@4UYD9S#WPE)(snLUHrANGBva zK=B*jSy4&d&|Sz;^c;$dCOwLFtWCcO;-l{9E)UNGwEaKQHC*pOCyUAH4j&r9yjHY$f<*T1_bhChOVUT|b+#HUqlV+E%}`xCPsL?kote9{~N6yieJ$t_5Jf zZc_1uS{OFo1|%=3gR0vjCuE4cf@RCAT$3N>!LRc_-4*CY=RKcVwl83A9-JmQcSTS} zAqXg`$ul%T_gL1`Zazf!$UTi6)ZHUp3x3Lb^K>Vb0q^eV_4cxD@bv{A9VLTSaBAYh z=VlIZV2|~(`QaO5%d!-d2$Xcf(Ok-X|LC@r0MexUg~^ebv}+$)Rj zaekk0$5*-@Qu@OyZp~^1@B0p%&)=2{wmJc;=DKDmZhqDDMA0Kqby45Y`a>JqHzu;H zAifx8TP7zM9;*Z3%UYhbp6EOu^^(K+cN^hb{|lsSS{3Zruif_12l?B{&t}cOQ4MEh zulM}f^9guWJMQV;*beMJP2IKYQw!8mZdN#Y6~c8*@hiu>eFJVYFAY>5`vo#uW@cA9 zd}u9H=tJs)BEl=FUR4`N`Yp$u{Pn?_N;2iFPZ0cPo^3~9m^K0 zZRv&s+fsBF9{U12Udk@m)7A>q3gnwoldItet6zEddC@%V75?1Ey#U-vxLJaZY5<~R ziq51*cS57E^I}`8et@3sfmaVqY6fGx4)ru$`2e1J?HpVAx)kh{v5A@<`V2(mM3GLs ztcCpP*%NQAM(1VQ_+L~%)Bz4o^COyh{(vsOLL;TWA^XG5($YemV8Czn%IKv|1yuO5 zJ}AuJ0X}|@?#;N*t^MGd!XrgZ2+9P*bw$uQJQ5%0Z~rJz2VrMNu&Qu3IQ!8($F(^H zST0^WRdx!x&niVee&V5e__0#tk=c|&XyNP~YN*--YNImr#;26Pp7Mdu&p`#0-2HJ( zQa}$(xk!K&h(8{PoU&5RZbAOmH*qQcAAxmZ_Sg1vZBSPyG#IWc1{K#5HS^~D0MS!( z^a`xnfZr6GNoQYFgA=ls)m@fVfcN^wma;KTusO!zyI^V>*fmE$qU2H|I2jSp+R*m} zZav&2rDOaP>c14rcv1TUti2ufB0shUnBHA*-+U8qoI!uo>|_Fx`vtb28;Goej=?oy zn~*)gHgxs4@A*%`qcK?|F>@3@Hz6h?_f!&`Tx8-mWqJ>&%*(M~Lih>Gb;fyKAa#Ks z=Ti?}2x|l5Hl0aS=4*oylPS_m4weIVOUeCxeuMCS-%{bVAIHTt-}ES-_v|@PEDu{s zxgHOV)lk?=!Vjpd-{tAEu^mPm8pf{|%!BX32W@W?)g-BXU|q5FbcoRcJwl#=FgrePI||8udOd>rj( zeUvv_(>|pOKG#Z#m|NBXroLW%*FiQH8WRNPM>)5G=hf8`(!Q@jxUo>;;`VlUw|()Y5Mn`^`m=5_RQ4#V*3^lL6Kn0o?ehtn^xiozk$G=s}h6Pb%3Td zhaETGtN^FRh&^pu+79jwHYu2^bprjD4KBXPT_FA8$E8xyRq$T-caMC*(*TBi_T&DQ z4+T6EudhP=FeSWj=e_53V4;;rQE^%wY@YA<_WJu8K;87(S<4#TU+(!RVN>kbxW2_M zBF>As<7NzuRg_y%2Q&p`BF>4_!g&X?3>J)OgS+&aBdH53!2T>k=w0<_@MP_tF702% z;KNKKYssus;Oc0`vqbO%Xm8J+o3XzQKC7C0!pk!kTsh)$_1-yjpMm_v3p3PsQ!FPrJZ+F&b!=7<(tf$+4 z15?_k81Y2>1V!qJzBGkiFnh}@jn}~eV6ZQzd_mzLI%jgirJ%VTz$r>&qqa;nBqm3n zQGC=1zI!e*ZY_xdsr$rrAK&c*&WnYzpNy{q(v!wHAD(>-Uf^rk6@RlErcU*nv*RwZ z`?crDoye^Pusc*epu7!C(fW1DPW1=y6V)_XI`s$82@8!>7*~hv1}|RD3p)!gmig=t zDb0sp3U=PvaPS-4`c^Y+mSHk*C=5NMkIpaivG3OpO05PJdmdi6u<0P!*Js*LqEiFS zri;yVb1MWgE7Z8{k^cP1>|Xtc13zKO>e^-@Zf|g{?Lo>7>mR`MU1VjC-d8v;CiSK+ zB@YJi8p_`f7=W{#PaWBh?t_foKpvCPQ4QM{sb=lxOGNQtNr^{(Jcfrg)UO}Ag5tDd z=Wz>ZcR+{wa~pZ@6@Z}amI*UuTj2bndDmuW7lNAlnx#c3UUI_n*;lxZCV}~@=Y@UF zuY<=d6q2^i{0x?lx4%4K&;#8kpQ$lhUIN{Y@4uPoo(WGBnDFU+LHj(C$kB;*1)x`d zb(nYmFL2AMMldAv2l(-%Y8Ux09BP?At!V2{2C*U1M{m64 zifiBOX=4%A3bpyAi0uvCu+BcBh{S8|4u^w_fwd@%*5HX^x&?5{7A*8Ul~OI;Y# zde0X;6TKWwxX%-}g=RnB4xO7y^d5I|^0GD%uMup!BH$OyIpAge`QsA4!mPFj%F8>l_^|W=wFKUIyvrWJF zgqMIf^EyQ3Jifq*CdNX`#rt5uitqa2{IkghC$H6I$Vnezap3`Tu-f zZcY|I^bn>_>p#@pUjQr=HEtcc+XYH@FU-Um(}87C!T^8{!lPWZSz zs0)sJ*h&sa&V=(5_x_ahD}eF#VzPYwU*O#L{zppDy=hx#6TZfL?||RWpQyU@s1@o4 zYc(y}QVkrgM<#xf7^@w%=gNebQ?F5+ZEJE?PABLQpVKJq+X0RQrCxWGFM;1^VoUdb zMta!A*C!s=qqzNpuAjD`{Rlf1?)Kk_uYNb4ajP5-VA8YV)doLJwAvsv>b_cNT z>EtVu=mDyCV;3l*^MZQnYMeE;m%xQ9rw%kAyO5^RG3wIgMKISr`RN37K2m$$OukzS z;=zp8rv3KBD)8mv4U4d6pJ8hT?NinDKBzL2*XqHBIv8?y^|Z(RB{14;j_53&E)ZfBk|%E6f;@#@2t zd9ciBmreVlW_XbI?t~{nEpSYfX?*w+wC_Hl_-=LEJ77oi*RhVQ0WlGWHucbW<0iLJ zdVRk&Le~NBZ_9?V^G*RhfJXf6kIld=-7m;1Zh5v1a+c!AD zQZZX&AO{|GdVlXZe+LXP8#I}Cs{)1()-<#%t_Loylg5t;?f}aBm%fF^Q2h6pw%$j_ zyWsT;SCtkou7%$36LW5DEP;n}dBWZVqI>5&_uoi*%@s#e5%ko4p9$)te&p5HmcR&u zH+S|QD+8fot9%H@-+~vDWFstQm4H10kA$+SP+a!KYQZlm2jTvk;oKg`ZXc{?ni-(e z0wt-^WrKm^;!aGsvd>~o3ACvkGm~`v8|NI1`hv?j)kFxI0JqkBq=H;r+uC-O5L&y7oU^+U#Bjw(pLPZ_m zeOQs|-`E7_E2NLxcB~HOza77MqI)`ARo}I8VJN!q>w5P?p$X_5%vpLD)sG^-PFBS? zm(V0IyO`4dK{pi|OSJ9RAA|PGzmt6u-N~iBIcAZ=Ep>E0=90Asiwp8$QvQK$*TT89 zwVq6zvlyMTK6SY*G0*lrG;FNurFbGe*m7EYUtk;jpdhF|L#Y9lJdHifgX}TJ!k;CN z&1(dYH!T=%B2W+H9$ROhzFh#<=SzU=KMbTb^X~&o z26D+3cj|zXf?CwU+dZ%@{Pw9?{n4;bGi$N$#cDt*JnI)N#iiYoJJmmbN;_1&+#7go z=}!=MKTOTc`7^}!9~&kLJ9EjR{m1C_K)@-|KGaro7wJvfB(1oKcfGEd&dLK z(YYyZy~Wa*?YwMJ`yoTRdY(Bxjf0NM#`Crwjt5s24TvjmM8opH z2^UrFp>vy_ymG8On+EqOI30^xSO%x`_z6U7mw^q*o|CEZc=G zIvBa>#l4LezQU!wKYKFBU*Wpgp9<%MBEgy6{b}xLh46Z?%l6$Ht^vJMif6Pv&4JX? z4P&$3?*%`LZWbxjB*Wkdz2CD*rGT4c(%hPpf$kCMH77S_!#;-^d22L|?Zne2npLI4 z{9N~$jc(OYL}|j>iF?CvMb-B za{zWUZNGojDh`&N3vK%RDGv-B(&Y~=D~FxM125_(tKGH9l4+J(on5P?b8eUR#zEkw(KAgVoSWAX} zIT+mN8BcUKge~aE-S$;w@J;RmgH>zGV6Z{3L*a)!7%#jiVab6C80)o!F!gXTlB*WG zp8i=4Z{OX1W2R~m;E4^cC-9NsuIw0|{KOY<(Wct_JWiQ#+z+_nka;$oeDLi_6Rsq< zwfT^ler+1iU!bsaQCS(_O87pln?D?^c`X`pb=nt@mSg#*tM4)3(@b3Js__|Q-pqL( z{^m03*8gZvhkI?W^_LCE+lX^X12 zz`%F9+Cgd}*r`|Kqc-t9ta#I_Fjx=_*Z6#z@p)=Fy6;c2qIi8FAj)s`QfbVBmqEGU z$Yq?C$E7+rpw+QygI^r{Nl2Q*|2_@Y)p-V2&qL=KXx3;*gHK0wR3S(8eq)qtzJY_y{v6#?<)YO@<612B%%f{u}VU zuia%*3z&LqfXjAT1MGgj;o*+6PeIC*o|ZeJ5E#pq3tsQ20UPYY7A){70FpX7_s%th z!@v+9E;5pT1@EFw)n)nM(ZwI)X9PZgefm>ZNn1RDMQIZyZ^*rc#j5AL0}g!x^Lv}d zf9HP*Ebl(%R+Fy;HUU;DC44z>_Ko|$v~H9@+oy-RE5^Nt^{*ygH@_7R4aS!*=(=4C zm#AcvEkpZt!rp)N7NX{Xw8SgizuGh4{M%R5*78)q>5FwIq#-$1=lyI0%{+9^LF61W z-iUWl@rv)EV07MJ^{3k!kdzLB{T0tzzj+Gz()HIV-A3`DKdHq#6pKLlUO{=$vqjKt z_1y=LHT=a5l?d=Oc z`Y0Cg-(OO-T0RLJJMJda6pH4jZ4oiN#3Jx)b8+L!_gOGI<%7)pnpBYMvhheP+J7lr zwl3eDk_|$aNlfTCT?o%jP{=dAPzH=I2ui#$cm|%f`H0vdd31+KpO8&)DGWXMC2fLD zD$wkFGHvYb5;*gn^_GtxD#1=u-kYEM+d$v*OH)62#o_T^jqR@j{Kul>uhHLszW!?b zqxqk?4$(hHKC$%)-8*|-486ks{tCYde-tmKX`nlPC|(SKME{uaU-V!9#&e$XY5j=Z zRgAc@{~Y4ne;FPVKa9R1<|TIjTKt!?!awVO41tp^Jb8@xv%lXevM2WuU9a5XOVRI=^l7ZWc}8b_aEU@8iAI2 zt{AjDE_3CpivfLCI!kk%(EYVPd_G(@_y)XsJM$NJ*TM4(ClAO>=!4W}3kN9|cfy}< zt;7!Wq4O4tNt?PQGJy#!KbD8=c4s!v>)h7V2x}cA`*l8M1BIRG%7R*rz~p(Xu3mQv z*w5Yld~<(1d{typCu~&<-908O-Y#DauGMyStqSh|k1DxmO{k9p&-jl2RJv3F6e_lE zIYlZ4Y9)UCXC-ps(*zl*H7n3PuC|Nn2q%#JFmz!|ksP;ns)O0Qi7U9`%$HXiUpZe4 zH_MH^c_i=~7`Kuu`$Ancj z;eM$ToHGz#Q-sbzc1|_Xv44&Bdqfgfv|oM>%OAuZ`I-<8wL8!7?0%d8XDoZOjXLuS zD6!YfX*16RW5xyDP+QNd4R$J)?wenM?!6s+o)XyuGs~3J^Q%&!9PPzMV~wxiQqX#h zt5sh?q;hi?vG6OjobyiWSKv>$YRnJ*tSJ?6mfn-4`{p)57jNl(JAF!EOH9Da2(cG{ zHus7e?d}EG*4o#NNH4f(Ff`-39m6-nG3Bhx>Xv))d2s4N8|WZ zGePmvU#nwpp>qZY$R@|8Hv^MaZHc1zHgLtfL2_GMB}`1?y&q*-4QuK&+~d){_19iE zHEhv+L>F#ZM{*}UhTqlBMZTQ>0}dRSeP+)3kI=XEtI`C69DMy4?=op&91j;4_V-uw z^B={JD*vBOvWfN%G-#j)0}f!zck z`hkY*V1vZcrMB&mdyi#%T{cDopL~;RqI1p;HGvGaZWlpl@EBOT) zwr#ZBQ`ig!C*E2mT=N4QO({O3^`INxJ(@8#>tce!XT7Y50N%$&xgX)UmY>W zU&1LD)&(E+&xfy4UG@8)e}k=Bu{!56&^esHB*7gTx>x#T(kj!PU*Yz|{YR!6CxC$s zapn)vxu=g#i#oL#qc|}+Mef0^*I=y+*D0qrY2f+7t$QxZ7l2Ihnd5;<6WDfIxUaxH z2O3xH3hJ5C3uSbtRUVSbhS$^*=J@|3=^8F%LT#333u&9+F{PTM?xNUj5YH~~?n0_+q*)o$JKs-6m-Kv;Z zJJp4fyX{N{@U|Cz+wa;0EadIyj}K`F+Jl9>(<>f=%DUuRrU5BrpF9{g3ry!_=M>?BE9M z@2~KZ{39_6$;sk>FGfYCosK0b()EbD@7m7)YxS!jIr0zcM@_~5VeNM+UqJf%`WJCY z{6YKWJe*w&bjALb0RB971Om;SYDXpz1oTXmj0xBsK>`#mnf-gEttKMeh%|RsCp&_h zm#Zy_>Pg|Y!*k0Kyl74?o&p3a$=1us#hySTxp}%%2|JYpC_K{AR(zDt9ki7ZR&7LA)|W ziV%4mg1dn-0aZeirX3~I;Y_regy5hS5}e#^NJN_28_a&x52JZd!q{U$hh5*)l-TnM&A zJLg?Qsy%`1?(R&Pwa#ih14G(w50WQkwy_}IcKr4x%ABD-lyfE8k+4ghyj)10^vj(* z1vc6d5i!V44m5h_&c!;H%uOCo79dX~3zMgiXC5V^IxuQt?eL_CFnW216HSib;biCR zLK2{ounr{=FboJZqN4z1o(;XDSCJfuUM@7sd=if4S|?AMwI_{gLlF%yvl2o;U5Ku( z9-ahO7bl_zMeHb^M)dG-*-fzXqPaUbP{fZ|38H)?dq)z%iAp7Tcv2Ru!`aWvlZ1H8 z-ph_;Pq1^OEIev84Q0eqiH>gWo;1Xo9#qs^I~qmeD9(1+J5P6IisVtN>5Qx{L{A!m zLbP}Hq7mHPTy|3y4ZUQml;Ge*^`udxj^b6jp{ub7B*gai_E;B5|BlMGF79^Do&sx~ z+(<;~I#fuXSwN0mxKJr2tP~eVDP_DT z5TQH}tz3zo&J-1n!fF&%RG1$XR>KPOa}-u*a1u72@Ui4ZbRp0&_oQeX!O7}LCZY~y zrD`6*nTFo$XaG`{84DV78FL2&9JUg`z~JmaKnPKm8}l>YU|i+ohL{X>JT^U0R*(@l zqPC#_g2wy-h9KX#YvpwEA{xnRDawoUq`8-e3&|ScB`bzMIDgy7iaEHr6KOU!l$D5Y zC!g@*hJ9mNfbS+5Hw{92ng7d z9K;;lsn|3j?MZTRkQMV5TP8+_YmQIHvSPbNq}UEikr7*}#ZhRPfEfDcNTLyGG%7(+ zY^9jD9O^R<5;NV2Msh`|tQ^*!E>3nN>2>aIBw4Ygin3zZHyNAdoItQd90Jkao?aS< zvqVfgz^yf1VvW8(u%0Kh74O- z95EKQ^rhF{orX#?xXQ~79~MLxIo3;QW}}p3nJ5sHWyPee6%pejTFA(Xp)tn5ioGtj zb`dZHS@pVlxnMQooQBoDSWH1qSwT@%QBhe%MO9s0T}@d{88vt)2U}qe64ljz6aN);tCzpJo-AqHh{ zKUN=|XW3Apc~RY1MOAUWrmVtePJ9M;b4LT-gQ8EKw-+t^#=OQn#$(WPEP9SZPd@bI zN6+!-DS)1W=qZGr6VP)adJ3cGB=nq&o|C=snFN!2SW}k`#Q@Dv!q}967C#qvM=!MG z(TG$U#n5;R9SbB`*pa9NI~Pxi5nXz~#}a|$wv)1YotG_T4f-=ie`|5!hf1_}LR0n7 zYG=YWRdL7^jMdHzFED(iTgNtIVIm;5-r764Qq~*ulhGQF2{E=LPc&H(9NZ|TzpH|d zjDRklQoYK*|8XTvg0CRws4JM#k!7K5})kK=KYQC6ei@rv}9mWyS=; zO(-*)KxlOnD4pD=+$mCmS9V?!t4f$3KUxgMs}PS*|W76cuF>*R^ z=5%D?PDc1USxrT7Jw3=IsuL0(324c7b$4^J^Q7!xYY9te86~5@MrL6nW?2D>GaGy0 z0RK}85&I7YX;FjBp#5LqhGkB zz?K?-%hd!IPc#mZDCa(kAWK(RkOY9`5TJNS+hB47H;HD3OTYvdOrM|_bJJIFB#~2z zZb&Z0lc{tj#)h2(8gf*Mr`6oiDTU8vXd_)wfsZ~Cxw-J>v#YzxUtr%K}FRR!0 z;BpNj%8>rEmkl@ix`Jd>rfOm5?nXl*4T&m8U@DNVh)gadf}*AXU4X%4E&%E}DPQV#7q`5c4JaWO8f(&f{b!dwY@_Gv8rcNZ0UI zAW;JFRuOkPVnQUr4U_k6-I2;2Xs8XG*N2p4dEjCuW2!b;Yf3pn#+g^!82v}=OJ2aN z^f0~%*m;pCNM>|%aB`#^U56KTA4)m44hyqUQ%)jw)JE(Wgt4PGhw5;OJfx)Hxm75qQEp623C41BYAGS)A*}?@ ztx7qAa${=ASu8iFT5^ug=46c{WX&UJ5@EC&n?YD#*%SzVT!Hv>{i=iC@=O|ujMM?L z))6u=)+Qstp8U5`{0O=zbISGShZvcxXBG5+xipUpZ2v35yqXFo=lxHFd5!}v!^=c8p$h zmMD5Fx?}bfENzJf_G6EjqMDcokw*5Ue`TmGGL(B(voSn53`7JMk^?eS;)cHaY>dGe z&YZTQ5vz;}=PL7nW0g69EM}wIj1-3%gpe6YX++X+JJN5gMkH4c+HN$|=?LS$q@|H% z!Jf1enTXH}DP-xFl3`kshAd2qBds+kHo~ot{}2Hm7^0PU8*}Eo}PTH40W(HLN^; zPbQ98oPiYvVpOb@FjC=f=#}86ERJ^BQr(I6c9?aYK4p2Lj3d^b5t*dv70Ze-$-??Z zuaVVz_!m0W=wCT1XVMF6(}+6g*1ZwQDC>wG$Ce=$EINsYScKE$#j;)EY^frKte40j zN#|#_y4(>&Z$&xw6lsQ4$s04M4l^gApB&uvd$@Qu#GS(-(-{bjTO2kg2Vu~$7fdes z3+Pz3T_b_xy@H8JOi(NmVhI@eIbbU*F%7y5DzVX=A=;oK>`h>q-Z1MfE)TN5MVVO@ zGDRbditKsV%%vC%T(IMO&klu&E}Q*tl%d7o3%n7koYrEj;0T;B>T%Sm#L+HAHEcL> zW*7|&Mo&gFS>>7Rse;J!d(o4bi>+A%MQdsHsR~1yVW5{4qrX5VS41)Fg^Y|1J~K0k z%swzwN5ch`xDvX!;Nt3ov~aT}@#pKqAS zY>mbUz-kf`5lxiHtaEfCVoN6OEacSAn1o{|>)$gQ#y4s#Zetq`Sc69(r>KBZSrxI+ z8=V6=n#aHxn|gjr#^3Uw>JTm2c#w19WYSL&8^_EazhOhRW?~4jn#n*CW3}HRIXYWm z4m4(^iVD~`Wc^~t2dCfg>aaQHx7FF(+Q}mMXQ`IGEpdps*aoF4Rv8=O%z8OyN@k)W z)~k%nqt3TV_`1f-fig2Yn`8Ld5os)((RXQUCVWjcDkveZAM(tgj2z<_<8Nkm932)p zSgBZ_Ah0a_~AqHXmmNp=w3mRm_q_*Q&ZWnVU(a7%hVosi7ZpgLE)KZbmK%$9l zXZ)mVs@u`<5HqKGk;Hb9Np50xXrB!Y>C0j?GCGll-BKZiG09N$$tRq3vTN`*kGbht54LZc#B&q`CP;J@OFA$Q)!6W06Ts<+pT7BmV>XjA)tCaEhgKP%HycEOUrr zN|dZWq?oz@lVaJUP)tdIlEb7}?&uWD`=3yZ{GSm+bvQBdIf(HQ5u;#;7|N7Se@F}s z7BN1LMhrztAx4Zbh<%Fa#F&KGXA;|ZEM^cRejS;UgA@>lpnt#Rpqc0;eV}0+gb8Zc zNWd<}?A?#TJ5z$*i25wvf?P5tN^E=bWMvu4wIIuiK4CrMhD&%!=s=xWaOtk`Vm0F(JARBLT$N!$`Ayxp=EKax4ug@# zMqXsAq9-!jiTscw>@Lh=tm@DcPtRVOh~!SH0F$D$O2xb*s%8$1!Q80nn*G+FiI*;z1{6=1d- z7CaU^vyEK(@MC2`*;y~qcNV$h#;V$Xgt{MrOslbEXIy3JVCt5X4-`Wb9SSO+^QB!RO3ZBr=gWM8aJ!+pRQBo17NKdR2cadc)Lt@|*jBk0TQzCZDg zvit8wM-dy&Op^YN9ogE+F^MqMIA(d|Y{g>ohBK)OTY20c%jyVL?~KlEvo zG=nhA0Vv{Scp%{jw6Jbq)yd#5Y;ylCX>m8JE#_vm!`!SaJg~S*W@B;Evb|xWA&f0l^?0-_K^S9 zk2=D*uFm0E?PXV&$bajC{E0N{K3ubAFdXF0Ryp&in8dsiF?BF}57n2{o@v^0I zqa^gfL;v7KANUSv#_n-X>KK&5hC6-K{ZVL_k^*~Z7j-NGG}N5GjqcK?cp*n3)rsgv zW9(hWV>{{5UDRL=Nnb4A0%J$UBV!6S3GPEY1}_0f5TS z*({DO8MTPOMkXNSC}zSDppNH2WGGsQqi0yoj>EX6U>zPk$AOLjCp!Ot%8F_nR2JmK z=eIF*qqmWxX+jK8cyt)U_JEz9LY;tKaD)yjsZ%FnY2%C^(>73r(O1l5BZ%DdSY*{C zj228o4|NiHi-!PMAXunhya|fb$s+)2P^ZuVB2OH3Dg)pc1O|5mv4Bk*0ZfTHeFQK~ z>I^zC6tX~_$pSXUm$64jk#Po2#I%ZRMiMI)9OT1%aS zmBT{IlohCRv7C6MFjWM7MWh%C7N*X_GGgJK%nA@enN`fk3gRKhJBHvXQbmX0iH(3K zj=iKG7J{8}fyDx1VTWF5CZR6Ca`Q8GLZH(uu($;J3_@Lqy&5eZ7CTtQ&K;ei;etEy zsS;R59(*LRGc03E1%gPGL^=Lwg5coOMX1zoW&_5;{x|Up3LN$t7Rta{=~+epPB>y^M3EGKB^R;sp;|ax zats4A>pek{?jDjx6d83PA3L-_Vqr#98I%!yEJh#r88{sM%wnb`==C3U^N5vHQI(_T zWf7qNsOOQG!hY}xbtxx6JuBb8>Uu`M(*?=VI-Mz@6VYxx^tV(C-*bvs#v9YCuudM0 z{Pa?E%F7{ySd_;$De+?ehf!S~WkOU}Kp(iEz?cuHiYVca=qzALq!Q86Mxx@O(^Mr? z5U1-{j=5P`iK>j=pa}^b{6keiU+Hr*@}}dnAN$;_ie(%+-HG6d0-dO8SP^c7syh0D zhdI&Dph2hI;OEp(HBkBpjE5anGm5$S_`Ajxr+#SV8|-N&nEoApDcQ8ArGJ>94_rZD z9FXQoU58Re4F5k<5EMBUhV=*#Tg!ecx-!m`S&N^Gh7N(i&S_()1*V)J{ti5Fw2$5C^d?Y1+(n2a&r1uhM92aCpBUDIejc69V|@i z0tSFtGvkvP?uyySFl#-V2^nQ(ty@e8m{E)Qo$cr`yd+yuT=r!ZX01V}@Cf4_>m_Sj z%76Fdv606lurOe6Fk_zyN<#LN(Koc97wjdNWWmgcjM6NIV4AKGk#PzSL1(=g4HUbZ zXULU>9HZ={#_FT{N?8OSw)KR5@ECO~Hfj8KPAs6>AlPWh*hc>#&_A}L58Q^}i4KQC zM~`7gi&BXwk!{uBu)i=S_@RSH8MC`BDuYcf_`Y`>7}X9Xaf-W|RC_Fqu78uzS8S5z zoHiX$Djf!nisNt?DhgEc5DceLVeG&%;DP~auQU3AK3wP@uINJ!JEB+oeC_TfXdejn zhaFKojfK%6V1O9Wbxv~3Yg-P$~ zHd$TPULgHwYM$l2ye_lb56^zdN&7M9%nKg17be>*27FWOWVtW}S>;GQlbONb{YjOE*qvt~6R#pwh^du_k2p zvd4~t+_TOJe3`w=Y>9dESm(-e!!5ocVPD3RUT{w^FxuZ8Y%MsCrujXoY1_`MGyHB3>y08#u0L;`yUWS{V&fE{__LapXXHa-lb3BwHi#ap z*?;!BXXJ*r4|8{aoUtuFkgU{`6@BDb*ETM~L+`8S1gE(!lAQPAoqeoY6;G(H{__s5 z(Cxhix2CP%{kY3Jdg*G<%^~To`=bX;79Qjij=0r-vwhp9c%2QxzTa1bTK6udl5b0g zJv;5U`|O0at(MCEJABk4^47%V$L#rFE?1@~x?)y1&A~!!<&vZGT~+63nm<$*mb{+6 z)=WV(bnYFk^*u|1Z*E_k9q%z-a=xVS6Vq6`pq4tLM+xLh>cKn}W0c*a*5o~#x$~zQD>!8OYFV)P;K}RP+(W0u4fX_w5WSqij(ri1 z16*6ix$6_N==d?T58D%=@I&wK>H7!AtG-D;I0ar%yY4%kP8fc*%_Z<9_`gR5$Y^sUCPE z;y9~Q=h!_%CyDpV>u=6F_w@KFlgc2OCh5#G6_RawW`~>~-+TWkDZFP}D_^cz)`RrK zCh3j$7c5J*6S;JE@U?n-s!7_w)kFT0CZ6YNRDz@~>unI75EE}U_<5ttPa80~|M~^; zh6f^AJGkTv#hZWn+S`yX zSWAE4SD!uh_4)xGY)sl&pO79zhPr#`z`@^-NlmUf|8z{s*`u?q9SQhJ+B1GLI!~Un zb`dF${fAyB8DZ2PN4GgPmg?>(V#X)ykh2y#|$b^#=d=)woIC#=|aP zwMK1n<~E=Dj!mTWpVWNo``#9Mo>Lv(wQu{?`{3Q>&-c$=H_H=!`fz)^@S8XDRaV}& z40Q}D@0g*gUNm9$XDPU#cfRx3o%xX;XP)&>3aP!5!R>U`GXJw-gGbDUVo*aBicy@u8&}sc(+bMtkv@kof)7x!cPI{e`a4+-I ziH0{?E2CbotnCkpouV@L>-M)vYKDb-^n-QskIb-fU$$i0+eDF&n^&GH95>zK7XQd% zi%X?Srjc^~ybHC>DiODjOn%$&_`??EoGT9Ja$EO1%D>>9bG4MLxMaJTvGK z&5nn|?iF39^<~JsHdGgww=`^3Q{pBAuX zTgD!TXNNih9v08IH2%W$f$&3pnd#KIeB0D*CUwO;@mK~oG$zT1b@*$_NV?`M+HkGB zy(jkwA^(e3d(Zi_qX+Ge3-rAXsek&Ww(HU@Ym-ZvI#DJ%wFgTw^MaSGHVnxKj20Gk zT{(NXYR;F$wBU&*X2H}oMIZL9dc8o`*L$%sQT2nu_W30{_>I>DwXQyYYmK!*$rNu} zJ+i23cPLd_Z>!z8d!f(k-PvvJFQ_fvfE#WQ@6C&q~`_v#Z;bOn_kDd37 ziaK1MO?-2#sW2-oBk^2JcB+!gH)~nTXSp{Mx7~3Liy@Uc3tDGolqN>+@KyU-tPu1i z->B*R9=N=9{8!zxCoM|c3!ElQs2wxcY5n3p-IL3A1i8Q66`J_woL8}E@$JKxJJx)G zc4=LK&h6?Cf~UwOik#ni<+f|#GP9oK%xBikjwRoOEMrnG9C^C+PRV-D^%teWt$a6M zeA9GBNLOm_>qQx!*C>WN18<%+bGgyf<96xErHs(aH|M1-xfV(Oac%kQ)wk!7sdIg= zuY2&g$y;A5Eq}bJmSa+LH{sWAS+Z}?tJUk4ln=J9l@<(7yg}Y^D6%O6ZhU7JanF9) zv(jlM$JgcxE13k&q~*R`LGeHSxqhLA-MY5qnDU*+()VlVC&j!q6HKezuw=@MsFz{U zQ+xD}Yc2j5Y56^)^T>=X-<$XD_xu9gHSH;?WW590Ghszl0g71OvrNZFb&=^+Kw_;a6i}&FQM1 z8*2v^zQ5G!IMFF6c8Y{s;x!F>jfsmSlqAp%fD0#X4su-BCLTCHNK(8kP*|g}qQ`%& z!`D#0sV_43?lC$&n3y7>5;W8P$C0&iY4+=~#z{N|LDiIr%Qc?{iAcUaUacz5SLGd2 z;}&#(vCT%i&xbD`soosot5Ig&a7H&Pscn3SucnrKO*Q4R)az5#OV7QN&hDNNzb&YG z?t352vZmDaM$L71C2y@e<`vs$+#$BpUrj60D)7+rsfFu2>Z`qFHkUl#Hns8an0LAl zu2n0qcH$|wED{b$TjqB+&zf3eyx7+w)lZ_8H-t}fU|n?Cy2W#;h7K+FD1IBHTCc7d zl#~As7x!Je?4_XpAZ(S?hssHY3nic2+@3Abw*37>&tFe7YR&Q{d+RPbf5d0`QNQrJ z3q>BKKUi8=DzR^si@%zcL;3pER|YSy-8OB*;b~e}#t)<(Dww4DMYQe>(G%&uOS`tF&)ml}%h#NA za7WGKHHI}tdZY+@OY@?$8Cj8yZ!#Rr)t1z#=k>f*;k#08Ar3Dlw}gn)T3IwaJuM&6 zrW&Fd!+YqL{v3j&X2OSvoQT7}T;~jG{}^*cM7$-uZC;2}!$i{tLESFWlS1ta!9~oyQ)_pkKjhS2r&7TVP#oR%9byo>k#1(JoTGdH0pg4e!>c zNi02cV(rt-l7#h^vzJO)8(OF>dUpSSy{Ulmr*Tk!0~gJMyozVq8dlXf3llCxCo zN!-%5ga~Z84_Mpj?uM3nPjo2f@0WW$F7bb~+{r4F)G+y*f7xpPPmdcj-}z57Dw(!YLMEriVb+*UH(iO6Yo znc{6e0qqs)>tpUlPRb2D@ToB|a#`xGM}E7{ym3yy;m}ZeTzWzHt(C5!_HV@`e5N;b z9rFPq6N9F0EK;-3>B;%RtC)53mDGg(6MkGL%|+fjiQhlJaH{H|DY-Ts!Ia#txD6p% z#C!2|AFf)ysWQA?`qK4el*Iv&fS5(y&%JvtbxCTzXyR=htTzq&w0y-8xy!SbZYU~Q zlX~U!%Df%LDp$lzY;xT`u8xh`Cy^vpl1L1H`Xkk-p!Jl zIAq#YXQK$iGJ)~xEk0bYPm6DQUUHf%H~9MT^G#x_)4!*jZhEaf(L#QO*PEsLh3n7X zP7a(@)RlDfw1u8v^bYeAN#EYN9p`)EV@)yW>lW)sPW$!$u=Y;DqD9$~=-IYy+qUhq zZQHhO+qP}nw$HY0^{HF$cHEABx8l|7{#p_1dybJabBxRxg$)f(L#5#xSi_gxCmnk# zTUCp{I2QgaGg&DJT(Oq&pxmh)9~@W-m-5_65-l;rei4fT1peCC)2%{i8x`biouE?) z`P2^BTa{68gs2enL}ehyl7wd|dcT=mgEd7qXAbze{my#vJ9j+bW;HeR9e9NsLG5w2 zfb|(HQf(Y|KL4t|53&DzP#xxW+(H+~B@LR{50>&w`_WRl?0!;O`G#dtrA78swRc{F zewt#V1dEtRuSYNBs~(SZOHLV1f_x@2P=YjPFE#npqD^A3jobGen3Hm17VkGng_id~ ziiFYC!h%3A-P;y($LqMz+!H&{(YLHbB8$@*(;bEp$o^Sg@LW#3pN*;$;L1 zaZHdyeXcNcbjljH>CsqTI1FM9b<@zZB{4KRX&x*wOx|Y{m3h<~GDJD<3c)T zRCwsImVfpUiRqcH%b;A6$+v<&f&tUO1%zFX@qMTy;o8vVs0qPC=8?`S|9n%^vt%87S-ADvX>M6?3 zl8YFbhM2_oL@xnnYK2ng22G7xmn=U$cpY3r+Om##>n9)kv^g%yU+P$Mg}>P}*dG`d z8oRHXNnD87gGW7wd?mA+kBJKAF~KJksV9}9QaeQ`k<#qWTUDOV+EYgL9)OA%)5(P7h^(A{|1=Kc{s|`RLRFN|SppgQx;x}(a z6JMv032K%m@}0&>gj*3ktRb6Iv%rqg z8BI#MXhiyMM+M1HB?v^#QEiQS$dM>)n$&8dBm*1sX%BUr4ayqhgDA6Y6N-ht^wuhPC(r1g~Ex_9P(9 za1q|^IY}?AhXH=--$iSxap_7EH6#NiHEjY^&<S;dfE#LQof00L5#n2qgjP8F!eX zph*U`kBu6JAk%^bd+@ap-IBZbv&~s(AM;~u#~ZKk&WV!3ca>-89QwX4u!?`A4ZR8d z40Nk^k+&U4e3gGwQpS@~M`YvYWB9cP?Dw>{&E~IFK246NY+aLqFH@(_L>UtfVtQ+? zQ5=(7pi1!I6eV)Hx^yHVZ!#v{zCq7AZVesUiPqQ7hYE4wV|!4H??-sktONZ$E;#j# zCIYZv^x0LKGzJ0U=O02uZL+dZmooW8_s8nhCR<7SM zBvxwF?FPDXRdE9h*)KE7(!)BHwJF6xVob&SrW3i1d;(d&C2z=LcD1t@AKa^FsJ*`!o{n=BgTrz@!bt$~+Y6h#PGGdaMAlKCgDN>|VW@JDU1(%G;X_UM{*W;N z3a`PR-9-wzv((l zn&-5fkp}&MCbLIUC*`PFzHhSFv#jR&EyAsg6K^mg0TEksdB#{$ZxZz;)fsGsu=~xK zQ*D{k+C7A^*&<$kKuKO~Lo#b-Kb(p*?7kwdKK2Zj4d|7ZQRr@{qq0Hk#qcM}2 z@ZOg3YD0OE+m=*pgudxT*kexb;5xdBO|XgyPXW`p`da~fvtn(I)>kw$INGVU0Q#5FQzy%|Ru0@Mh{ z;(S6%h57j@J!5VJw!+|7Hz^W%e6%ySxr7iY0c4OdI+G&Fk;Dt3{d}A1o~pU z*GyF;B5_B@a<)jg;TaKBlBT;w(PD#?dxhY>tJK)ddjXn!&#slp6?oN4Ma5o@EzG=y zs$?`*BqGBBi8b($!=T)ePhQDpWKWG=&KZ+L%&Ik}!#tfI5vd%yl=4glj2gd2V!H3E z<=F@ti?$m%Bs6gs@SEiej+Mr`@MgngUHTIz@XA|75YGI3fuw=GX(k6piFJv727GMsEBgFo;>b)+JU?^6mPcZpR6?DFHC6| z+SaAL8HQrX)o}LPsI&0mkq>IL!ljj3=$Fl&U=4cS5=1h@+h{55>bnpx8)CdfuBN%| zbTL}6VLJ9=i+&{cilX6LCOVx{vp;YJriAV7KABa^x^WjZ;z+`@i7bKyKkM!{I6%G@ z1enG%@y;p6#H*GJyGm2q4_f;L8xM!rha-!XCzkzAp8muUr_>7ig8{EaS}@25PdjTlDlUzWF}z)Lh+TL2F7k4t z$t@lc)}S66*({W#Ex*Z~e2c~+a&yH9uik;`uR5@2;aI;Hi&e;PiB%PDR4!XZG=_w& zV@XFO-UU$L;wv?Bl_xmI}$(eXjP|Q;PykoLTvO;pp&??^n9%B43H_S|P5Pq&?*Q7W!nwW2| zJK8ii)r1j&_}0}@rPa6@I40I)HRe8Do+QjARFVWQrliiORBdVXE0t8J5YR;=lo#FVSn(aUHy~BNu@@}zG!K?jB?H5!7uAT#p%*RRb1C-LoaN;L(5@37er+e&o zI1L3r4zV`i_*0TuwMgY3k22F$Jz>5b6Er6(nq@t;i*G=?)PE;<#z)XpV?2q9yP1E z&&m!crVkj?Z{LRF#12440OZ<7oE1QA(T;=wRB}rb`sq%uk7=TZO8v?Bt5hEr^7l|H zV$z*0h?QL*2wa67==J@HC+f@_Yi?-gK5pBumxAw)J;E(GxV#v!ed}9zZfI;=f2mt? zZqV34q+4Qc5ILd9+efBLMX0tf?vE$H=Mg~I3-$|L?#;)~jp4@G#vgOz8`~rL33bVl z1;7j4F$E}&D0>(2kr+j3w8JsM7L0K$b}oVWDC#qCD*?F9s?b4?87&M?IOPW&jF0p_ z57hc0LRc(zOUu-{8J7U(RwNc4ssV zl@w72B2zw8qk`mU{Pyt1U4=(irRUg&oop!!HPHI$tn>gUjdc)W+dr3G_4-RH z*1ZF~T&Xd}lZw~;;N_&JEb zz(%z3Om&N^bW@vq2%=zKxi&a1|6D>bKIcxtbFKFubFyC^UnUz5b=4|9W(ItE zgK5r<>%*C@y5PUf%RZA3zx*M+!C$c{I6a0X%)E+=8k4sY9l?cPOVqyH?O?w=xYTBR zzCr$|i}Fq~z(YDT)V@?EesO%}5b&uG#oeoFP87D*Boo-=BI%waU!gFhD$h`6EKz6| zCaXUY5NL5}G~UMcYn%mNI5UaGcaLjaH5MW3g#XZI(+p@2vNr+0U$)_E#{P5Z#QzOQ z0(Y=eeEOwL49CMi4_1DB0(37{cCIqBBRdc06yN?$C&EWQM#EzTme6Yd>@IM9sqc#K z4$KB1qI;20(prdB?~ltGwI&}Ge2sa*N5s*;&V$^o8n=6`zbkf+4(iBO|JqCO?j!L0 z(vaMZ9pm^cB2aT~yh`NGWy+U-TDk2Ye@g23)gJW~F!3ch^6mlO*_f&fzgW)?aX+l{ z%u6h{rv?0$uk#E+Eca*QF^>5IT!c=3ebi%2IydiBktYFRR{m1g_>v@|n|chyyQ(l& z2vo5gzxAmeNqnb&-4(dKB-UEg0TGP>e>9GJcs-Z=9nC#$mEsw6d2>~hC>B3`n0ZTT zZeB-X9({P_W#tj_UiK0Um}6m<@e3Q;sf_v!ewY`3%=g@oF8>hOwDX;K1rr?VC z)@^{-&94vm1g12O)I?@3v3bDcZmGChm^u>nDQeIW2gETs#YYUvk1YIJTqB||jkcfE z#8)pekzEmE-ISAu>La6?*q2Eee!l*kr_zUps=vekuNu?YamN3mz=2WYXSLCsGC4UVEtKp`S9iL zq~w$`VXG^GFzC5$m<6He2wbFfep^GHOBHDmqVq5gSsj9)l&l?JV zBqPp9g^Y|Lx`#PxEjN5)5plj5x}|4A8T@+yWO$j*#di@xX$~`m9O*Xt<>TD%UY6PT z?9dt<3@$H0q>?he1uR4yd|(;{cOCM5CK@~y;ik=1@&TRTtp&4 zDypih@>ngEnHryzBA=}?H81^w4aI(G@@zT;IfKH?g17_7(irHw`!K2UkIz~nl7ssI zYqno(V>ji}x~Q%A%C;p)<;F?e_y^Ft4WXZi2tAsa@=$+|@aV7X!5Nd;MsKN$DtJBZ zPqTt^*p&fcq(bF$`$Vt|sb}ONXhDmC*x)I@(I&LyHCYL}CznY~TC;DkK)*j)Dyy|; zX*I_98!bk)4MM9u?-1V1(OtUxqaNF~)DWn%+hu>Hb~0G0I&8%bnY`KD9>6=KBSFc_YL6TqcQK#5E`5@1*vOXj ze9Jp<(UVBET6y5}XE6cz1}PSk&4|3-iQt4{*3d}v$8nf3j`9JhKN5Fi5F}^@%dkuhJHyoIHJm(T(o5JL zh+xtr092k&=1jF-?mlLME%|i00_co=$Ztj27Q4UW^mrMtAsQhM@p~?RR?e`Ww{5YUikgt-(HTV;K{#6 zMO}oGfO6qS1<6Yf&xGALb#l%G~D zL8!Kzgf~@Hqh%ZM9!)%n8^R!jxs!CNal!W@g(>XuBi^6f%rQ=hLZ-5n#=WFqDam=k zxjr(p&Op!!!$Ey2v$#3Q4=7AAlyjNrne=Vwj@DAAxsGnaz1yQPUc02HFX_3 z6WOT_BE?e*Bx@7#=o+OF;nH9RmZ|ns1{K4sU)W{P&(caj>L3J4E(MAkpLkA^GFhid z6FeTvEfP-KrPQ^DM>1(P8>Y$eE4FP3(+3`2)2UASH*>V^HB&G*gRwEZdnpE_&_RlF z;=RWqtM&nI*De#bR)VGkWt!RDythIy5iNCKD#77wxnMT`d3FsXLRMG ze;m7%+<8NCYS8}Xb^cG{W4S7wg zJ-z(3_U~}Wfd`RGia7tE&Lr<${92WYE+e8rLRB%;R}hnXEW15sceW~FT8haYU&dea zfR}NQJy4P(;7XM4cDFxj$CD7x-&sHDe$dK1Xy;1}sf|p~-R7y{$6r^@!RwFYZk@>) zhEe#wSnmZgdy&ouYriRI1ws>nb~p@2Qd5l7naa8bNF8pB4ZRw4U4~kWa!&R0SLTQP zw*8@Gwy;(Gd4dz^8Sb~N{N4fp%59h6`?3`q*)6PchYl<*yrUUKd21;=3eRUhQ0Pks z-d6~7-&Ya-(blBNd7a~d+;#lITVucYTo=fnu8)@TF%$3Xa&k7=X-UmXFrtUsn5-nz zo;W^$;tGkvVlveTn922^03{j*W4!t|z}vxklS4b@Li{bwU68~3?o92Jlxc}ewHvjWqwwk#e z_Auuj~jo6kiFR z;*$H}K@A2Bg(=aE^X?Nqso9c&h;?DEpj1)b@==yeS`F`tY&z0~_%s`}H$q0%#k$e8 za+liVIbLP$GFWtbTI=9t>H0FXDuH3>h2en>k!@NO7%^MoOa`ZF^ooiLr76@7=yuO4 zVfjX+vz$N@qWG2QoOy;yqsPOhpzE(xxs-;EWu~NQGSMn={i!T|I@G1paebbgk$R4spGuOE22QFs$OOIGs^t$n4)P%DDzPVyln^ z;R)Gt#Y<%uV5t$MQE_H2rMq+CPUUstq{SsHkzBNgLGoAPCe)fth#p(C79qh5v(9$g ziNvc*9i>*my6BC?$u>0z)hKXKXNag-Xf=1S2C^xPv-VL2viX@qmvadiG@31D;;pxD z7(NVtgff!%!&#GEyenLr1PQoMU9+!VjWdvC<;KP~Yh2=S(l@=P1UWlhLc7~2kDWTE zb02n&JGg7=I+$!vpV*LUAU>fn`<{>;NwY)ceDb1=NYNISc$cTyPMA%gv0$uUV0%iH zBkg1#AFCp)s#NB<`XV?oXX1<*+=A=fq9$j{$6jKo_)=$*jvOXDIXsM$}))8qyvqR^%)@cIa!K^AjWP3()rVjp?YB^Bf>6 zi2-BK6%811zi|@Phh>ifb%)WGOB@vOsLT}> zBAj51*w~XN+L@ie4QolG2mpQ|6l8xNx>Wbsok*_3<9jzAx%Vl6Se4ZU~QfoL^Tk94GU zW^7L&ufcFIJg~f%zApYM7(5W!E-zmY1xAV>&|gcHGXH}nWhu%Ssk~kPi|N6@v<88xkuvZ@mmnIU88#*Y*r7Hl>0!gsx&A%>V)ATXbjHskqM)?N8{_lwC(hz3>h@a%~T+@&i)01B5m{8-*=0yjLv3 zW#Klo*I+>RpCG>-HL_@6?vvl!9u+GUTxsRX#c5clBb+ep76bgsNTeToZm1N; zqG!+@WL4kfp6RiQcEW(EE0Oktj8!Ig_MuO+o2b?Qc zq9fW9ZEj^?T2_ybD6c!zPtkQU?PsrRCdQvyoScTZg_O9eJ>P$Wh9+L7 zaTZ*FoOCbZWl4sGmyts9= zwf4QrWH8WAnI{>;WsCjP(%YB~GK=Nv-h#p;mk@0p#+tm6OgW3ktvhUyYGl1ajxp9f zb+7?@wLu+4ZvGW|MUA%fz?dLEZFR22Lq{Nyg`$2qH?G~ygMldYG-I}%E9>_?30Djo z3Jaz(*VfWCzcs|}65lt6T{3BRrk;p;I)dt=H;hJKcW@ky$f~zRV9jCcLw|l;tCP9k zDNN-gy>Cdd$pQHRPUCSHy8A(x&Q#=X0_gkeHb=m6qVAuCg*g>p!fN1{52R>Gb`Y3F z;)6_{BM`!JYTIwoF%Ac??8pW>9p%b+)1ZW(RqS~&1;r^z0o2IYWIIG$y!-ZXiEi1l zrJh;G>(_{{nZHHPyNcF*Ka`nz-tbeX;eU;A+f+kRJ=;-mSE7YJd4Ge$POJVYE+z$f z&AeWX5-Rm+Q=LYt{nYDSkyNuOQVzbdeqc6j*2lM~<|LMFTjR`!5R{!gadYnMl)12x z>F2b2^K|{e?ql*a1JHAduLJpN#t3W3nb^Q1I!wKOoDa`TthEz}!G%a?gh-^WjX`PL zAdw||MeRc*KQ)-&A7^tD3~Hu#T=vlCYb1m}jR4M1#4NxBobT`0+y`kA)9>7ej%{GX z9#<0)1-zh4Oh#A|mLz=mT~d(&QFe;Wj)u$*M>;@k7CcT5QZm477I>E9aUb}LDYmcj z7B+A&>a#&Y?V?uZjOb7m;NHWppPZ;M6U54z$zT#oqCUPKohXx|y&?Wrf*5+csHkJX zp*#i`jlqk^4Ej+cYK()}nLkceu> z6Kp3=H5uPcF}|S4xUj~H#doI0QdI7YS_q$8Mei95qT)^2IjX}iZ4K<8h<1+;qevUj z$LaRWEt8i%RYY|YjCB!~y$B7h6XUl|6IvM;xYPx~NTCv9?W~lU)|aOCSVePksX0DC zFuv-eddLg;5LUl1Ml~|Wv4>$PyPS7~3P`sTt#w;yb|@1cmsu(uc(^6Q|b{2|tF69vo!5Hl#O1?rgYf?i7lm zkquQmB6ibhQ8-73Q}}0)jBTOuH}(#4ai`)rBZ@?lEwUn)N^w~NmpY;;GRc?P6or+> zPSH^{xs+9zFLii?&my9@i1jBN&zbn{IQ1Xs?y5RZx{UAfq$m{=eb8CnRF(GI@yh7;YN`mm4O_EX!6e)LUeM>HEQ z?~ZA4wEip+E8YtpXFKL_{8u}`cr9Z=i*x)*jggCC0qhZnq;g2!2Y2@ zs#jDzUs#px*ji@8Ay`%xE-?jh?}+$=m4L&f)lduAxX%#os1UV5OB4=bJrSdeRZGzy z6}Y2Aq$qCkLb-6LuK>f)fJ0ydImUZe1W&n<9khBl<4Z&J;UW&e3mV5tiL_9_wBOWl zshjEUfI1;;=-k6&K#m~!p(iDkV}*qGL1El9gf}@ilnr*Wb@m0f4NuSbOmYU4u?%h* z@s1}Di1Y5|Fo@Wm0XX<@zF~d?@u}g} z^M#nY>=pYNm`AIF7A1jf{X&!5Lb1}!Ek-Y8SuM!nYj-bUOt7Al!H5=e_0=nktSGSO z_#{^DPq$-Nu$a|EC#5QGKdboqK?U(Bsd4We{#Teb_O6&{D+TuWN>;d0L(U!w#T-~) zMWZH-7~ss$ofs4DSd?^45z)564;O}85VkWGvV320g|nv;+(#dor!>M)|H@nr#m8FN|!WjFiqJI5jS^47y+kTRqEB&TkgldR}6V+ zlPDhxeyz8ciJN2~Mb=}s!=Y{qtRTw>(XG=Vu?-w?lCV{l83qgyb^RJ!FQxNtHx3O> zpl1KrzSsagSw~H;e~(?;kKti0leMll*llxSmqMX646a>5;#1*YqOL|L5F?Pvb2pvh zmf@JU82*DBXus^LBoNa-T`oIj(r^Lu5YbjwPT5kD|P^y3Fb(8po`+r&(|5eh!{1+vXog`(2C4xS>YFWEzvq&tn zKw4ac8TG5w!4(PtyjZdrR3SsQBv>yg9$&-u(w^tcWA(!!1L_YeVi*wGP%|4WKSh$M zJ95wvL^u@MUJ$ULI12cT_>`Lrr(sZ@w)*q;%L~u(&$L_a;$2gTdFf1bL87v$b-Txg zdqYQu*E2(@hl9N_#nMEYAkq)EMI5Oa=zIzm%LKz+2Fe_cf4ONhN^1__;Lf(}En~f|volto34vp)dg(4upUmR)sHlMfrjbT9)(c(aJq_)D| z*O6kJ>eX#3K+K@ciZy6RJF`QE3h$KrIbOWMJQD}m2+#)(2RF?R^u zRW?}|F@J;>h^|ZcV0(P(x4l|NZwrBN+>_Y#R8Y@f%`@HhfZ0K{dI3K1$4~cuyOn#p zdFLtFrqD)1sL6ZG%QQDuLkGu)jdtdLV8Y&$`*{&$@D3BC|1aZW#=ea1+C@ zc)BdIT^MrUZ1U+RIu@1e2K_l9#f^ST!J({8m1uxuDXYJo*@64XyYP^LPYdLn8U$q4 zLx8>O)V5>$Vco}NhkhAAV22#t<7I~>+avzFaL`9l7H+X9K3Q)EYJGm1FtcYI^5|s= z%99|r=?=PU^cgd`>u?GsTTAaGI>zTfK6<1H%^~=mKHiE^QQ4G#%=%EBdEp~pXOBZ; z?~TWV~6>iq*62hD*d z5zo$1u;wDn;f+8@J6T7`QJ0cjhYqEPrMsko&iJ`-!Uyr53a5LZ)HgaGOVFpf@P^|n zj9~irh&Da41-j&Q96>V&;TjAM&he#T$nm?v!97xlEY?I@su>WjHS4!hHoAmJACsbisM*IlGo9cRbAdt+b$3F=b37%MEf&dXBbA+rXK0^r3sOjRIYBMOo` z@eWu`ojoP*m8lMvL#D zFB+$s7)S7~p;wc)LTfBYc_=9OscQQDdZ>H6`5%owt_Q zsOf!+*LMSsEcaLJwqpdY>g;{;Hc~?D)sXXn?$QyMWxrd%O?1DAFmCi3+jaaNG?q4k ze)s^@jPoW0gmMH3*FCxjrgt_eTnU(i89#!J9|xcMD!=siv|jU;Hmv#A#ijl800gN$ zn$o!1svU&0Y2!>7>&Hw`@CQ+-9RQ-n6fK3e&L`+UAUWb3HOJ>KB!mA;NS6C|Xa4`) z+5fM={CEEEtgLB;tc<>s2@+x{B?Xn_VAej>ve~?eB_oBU0hELdJJhfdD8nS}TDl#- zot?eDuEQ^^%gt-K#1@Si&G4SbK$>wHiT3+01XBF(4(F>u6fZg5x2XxIr%8NC=C*Io zgZIzN&qRX8#EG-VrMtw@q{r8xa3T}&l3$@y^e}^|Mxv** zuQL`8WogS$4G|&o8dNDTR52Z+aXL+*ButVQ`Y?hiCaP703W;9ET8xIgY}!&zzJM>h z8_0*KRKW`o3CEwDxqR+&-(9$&YeHK%v6)4)5A4v&LiDGq8__DMKbXa{^;&`X5GMX zI+#lV^a%-R%O%NOl*TLD5A#t;?}5>Q_i7VuHc%}Oj#(yuQcg}vswHs@&Tqpfxa@Q3 zxC~#LIW~pCqJLqZQjNgSWQ(xiJqv8O;gpxjNsdq0BXoN(`bOm2Z&>^0E zB!+L3nRei^!AxC~w3h+;0C+I_X+@b)QArFl9ai2FfmQi9r`4{%T52dUOlLE9pSP4$J-J}{#5k1=Xlw3lOpvtlC=wji;ctXqW4{S9CY zhrDRN4C~P+?>wE~rIMtoIx?SzR6Eh%wTXotR2gP;T{y0n?l9u_0?$`Mzj_Q!bb}W3 z8S%WR!q7TAgLz-wvf`#Jf%i%h%kcAsMo371}jb%m=5xbMQW082h?pfd9Un2 zwxID`J*}C8CsBw*N^>cKwMo{6)-2RDQ%hi7hr+z@DqT{=I=0Y#l01)OkP{3eaR!0> zO1p#GM2yW+16NQodsEZf*ZCOeZ z9!J_*2}cy3+#|8nT-Na}-JE0=PsmWauymdow9mxqcx*8{bTK>R(Od5}*xG)}J5K8T zCpVy-Frlnwh|u(O!p%V=*R*{(bP4yaX*Z~vQ5ZKWn;{uDESnJ;H?AFj*FP#Ej+}Pt!34{8KunM^hj4=7J+57#DuOK0OrbeQ|ChoTg-vRrRQCYEv z6)akNV<<6N`iBe%?c@%$cYCg%Xn|>6TlaMu#j2?%GP8L%~3=%h&SKEq?R{T{Yp^Sf^Bc%+~~su=MFf(cLZ{cEBK>(Jo!gGLByx=adm1~Bt} z21IbVFo~-8pCR!G_Gk5Fzjy5s`mx<}O21R$kq89?JWAc%c%*HFUU7&f|16-$e+PtV zML~K#w}ojzp7V?kj(|&uqJQVavke#9hU4y{#=92yr}R=8+<>6$p6ojT!(t7tqQB9H z`AiL#64t#y|MZQ~aeIxx_!=F?;=hx@(TR<*fcpk?q98S}jsV7F2v?;WvJoDV-qtWJ z5E^h9{7pO%DPln#TNxSTLSW~I-qkw{YkTZZo4cYw;J`8BAvQ4OaAB4#0qBI#BsD;C zzW#!HV=A5<_AxmOKs{tmA^DGB)lNYCga=*?5 zndeU>Q#5iCA7@^sc0J~@0ta*p;dwNR!DgzbUso~7q^7ObNrVc_(c7g=STT_kq#)zt z(WcwhYbIJt%h=QGVg*=4k8uR2qUNFLNe6-(do#}{MR1;Ciu=wZy5Wu5?W!HZM?39Z zLey{t#~!=Kc}3b;a^0oKS?gZw;jCcG%IC|@SjYD(rPISBPM#;z0o>4=BINV!R=phX z+rrAvLQwM4y~||6eZ$ETz22X`w#SZueg?uHh9WdYsT}WMIitLwtf(Ozfm95E^?`OT z9#FA$ql~na4yF<0F(5^FX4y;xrM6-}=LU(vaFyi6=7~mpr>ZK)UJ1K5xP%L6%UFmi zS=>7<5P|K!-UzQ%H+G1Y!M&V;80WMLr{P)hH%$53&|(wNPZ>sxnlUR-Eu>AmzHL%E z7oAWPOOjfilk0Ac6(7+sw|C1^C}_6u0?o=(o8L{6z7PI5dt1`&oL*WTk;DI?`b|4b zse%8!Nj-r4s{9X|9X$&_)j+RpQ_&f_iuKRrZl!P`lzd)^;uJr zlvIAwf)E1dq%oSfbP}@FMKKB9s3<>AxH(&6BM?{H)U_5W>H&}rUo;)5g@G4+$ugPY zpTPN{Az{3zR<_-!R26GW%ZuiXOqRQ>Z2k0nWeKvN^xe1I8&?~qPPP6FqWCdwu+g)f z@x!meM6d*;#DhZD8#&qQZ8n!u6nXSmqLiWQJ+^_`CSH*ehvzPfQWUXS*{6g*@b-=^ zDdBSGC5erOMYhCC^upp`?)bQ|FA4ra4a)s}s^OE=Q|B!cor(IrV+>OX>^TcKK5{b` zBTggE;%pQnDKcHO=?XZ5`y-Moc=Q_`nsqV?3WwI-lFLEendFl~ByEx{6>Io(QtX(v zON`;^0p-R{O!8WGkR}Ey%T7PKwAy3mvI8oMAsNvpXjSB$M z&QC=)GiU2sI;wwNV@71A%f%;NThkOdOZ405x)T~JdsHv%HRqTcRo5mC=Ia$E)&Au= zqjZ`VYvOvGRL8qgl0daqQ=wQ!QYJDzhaOZqvm1d_vd70xTmBO%OH&QFhd{4mPAdVgSGsxCHMOS|N~f(X~Iu1IgX z!X>&It*lM9KWTOR)&*7M$Klf_j+I(di(U=)cxZA}i7IKL|9mKFRZXmFQSsur4S zl%FAFn4mtel=NUus{HItrabHCn^RaiS+ZnUQ?U$^$XL3|%MvtW&bq81KDv>aoi9pK z9#_{^TS;R%Rx(`Q_Qu4`udoo=p1h(_4HbWpRb{+vUbVI8%f_l*)if*mhaErVGHkgq z+M24y=mDLbxgRv5C_GCrb5agi?0*7uK1W zpNcef=<#8TvWFm3F=^`!a1YoQ%|eh55P|O!dh@1r;p>$j4^Q;{D*Xaj5oDEDvcvI@ZtoSa<+SxvxI3HxqYogt=dE0$s-Ah#; z5MnX5?-5;Q9|N4PkOxPW4#cVsikn&iM@%nKbyUQ1(tD1W2HsN$$}8AHc77cZW<}Tf zC`OF$eIZJjyBok+znNa@HH7KG{zQ1)i;jOuC|djunru41SOJ`4SCEs=9uuN>%7O7W zLa1dfc&S{7W$wKS*#MPz?E3-uC)Al{{;f4a5AFO5hmOd5d!H-!C)QcGod;#dr+J48 z^uf>HTLBn2epjG-_h0G84f0<#UFlyC|6bGmpQ9E>J2T_IPj%>9>6+;~Slil|8~!s_ z1>~PS_sUy47Kbh2sMA*@KbJU<`j$u>6zkM`Cv@9;-JK~2s#)6xibe`kBB%cIf^BTd zv+_O;Azifb@nO`}me;rEqZiND{q^yAlB{bK^^X2xwc6WO_TNZEE%j4lce;I>*@LikGIQ`t^3RC{jJsYM%LH&;ehYwYq~U7w%6t}TE zZPir9>+^B{f3WtAL7D~4nr&m+wrz9Twr$(iv^j0tZ`+!-ZQJgC+wR%+E$Bw%f9vo}Rsvlih(a9`!YUAdbKpA`rZKiaxDfBwFEJ{{#tGoC>2)O$I2`RD>(eBby6 z25K5EUkiN#yAxgre!h4z%_43h1ipOr67Kj1T-E;#$W-MT<4yS{`dZBov?l$E`Og06 z66bQ69ZWDZ_`FGDX-}UZ`tuwCyyxcx8PfhfX|wdF*UweB74qZBHL$z&_Rd?Nk)m?k znG|sB;s0|crDw+g^S%G1O@dW#K>6qM<=ql=XPXAj;!Zt)iRfhPb*tpCe!yLcaSyxS!`!w*RdmQiayd$LAzeSxggX#j~Nq z^aHSti8HXf_alb>D+N|zkFkR>(Rq1{Z|^wV-^ILibnqT3Xb+ub3i!bD_@`$O|4-$*lbi%VaR-Sz&Brd`oq?nNreEn?r`p_T{4-KMd*rzPW$o2U5?Eo*F9L9C2o$ zYJEQJ58v8{Dt2Eqf_7m@m-i)D{3YE#j3G*^HOTjWKb#sd_$;Q1ci5Tz%H4W-`o2k6 zO~@8Q+vG20&$7cU2bz&4=<0k_M)|3mIE^>Z(Xgd2m;?zK2-;uQ*?m22yWKLImbH<5V3u>Z3Y+~{2n#@oDXQgnKxaW?fv>1UIn6i)mS!+RyEtBrb_#5tM=2p z$FXCtE(U)KBDmpMNom@fCwxf^9VVI2SosfgmO)?!HV_*IDkG+mmJlr?FQ%L zdAQ)jvOWRPrPm95;wqm@+CUt@XeP)0>_{mAC$hZu~#{Qc<6ABCejRed7J zY7iHOPk&r_W$bG?=&PK9!}=CBar1ghP_(s9SUa}JC{DXk4ty?_k*Ed4s@DL0nakz6 z)p~}azV?#LZ(twAJtpE6%Y2jHmgGl7-~_GHO3v# z#fl3MLRhm(93afOGRUFLE3q-pN1zMLdsERRq@8WZSpwYFU6Bl8$-mqCbjJ72UBwmaO?t z=JoxEYZ9$;;ywb*|GMY=gZ48U7I?Or(KD{@x}g(xsPQ8%Yhpve{>BBN3*XU`htQMf z#BmFa^~|Ab`mTN2c^R{m;6yDlzrEYEDB-flT6UNoAzJ1lOR_JD#xp z5PWky5{i=~wS@{kQ~c|S^cQP!sNKmNDgbc-qeSM55%2hQqMsF9e3|{M_3w|? zM{siNGS&ISCkr(6=dX?*qi2=qcLHJ1!d}2R(m=YIkIa5Q{NZD=1DIjRA6S+n_tM&? zX*Imu;pZr0vZ~(RHiDp%KU|W?HHwwE-&x-gkdM*NZ9|Y}qdNez<5WZ)8rD3Qy$7*D zvUZ;{kqLVe!2*Dp#&k>+gZKMQdacep5^^~|HC)J(DB-aVGYDelDLYK5 zI}$$1OJ*FgkWDytjLb3(JLwNM>u}xgQGvpz+(Tm$` z;gu@7;e-^oveH^**sjut2QkXB3#F^lX*;Q0HatnKoL8Wa(xNhFWWpQ@o@=kyN^vmD z8N>(Io~fc^uxLlbYX26}&SL>ZL)RNHha1G9HV_pf=a{l>!Wb?*iXiG)4o&Di-bAFa zkJNJ25^h$y8D7>R|M&!cmoX;a7up*)BBLC6<`K^n^Q)84X>8s!^Uo9CG>0l)%Xw}b zIjlv%(PBJruy5NY3!zVT8b`yvD&~JekkbU{+GQ31&VmXdH^f+_qvyaRccg1iLIz z){yGK1S5ab`>uq>fvk_sTce(*QQjKSp3}@Ur-rX2hu=vd&pJLk(OV{_d>0OJf_Eqh zlUXURiFK8g!$y`8|1B-Il=xHUQMJlsJ$VwJM_u_WO`Wc3*kFE;Ih0H9bPQ*`vRP$B z;g1d@y?8^8)!3Aet{Rn-TF-k2#^q2=s@ zjmg6j0Fie}rQ&yyXcDt{Nb>kWwH8W^H(c&SGzJ}{$H1UWJDwhrYM6=A<(7&}DZPVoC(yEc!zhv3=AT-hOG-ecRgjHaZUU?oMxcgaV z=m!5pgXKgOUxvk!ss$i*1gitESx*`mBrZX@^Y$+EGI!_%EvsZz(uC}^K-=^7x=A_Z zFt%vRQluzxq$W~P5vSO%mb0vZO z1#FV5(WSawO$T8#ku~s8e`N~|j4+2)`CM%d;?O&-#QfW368v9ISsOnlOi4h32L0-g zNc=v&F~HPRL}66%px&Qr$jNhX3fQP`IF3Yh$MvYy)I_C-+37CKhQmMj++i@nFn<89 zmgcvc16gRXpD!w|mgk9LvbOEsz?YYNvPGyy9FdGfLuqXzK`l5FC`9FU@%zGIcw8eP zM3ReUinLG^bmi}V1&Jwx6j6(r*Tp}TRdf`E^e+$d=F@dJ$}fRC$=B4;IGq{I@S}ky zSU`mcCxx)qIL>B*H%fqN6$?k_7dy^mmNLBa7{!Cp1jK9gPdnh4(E#@dVIfqAhnJO? z{bpJl#gbh#`UaVUFVK0%ZRgfkj_>Vg4*D}ds7yu3k}OnZ?^?4mB|G-6RC2Oe6I(G~ z=&C^zrb5MBQ%_7WR!Y=7J`2=AY_h=Is}D~L<98!o4Bxcp{yL_9ezbIU8+`d7UUJlG z>eN|xpFHWT(ABN_+?+1#cSsT$%*L|vFX5slH23FlpAjI;kk&2zj7OFAC26Bzj!uTD z?#rx&_k!ElEPj&W|3Z2!xA)W zEJFIoXU#f#lM6VCFrkBGGUt0L_PnTJ>4majIkJvk&pwITD^BWinP;(ZBH*c-U{F17 zWfo`kA-P6Nw1e$e#ACZ?wR)|Lb{IZ(K|RpDryX~--?P|Crm zN<2D{gMTScCFnGcQt9*7CiN9+lABWKV@r<*E{e%*MR^>hS`7{9$&Ogm&%jzap|G)# zs+DD8lYmyn%%9uJIkJH_YvcGeQ?&LNiB34R z8N>iz?K8xC7b#l`km^=$tRNjXO(pm1oF*~F3}S(I9jWHZDaYWC^nNj4pO8|;gqDE2vm6~jpqa^hRYur>| zQ?@D7snxgnk&}M^gzqZ|n}}8~&Tb!aQF9W*WB`f5%vH6+)mP$Q1Woqf{@I5aEc*{z zR1*`gO2@^m&NMuvrG0VJa#YC|kF?8ubbzlgPcaN=5s<+xUOMxG57y6Uo#7S@!J&jy zn3vBvxW_KDt2)pt!9CZ$Aa-|9m*~fVz*28fcShBnrgZPcIhi8vv?=P&rtLz}ugn#k zQNeVc1}qYD0P3jh1QaW3Yv($i{pVJeEQrlpY1}D5)KLY5H*G)sAKQLzA~P*UKiG4< zyTKT-J*#KCI<;K|vh00yhNxEK z4iwr~OnLqSQ9p-?=rvK&cPY?qEe!GnWp-lu4cMsGdK!x-N(_tX8yGI&jq2mN3B*X% z7jEu6jo?j~>J>s|AB}X(gqK;Sk@!1Z=p74M27Nkcvc&p=eTazSA|}HKMuBCj23hWy z@Vk`bU98~PM9trX9xe@uoJ%v61@X){v);Ay zxRO*hIt`)_F`U9qP1RD?!7vlip{np|v55hIvmU7JZ&)V7(Yr~T~G`I_Ybxm(iF0nSj>PH--^uoHNNm2 z(b)V#r`z$b3JLrb{J&J8(HQE$o5jUT9?Edf{*fFD@&*aC7X>ITjTy0qyPhtp>j*CT z*^bNrri8}NqhlXuM!6fyk{DAc$25%ivdOv$JqoHvCx0EaQuE>p6S7A*K~^q_VC(^vYr;c^X9mesaBwUx`1M zlVFKJCk;xH85-airz#0wJteN%RC}A+s7GCBRFDyhK=Mu)?p(a4qOwGcUQyxRdpVvQ9E&W>FMmb!=BQRLG#R!1kl zqkNza!A;aE-|2sI$dSzlFj?=AOZ~VgA>AthVMNkfX2+zbJ32{qV_U7xc&l(K!3rvi z<-qf?7@j)G*355~6oOMT&mnrgj2oB#q>ke(>xknUVTJ}7NIDt)*0?ixU?}X)%&a8n zqycj;_3pc6_d+y2Dk?fLO(NE$!ZJ#m&oEa>p?{LaiX4t`4#eW1yY3H0ol7g3PwT!L z3TA{5lNoOj$;Jv*RcW;rxkw7?B-f11RQ$9g2up5Iq(q-3?g3n8{aMt@Sb_!&!AOU79+2q)C9l=|TEeD!hk$32G$p7T{i>>e{ z|3{x-YJna45j>nCF+Uz#e!C)JnD5}P{reD4sU%Bq6L)|Y>@dVql0zu&W*0wz^(kog z0;mo@MC~O$tv+E)gQc822D{j)PkACu}NFyO$2d$|p<_BIS&2k|THwvuDMz62|vq)yQXo8=8(7*HD z0z|i}@2?J116r7({We>%BPzjsiuZHJ2{tnSw6gV&4sKYr4vgar3^MQ~H%DB>1)Y+! zf`O4j8lPC&a$<|ZWe44mvzma(=$yGTpHX~<<51L`NU1rbV{$oxLTqwSI<<@ zb{0^DkvXSS3BI`aR=P{=2DcTNa4(|9-${rc#=&INt&~PLiL@zmsnzQ!5wlX8o$=bH z?O3pjx3Isf6x56r)Kmaj4k~!o9SJLNZbyRz$%COG3d*sQdhpA@ukHMtR@srN% zmmV+w%h{~{yK6qy{`XeZY#qn%_kG{RIR3AIPO2x!wbrl|hkMU!ni58E_KglzJy%ob>Nn?*))+whC)N{6ArQ!rV=7@H5=XSP4qADl!0W$n-vOpCA zs#`UC&1xjI8s52E#$=v4!)}=C%S?F(XSkp9zI|)0B6hmVs6QPIsKBK(V+-gA7LVaj z9BRTB7NwrCO-hz>Eu zJG!(4oZ#?-~knD6@up)&oXjDja8^kXwoU%`>6_Cbn~I^N4N&>alKn- zC7NM`V5i0vP=F(?{YL)#mr?1iUlXe z7H-t|M`gTiYd04hfdrzEPU-lzeMGfpXp4J&DO$w;9oXFNwRZs`dr4q!4|=P3@3g3j&M^&O#nX}zLn;0@VsCT+;Zm=5j7y3tz)7h~7c1qW|U z8<6M(DpOE5MHfcJW0eY+KGvgVPjkG((W>EVB2-?wt}fB*$jBhlI}qfKq?YG7Atuk) zm-)pkAX`U4XYyte9qi8SZ*bY3Tl*TwdXA*5?!Vassruus`cyxvjTQhe-SA^)s1)Fy zYUrgz>Ch#PU<+J{IND0;DLY?!9^}9n>*v;2S7fg}4$!CU3LOnaw7|{$G?eD!1!gS& zG;UGFTHux~*gF@+;%-?~Z;d8G!61?7o0tLTMz>6vVJod>-+y*g??D<}3r%G^|Oy5_T zodlA06n;-H*rpdbYo#RV$F|?4&ct8}=)`&~{zRNo8X>d#B*>A81QG?cg;0A&dJ(Y$ z8IWW^ZECMjY&y(=i*<#I^^?{(D8rne{I%Sd@6lS4`)W-4Z8eR z>Eg5T5Yo%)QzWPKTDApPSer<+>uVDN&fNBGqbjo$+R{XiNo+yR+=4@7m)$zq;28Cd zA0fT9a3SFsGtu?(l$};ni`iJ6)=l>AQ-ZV6O&Nlfa>j)F&67hWc_IG+Gx7-jc+i1E zrst|>kNwlu;|dA^mtqdG)5*;*B#cw^H#gdAG<8LQ#^KJ5pBU>i*L=#M*`4V#H``-n zc3Rg3mB?dtay#=CPiKUY{9y!vL8 z|8VbQmY_la1Tvigj`0$GOL;+v3^F}9WU_za@;)|1_o~Mq7`zN31pV0A*MDr}vn>ow z#7E6op=H*pefSrKltkbXYDWfY~N1ZtXr*Sufd>C+-2&Dtxnykhk5tCPt9onBSD_; z<0<1;hhpH(Qoe6D!f5`-)2EK1uwZO!xZ=V)rV^(j=honyz%@J+l>(i2)f_v#Unoq>+%ZWr(TOI<iqM@j-*JYSvI)W{g&7LO5A*jT)1{E z0af@v;v)OVpLS&Jx{Bc`ye-Da%Up&(6?AGheEJn@EdXT-l9awJrhv`B*hDJovE$?1 z>Gv;eL#~@HcT@Jveug?CTa0SVw1LvVHi8mVKIQfNgTqSim=hD<~J@hzWTI@s_ z$d+6pbU2Mv*efs;4c3U>xLRT$TSAoRX53g_NjG!&W}<_e5@Ty@J5JiC6XT{SZfarN z!sA#S1aMRqhOT6tt~F<>}LQv^14 zQDcY9R8sJm3qW%FlRsV5_0O9bD=Wz)=1Bzf9JdQLLQ@Set0Kd?^Sq`ZeRc;;y!OQ~ zKLJx6{+RL?TVXZ7Ye+W$O<_fjhw-g81vNHST^1RUt+>eq^RzRWsM-f&l zrnq=BgJI>;?P#a!wNjIk3RR*{CzAEBagM>|O;O+R=IiW#tYU6Q9OEe@J&%Q$FvW%# zpkC(+dl}}m0k!p(TFaG4;o}y2_E9!o8rRN3m8_b>LR@4_C3LwY&=Boc5t{ax8FncH zp$NO#Ih+2)!TcPh`t?z=qoqXm?66iB#LR9yql-S+GO8dl!jaizqRgK( zF{CK-5ZLbsXa6G|8D_rg1`KC&M568?NZk?G_Y3RJ&1v8bQ;DW572OG(Fr(P_(|cq1 zRocK3*z^bKWQbiH%ankoukvo|qeDu{_?N8zW`)1?g=LW@%nZG>-SsiY0&u8}6lU%F z!>VuQnfO9l*#xwwScM`$?mFv;aEMDh+7+5I;A+L-uEZmwCSp#%i}ojQrmZDnB9@3F zT7$9D#7M_&v@zvou}F)R44W}VMl#0`Sj-2lSBKAP79mu<4p$#A!GjSP^PQ~tER@RG z{`F5U5N1`N(#>*Ibi#=;>%RzOsrq|=TA<}j*ObMIVrTX%?uXq{zXa48HH}7fjS;oH zZYkS`O)z3Y4n||Y1Ptee5gE80JLu;7wq%s}&}}Ptp|pz@JQNJ)!S+VraH2OBaSzJO z{ixjqnDBo!CDg(2L92r)(}OF6#PnkM!$j>?c4qd6%YH*$(lrEol~Wg~(ilwJ6y*qf z?eNxq8X_KgAU!*~n(7bx;cNg+Wb4Ab20}ANCkOkG;!LW^X`9%ajhCtH-{WUgFtVMs8S*@IF6vvjs=^yPM0U>eSnaZpVZ&$oKe}cIJ`8dW2?@r_! zBkz35s7dkoWunU|I#Y@+rziI9!?p9goQsCg=!_`Zd~p+j|< z^Y4v6D{w!M+Kl=bhD;M0G6Y$PcSM>~e@P$^IQFZE3qE4YvP49A!BgrF1v_UD*!K5r zREGpIEY*k3TEGVCW8y??OuX8q-0{4N&Z6jmhhgUzYxnG7CkRMj$AaNW4(T*EU(%gvGjDt7i+&9jB(E(wOR!+te7V7;TDq*>9D(sj;t;^UvZOxTQ=c- zr_Q3Vt^hL!zLSD}Eo@!B%B5lRzK(T-?n^MiLffV>XWU=Uy0DRKQE!HewJS&9;W&|D zIE?1US^5#?kNe$+B#%0K^ihC2HL-qQWx6&6^=pltnw3SwhWXuu`EkO%@zWhe&|T*- z>nU0Xn(y_jRDzsO{7`M4Ht}@`tzm~DI<)*?2~c=?9;D4daTvqfZ^$`OSm#h1RydA*=DN|3j-{rC{J@hPS0;RQm(}b>0YT(n zHUhITC{CV56`>OoEp-$x#+j&PDTOd-mE0y7Q>S!v;aRN{Tz9getR;`Gu}uO7*JOZs zLr^GLEy+)+5y6)}#+Nnj`q;`^_>xEtZd;c~Yv*9>1ruevvv`XhVgANjIXRTl(G2S8M9_$nVi^ZB?cF)m z#1i9OQzXAtJ_~JBRAzaZfZeN(*KxNMr}9J<;o#4BCii2cXm5mQLi9aB#LiHm=09R{ z`z;)XgSq5uJ=#W!WlwycO?+A;S?k#V2%6^64Z?DI3$92}Lk|ta6>q>T@gpUSu-*B@Tzd9zPRw}{$`U5a~gO)a$^+*>9cO7@edvOy3q0r8yLPd#1aRN0WoPD z4ZX0?FO@+y-=FAE8_6*{%x>sVy0Os%*IM$1k*7&E)O>W5eGdX0ZU|6lzm$gy<|OPr zooS>{r99p>$xN6#b1~4sZCb&Zvp`~-(D!{lNrbdb`Rh%BN~&{9s^`<#<>}KnZpLKc zD4l~Kdgial51kf~>`ay0+JqZn;dv+<+KvLuBIHnhVo&CoxrH|TV$LEa#|YJo!&GEc zcj1!_-&@b$Fx1r;hajmWwxiQkv9YNeL&7|s@A~;eWlNhi6s9Czm=#5;>4-Q1q`6$r zsrs!iyD;UssKIoH@f>e z^$?moM~A@p8C+#Cb0(!UEnFQQLlN`!l8j9V^e>wWYB@@{Nu?<|q*q zx6*{@%g$PI_?Q?G|6V>a&$5cA2I63`U5gujW0a_dvlfrcz6NG&42>ij-fLyWgt6r` zv&GUD$yjTKc7T#31TS8&6u+7R^a?`wMXqlJ<%^PcmiFVl*9T^D=w(W1UvhMveskZT zO6m(MeC-9Hv= z<-&Z>%-IV&CN$e9WUjL$rhw#~*grpUtR2ON`D49|G*mDv&a zmvvN`mu7d2nzR zBxAZI#VOFvDi5UxK)I=`>nf{7urSS$Z&s-0nbF602{;ieF8ByG7A-Je`Sd%*8?Enf>OVZpeABZqU}vKppUBjWVAbmBT&^RsH@zim<2so4bv zDHzO+bMo>K`6i`3kMI{HKkP)C5RUv2PWFt|$v=cumsSaoI(98h-l) zO?rh`gmf;uUGus0N^kkEb0=t)J60CQz7GJNy$W&q4HUKKxjER4-KgnAfGUWn$$C)> z%HFhT#gcnwzZlzPw>7!|Qe*TyD zb0YOQ4I=n%)u&f_Lav7_pTgLor=!klSDJ*=`}bY;O6Il#^y!J1vGWWeJ0Y{R{%tjN z!mYc*V!I)4(`J|{^wTr?HMG}zz2$MC(#cndyrZe>M44Q|B}NzFKD5a22N|+5!egi* zH-@7tZGexOxxfA-hd5_Kg!(@l8@018+*((>eT%m~v&?;qOh5!q{_=9gfn}=R(qhnj z5_~T?V|-67VqCjOsBM3TgtgIbXXG8WE1y{!4mQ5sUOGQu-u@Wd-fQO|XNaSq0k59yHD`kK&exr`?m;}@8DUXCE17seZ%+X z^qH?x&%pB?!}k{~&~MUyL$TMG*irA$(YuJ%vaYJvh0GJMgl_k;7LDGI^^O&f)5mzU zCxqT@&bJSm=T4U{>(@&fxA21PdxDuVER9XX?A{z7m$mQr?L|;G*r&S{Rm88eqP560z%6N`v1UHYJedAe??6EpLjLc z|BY8$&V}~FQ17}Sd7Sf&m_sA3_XR!Ab)KIrTU9CvS4tu#CKiK)s8lJ5p(d8WfPkl# zPodO+fc&Y9UP>K3;J?$oB6p&HbrjI+JKO!DH=8b+_trbhXS*_0&DrFc7Y&y>kwhUo z`J5}3%=p#WcD~SQc*>Z&(QLb1C!1WB&?Ys7iU&56l)-`CC&cpV=rr*A-^Fr79+%m{ z$xdZpjHJah>2f%hh|OWHo>w1Lf+`LN3kz-cw|xaxE;hym;OfyZHRCk{DR-mI?!hZY z;njTscsH10+!uOh8Xk|w+&;7BY#NS0l*wE>(;oWMbOiB+%WUB6=V3$w4#AFjZb0Y< zMH~@U#MZiqxqU|jaujStEFqi2Qc&WcD%y`k0rn-#pMNPv*_C|p1v=w1ef!4TH0@lj zGx`T5IU+qrl)aZhN4agthY^T!*#(XJ_A*#RO(c-9<*6w-jJGnp(0yM+OU{Py3-N6n z=c9N;ukC#maKpEsWpVlFjkkb5!6lyYIE}U{Sc)T%WmF_NT$VttI6E|RdEISBx!<*V zc^3oSpQ2(ErZ4~#30{vGclQ+^h>90n4t-~Zu={%4k6VTJ8-)?@Bnkd=L3a(^MQ9J9 z2hG?xR4?3(Cu2ShWVSqqHsOB*^UsFP{{2OHr-n?X%mW}MOMZ{T&tn(lWpS)1!Q37N zY@7}G6~4+T?11nxupr_NEny4#_<=FTCUQ8*y@|3U;H%~;qe(o+m`A7+r{ET5G!#R{ z5@}G;IB&gbY0Al`v}+(JIB#b>P7~T8RW%GA9ss-KcrDySR64;WnFY=5M8L1OKjGa5 zhW39Qg##VATSE#(-V;ZST?>B?w(=O8jX(=nO;t3k-JadKErp4Gk>V>16~FCLyCy23 zY#NME#O5<2S-NStnanF026amR8bQPsveMe7a+*bu#n$KIp|Bn}>nw&skg3qMG#NOH za+gFR((<&Mcr`Ya=(^dwvGn$J86-7(Bplp{+sO1~c=UNa@vb2*iX;9L* zBIj-Js-XNXO@k`u@DP^k&LANhMZh-Xvmg#=X<^m)P$5-g*0WRJ3+6rnosXiZVF!mo z{#IN_Sy)^uVlN$hfiA_#1?HR46wh>}ma2fusIJH)|9;Icp(!u7{-L0{!&^}T3;s8m zA4A0a%3G}|otfRkD2Kl%T4SVtkm{QX$5bSha5^&FhdawWM^y&D_ODFgR-`Y&^&@az z6pvB^$xt`W{1t6*bhUq&-H$#ilD5zo0D^)y>ZBT;X8uX0FMpkZ?k{@r_YWJuriDm) z@SW$Kr~3K#4OX)b+1&e~Muo*TT)Su`f*TkOtqca&1vawL2xft!R=w8oh+479CHf|V2S+1kE_EqqCOhD zr`3e8mZ{B}GKyE3r(a=7beY9gYpDnQ{rh8HDILzeQVGB6eYNKMNsJ0g1aUFuc10l( z>$n#0FnJWOYK9~p_o)&I6C+#{MyES~J4#hi#A7m!O>5S`@&-s_^pVB=FCK z|8epE+cfbM>Pe7qpsCgoN2*WcphpxZn)kOfIsUR#x?;Upqph(sb-AY6!CXA9GO+u? z(9q3fQ7Pt8^f9!KNHVuz^U~R8i!h(*>>1(@hxvV$+qM~qKZmnMb{N!#E6-qupCH5s zIAd>q0DMM=%0LI0LIl~_J=CYeC!Uk^nHt~097AEc#}fZzlE0+e*D&7&_m|*?^xP%f zyPty)lY8H(Yx^HU=;(vH_FpG?W-NZ73A2|TQ2xO|i-+pwZZuR8v^C`xF4z)VmhG%M zp?Qtz^9++`9wH-Ury=Tv#!MOJWY5x^;XpCg9<8e;2fro2@e|?W8!x;Iho9qD@=S1$gbqAv5s| zpuA3zMY>%Px+*qez@92udS9VNm^x9c;;lxTAQQG&`~6fE2tFTmeRZ9+YPaeX3fe}8?c_yZVA(Ey zSJGyiXcTl)_*}^NtOw9%+XhgGPIrPSwCx_cKp%x2N;{5YBS@Wm(C=awxNy` z1wwDlfC%*!ES|a-Er9hGES@*X6zXUy_U*rL`}GHn?ju+Du-*D1sdsy;qmbRO={e?J zO((3{tvKQM<{*_PM2B?!(v+A>`1?Sby?E~Nrf?3Eq4QE{r=Fpv0f>5DOMF9JY2;r4fh1w`W!;(ygEI1>W%E ztQJnQeJY?&7At9S|HaqeVO`UA@dFeJoI{w&nn$Wh+oacJ%!891ex1lP{IaV{YaKS!WN_BHg~U| zpqxLT@BW7TCu`alJ>*cJEC{7*1Veweh3*Fw<#)RSwZB3K4@)S=E(e%pp6Oc2EXb&P zJE)eS_>?XM1N)*H@>UO%=dP%@)f9Ty6~#6z+etqjSOEb87%;C&#}3UIc|nWQ$lPbn zkoZ5%9-;J*@+axTFDCUIh$MCe6QFxLQWovZdDIk|x{g2G)-Rlcx*J}!MXh_`!6%I7 zB&nAER9DZt^qmUJ#y{h8wJ;fBiY}9d=L@DMOxz;AFXv4$rj|cxJz?i^&+VkYO$m;k z-ue87a0MZ%g(&~$Wx98bLg=XWXgrj~4EeRx<2e74bgGu5X?5&BS&1f6b!Cnq(OEo&C*y9Oc$;}Nb(1O8X3|F=Mr(3} z2Pck?sxz1+ELkR>Om8N3RuWDpc(_8v)3idBOvxmre>A5AMpvr()LY&ERHA8KBe~)H zuhU}6)P~K{SiO>ME7P);<=iN_r$9?60i`||wdNXixwf+!T-!^_(q+h!p=6RTyMRtu4^!)HU z*XR6In?;M!VpDvT?AW_*e&{o>w{$7Ncj&1zzLbg7$qaZfslXpPzEB&V>Y^ldTga2x z#KZ1gw&Vi_8f;l%pLgjg7&sU*N46lPFCGtosI+PbR?U{Bf!mTG5lKwnA3T?OuJhMi zN3u0{o*m#0PM&e5%ko$JloP{m&*oA9#x3(%$lX&il%AUhXK3onMUq35! z#YU0b3dxW3nnf?_@G7@(~Rul~tgc=^-D1@s#gw;RAHSR4=;7Nw zB&)!mBN)j&js)UlQ?8Fo1SI6)j6SAcMi%M8xGMEc<46L7s=0TNW*)1FOyKBFMcr-B zy4~&)o~kw$p2@sHV_b4B7F=?aFUIX{dFVQmGUrpx+R<}Bh=puPR~Al};!+9xM7*-2 zDO^f5i$;yi%r@Y7CdWZyR$#umj5|W&J+J-+HYwMi_G1+hQ7syEyjecRZdNjpCg{jD z-6CRc*UIMxWRJ2F%|Ajb0CE$>8w5|qWU@H_PwWqVoUF&cHvA#;b18Fd2{+qy&o`RB zFIC+i%R65-w*f7ly&GMI*Z(cf_I=6rEtj489G*HKBHOKezEkeQB@(#*9CE}XS}*J> zlMzp!Y@P%0W#thRVfz)sdN#xcWy3ygMsp!p20t831?6BUd_ATE9Y3_yoL_$R;?;*w zzyk)#^?iDGNGoxPcQhOiEEvoe$%K3go`JKl76-nl$?jKs$cV3wK zY?1{|&Q6{I#p9G;APoaFeLkctp+uvr{)v{!g~2XAa-QV-A&EsyoZ&Uxz64^V*HLLzqx-UXYIQN^y0$`RHdqLj-u2B+Eype$E9Yi$CX04Cf?>A z#X43y=?ji--UEfH4>_rm%Z6|->m|lenzJgFVk_4J%;ymHN%ICBoh?t|yj>{cyhjkb zC-JMrF1n7#XRC>?a-iMFmx_YF#%XVp_>8WS&n|UQT0I?}N{M9*@ z0*#4~>Z&_qzk-jZpuihb{37?;CW5o~ygv$1yY4f8O~Cxhc>HM|syl&m6L%tss|Lkf zq4&e*xp%f6X>bawdcCBEA5=Xrh*nWJm8xI@P3ai6;vPcH8w~K@;y!xC{~5^o5hqL* z8s$v9&V^sO(FHufA;ic{0=jLa-s)H3_x5BKOZn8O+H&z{_l^Rdn@1CYtuP+OlSoju z9b8XdXXJSk=8(_(4TLpA;Yg4{M`4CmAz64GGDUjnVl3x&V0}J zoco-6`F!qs&bh%861qjir-jq}cU=wZ*{ckipr{?}p!)iPKF0Q!CV$gu;-oe%?nnEV zJBKopfnU2aJ3 zBhGU{y>*=%sDnhrl@X5$2W@U6?KCNmn+JEXxI!GIK?iFU#=-rQVjJdRG>4JM>d2-NvW0j33~$-d zJ$7$cT5fS~pEC#F%kbSYmbK3nmxnsY20wT`FrJ}5Z*p5a)ewi9iZow)=xRBcR3*Rb zX>#6$@Y&?N06ZoBQ|`m(%N$yyA74s||6E7z$#8Ez`%Wv;o^=DgRNU!X&M+DNdD>){ znv!K3r$dT1%-A}X3kjw4EbobFB)J)TN-5v6FT7fBCE_f5_W5~smoq8PA39lBu?fl(DQR3PQIW|eD%|xXRwhQa2N2pNObIiKE;I+ox5T2RI zHYPjFDd6#+)`9P@Uo`|JbMap<=Et87bIUCq_0Y*-?QPY=3weBc;6KVG8IO^}0|pxS zzm6HXWDB$2$1>{G<7H>RI>k)nYCLo!{_(n*jsIXaI5L=&U388xdu_{zB>s~lYex0) zMCNL+O1qnZ^O;&+nvCb@<4LImq##>$n&!>IOR`I!zR$d$B5*a8Jok;JnyufYAAVko z>LRFgn)nT%_BF}7q5ZA+TrltQ_xuT`V z+@8Ju@q7QeQe|mZsGtNxQvyy;BALG-Oyz%Q4BzUG*#~TUDW`DNU$DsO zKK*KlP;Z$Hk^Zt+VT9tw85Y!h`(&)A#&TvOn@Y3A;05sn;Tn}g39zFkK%4%|eTI4lHwKQqB|V1A=M*+t__ zl~jtTt_n>Az@EGY{>^c$f;lV z-p%_*@KfQMVBTPmjnv6&#g8H0stu*ys=++``%m9@d~NoAx5E0*_Cn#H@@?daMkkG- zVziMcZXHJvlwl1v)?KB%xyTdU!=A9FI{~@`^M_(^^+I39#xXWCd_~PH;X!BB~k?O^kZ$EZaU4wg;oMF%p zq`chOYzy#CXeuXUZ&NK~;zA~f9$>Fa>zs)%7!>`%wr!mb1?|>$n9!8<9r7X$srby! z26uIT_vWbLx2QqwuMGuLQLI>vR?(9fIsG6+(>$Do)R^KUrmftX0vx@NJ!S_O;#VBgcyn4%^frG6#YzbUX1uut2gT@Pd;>j6m-+HB7L ztUe-rI#utz?sYqQFV;NjLS>D_nb4bTF7cX0nfHP?Bvb+kA+A}P1AXd>uJbSBBvIPt zxLvW_@pGOM;KxkuIq6e2-jY2oLOcBTcO}YQ#3~ykzC3pxoy0NwzFU1?(MsOrY&QvT zc#i%pTD-$X__`hX*Et_PUho#tCrI#Cs+!2J1s?1ahp0$gyeME{r zP}XBbtS1d~E4C)IBGmNfElVkh9Th6{=UnDb`mE8Guk)i}26lbC8Hs8^!h5X!aC_hE{9Wk2($=H4lEDSmuOC*^87-b-0K zupa#B-YhCPu(rz9x9|RIY*I<3xA77wa~DfdmCbLw6fal&!3-Plj4w)}rOVD(b>|~O zz2`uB-sqV65qszU&W(wVoJ||es^M>&CO7PYqN>UW{$H{F^9nU~fO;^+Q6rQxQoQ_I z&$e|3_%z{>zcPX=&zK|~kcOW=wbZ_4v!%XnHe#0w{TdNn6bJ3`IO6N{sl(q^-!y2> z^!nL7T{dX8*|D%@M^n(fp*Jc;Py{_iVCi?gQjpQ+y8zp(+#|e zhB%C`{T0gr*|*IK{xa+S%+fb`9s1CAr!e{KK;BAYT%LK><==JHqj9X88P`}D^u`~H zURWJ|Q&P10U?N+_T72g2RMXp4Bf7|iin;wiZpO1&zd$|Hmr1Obbau{UlsTF|o4FYU z;0?G$%B>1KCim9nHPV#;9U50}uZh*iY7VSvgKKLY;L%DND?G;w` zSmc=Fgg+mh#;5j5%mJz;)0NlzIkUB_g`k zl=Wu9sK0u3LJPgX95?qbZ~19?k&?EserQt}R^j9@$gF&%1F$PbLG9};zmQGLyLob% zkInt;A5W5{!w<`nY?DP9u&mWcnhGS!*tQ|is2KaYEZ;YFU(@H3JWY5w$k4n`(?eQ* zG4@K$v{CWH-JflO_!@T4e6nQfgG)9AX`8K76+oR}2Q!nX-g;SmAyp@ZR5^a55;K4^hLsbNF~Us6gFH z+&||PR0o4|_)rh~^m*Ia7;-*QOCNgGrXXcBFT3tuUYM|K=WXrf>bbm4Az3=aEorl6 z%b;UV76dA89#K7)GnfWdwsB^iH(|{CEcHOl@OtOnxBtGfA_V>(99m|-@XsxO-5_k; z9sbwVjYfve)U&|zNw4J<`N-~m;gI8+jt%+9QfP6$?T}pMqZW32F7@f%+nVr5-8`$- zq!#8Q27P= z`n`9H`(2UUww>`>aP=T*9{Q!V%^A}~pp4)fbZ9J@phcO@CK-D8v=ky0pe~p)hlToE zgg)`WNl>upn_gW5T+L&L>3>CRd;Q-zyuF>KJrb8@c%21Gs1Kafmeddv;jR|HGW!+A zxYQjP0FA(;5=k)sHmzBaQ10HW==pQsOCCUDF)2hMa0jl{DdLR`gGR~Rp}y$*3qqvI z#EQq~bVCg>J!!tr`4y?nS!h(MRccmhtcXM~IEJ16L-S`` zIl>>wsr}M^YU~heqQ|9!vImn3(8+?^(^DUlFlWIw_$}M=(TOOw4*P)^|*S+)n{9-7T3; zpozzX>aF+M`;K1Apl&t&IG;cx0@-GUA$Dy~t6j?ONv!?4(bo#PiOrIY*J#}1?&0|J z+INY=;-uU~z%)<*3w2++3?M*vh=+?ohp$#nD&d=#^Q1ZrsFbpkqWp{K3sI+nv0_UC)L_XjjlC1bYz3 zpO5l1vU8=M0g6Doggq{-x#a>U-5=TWbkT>;d}ogHSk{ELaXFD$Pr;o@Coquz*OS+p zZ&a|k0sK{v_T;c(v`JPaQw=*t9)kx_{()90+*JG|omTYZUaZ!ZW)8?ZA)8upSK97D zjwkHZC-k`Bx2Vs7ISDN>iGEaO;!6jS-MU-HIfKp+y-|-Rv9HxU3V_|F+Z+owK>Ih_ z9<3;w(K{zMf{e$}CTyXFY7eU&?ojUtkKX*v1kNU!vF(exe*_#yyUO5K8uUnnQZwI| z!ar0@5}&?wdZ5PHZ%gp!gs2Xw_@r!JFU};XLZXtx8n&je(^do@fRMSr*7m=0TSRJLomLJ0m=kcxn@D&GKzgnrDzvw>C3P^;QMWpiEFz zx8SL03?!Xo%!8>qXESmoAc+Suw;zNn%@R_@_s%h zE9F7n-%^WalY4r~Ze9r0l*br8nKeI0c_RI3zn*&3dE(;zta`7Y+xiRUIVx@-Re-fK zSLCP!mh6R=2290f)DSmf{2=lUA-=}YeB0W4?q|lb3tx1_n}#f(&rPm1YQHsUPZmNo zwEae*E$wPse3qO_V!4Tn%W8&a@F_&^A-!{O&c9Ju&sEM}4e&5fLPf_;5mr*QxP)03 zxru%Hz{8SQgR&z^w~-=HbrYKPTMw{R#Rzt)5t27xCXnBz;GohnFqc?3)WuH?@{pFr zd#&GquLd20A{G?}Tl1gQ{BCo;LZC%ta-m*VFNwrI18Tf}XcIs{LJp5TxyPugIypN_ z?nsGy7}TB75ygKbU;MdBPZ`IakVE7j@;n9SsZbQOL8wp{#ZJ;Y6bn|SGheq=bXr@t zij!j|ee+Z*^qQ*bE_U~)tI;BAV#GVLh|`%`gUX0rJt?|3RJC{|bkrMq;!GBZ7A9CQ zYCH@Zd{G>-{?~F9dpDcZ^`m^D2Z|KOXklYJnIr6EHcA*4cQJyZ&^xz_$&qv;SNu__ zJ_DXv@~Rmyi0p@+!;BFXY(rivwPHm6hiD9Nl?SN0x?)e}^YAL2Qx*4%(w3XO+6v>Pv)gcpY&^$ZBxtX#p|j*{ zoIZ7kC02GsotJp(cKy`CnImS5uL4~FQ0aUos_be_dWW1qu>A?!RbC*Yri8M`6PXBu_5tRqDTjHf5DDc2j!-D?WB@ zwg$x0R1-18)lRn<&lJgOIY+a611m0Xv6I4%Y*#kT?MyOi0C@g9xbCG(jW%;ZWsA5% z8TCwOEr^`k!FaRz)T%jLOT@bcr(tC0NHasYcfU9;8B6OQSEp5(3jgH)1u?9C?J#QV z_uR6Rt)OzLON5&*9$XbITu?cYdlO!;Ey)5lG2s%lp(|BzBg5}(E}0q*$*Uw)VgzHM zstObrf?ZIsqc=3)z%CG@yV}<{x9~Tk`=8u>4cG@*>@spFw@+<7!Q$ldUty5N^q$5D z9to>HM5_bE)T>3r-YmLN5Bf|o=?$u<7Sh>IdD0^DmkpTLyq4Q?Yuu+8cB_LD4vR@6 zt_;nIQl%I4uqlocn1_R6RUhYnh5Y$-hZiHoC-KBr{|u#_`mBg}_a$m#JDUx)NKDcy zvH{<&iP8c5gX&_kToyigA6tPCgwp!9-mYB2 zR9y~VJLTR~=ktha(vVpD+97}Eg676%nP!amOcD_~^ectNZWCx(taxs!hcH9fGhOkq z1i3SX{0#b@ZquqkPuqULj<+11QYZs~bKX7Qk}A>jRVG7SoBGn4-e9AYa6L|j#+{zY zFS^YFO_so=v0}sqwoj)BbD(N}cs_aeWvGjT+|~BTvAo5u;RNM_ z)mnY|W+Tj@e06gembeV&pj1(>7E=ux)|8*iiuv}>a|G|GOV&Ho!yC4>_RZNl+FPOACz*BTv9tXth+`l%gm{G-11&Po~S!fl{W zfPxp&~VhG<0%&ih-< zKz(aom~x~Rz#^8I-qCta!rA^h((3Z>)McpKNb`mu;NoNN!Ep(cFYW*s~q&>1qjmPD7^jdSZEn z1O{%7aaAk?Rjn_>@0Se^F8Dv&WeGKIv%aODZK5!+Eb=`6~d`=Ce^!3P>Vx zr5=dHd&aCjB=K(yE0n=60(xR6DILRIMs5N^o<>|Lx?T@vt%%+zGo#q6x)lKV;|~#- z1EDWR#f7Ya>N8q&C1SHp5}UT1Mvl^p^m5Cat2=9GZiMqF6;hRz_fyH;V4Q43t~A~5 zmILZEI|rPo*6B=S+=>Fx)ZmYXBz&C~fTeTP$0YyY2h z)ra!N*Hlppq8rt?3M0iNTNff$(O8wRXS_l-Zwuj5V+FBO|J$4t5rP$}-37EZM9{%K zTiu>rh|GAbC>`+7wR)OEB(xS60cm__P>r^9OG$8Caw1Uwi(bAP)Rt^;Yc&_!(ez zqssPqJhVWZ6&4IN0#9yVEz|xdNZwwx0-03t_Mh1| z^&+R%F|z?}b=!}b|4v9WqAfY<%Ne_4g=`1+a!}(3S-cqqt}It@dE{C(qb;Y?$3%bX zM?JC0%otNun0jaceKQJ+SdJHLV+I)3xAP+P4$|({CepNBNRR`vwm`w>Y&wx;P)JA* zL&D|ul$tHQ5%0H>Z%WMiGzqn+t-tOag7`DDIh$R$$}As= zw{aADnB{Mtk@)gt=QsDpribbHa4bgnivfnau>H;!h$s$9ruI0}k}I)W3{N)qq&=@o z?7cJYT+{SYGr6# z*Ebs`Z)-&AqzMdx+VUPb(j=Pn_303*QQD%TGo~aiR4;HBbSr;EE-sExN^BWA5XSXF zoGg8xGCXt-0nV2iB`~DyW(hA=n8(fxO^r!e^iG$q_1s?nlHHj zx|q#X`b)GEq>3H?3AX9lcG=NUiM7J4N+zT);7>C)O7L?0@0L`CO;C-9nvUir{j$np zso8=hulQlLiv;GZYEv1P8eGJ?tgqIGlJ@S58rBqso~f}A=UKAoadNzn9>e4PKJ>Ts zWp2={eMD54pCLg$vrM*<4(x1ah8P&y<3QFzWe1hq z{tP2o1N=qot2Jl4x*9%2MESRMZS$~sbJ7LY25Nku{2oZvfXx(B`2xNmlq%^5H^xw* zlL@W^EatezKl1^r$Y>Q+^Oj|69;jw9r3{>VDgMUz>$Sw zQXl7c*i>lygQ&TR3eLKU+w-FyU*91Et6 zBRP-d*DouUC3T;7$pB}Kd(D`_DQ_0!R!nD+!+RKy))Evyc9&I_n5g7%G6OKs4EFU9@omhAh^`K81g|e=9yItyRp!eoB#B)Xh1x0VVlTumuocOPj!uihqjmC5(N$o5W50uL2d-5x(vD#C%-fvO^c8>nz#eC_$#Sd0V7&iaV$&0n$HUt#0qOyF?)wlYxM#?%YgGyEl0 z5uwD`HiQv74C6l8PU>VEBr*yqw8O`G-9e%NYeqj@Mr=Yt}$k(D( zoy09WZ>GNJHfB8NR2pl-+l;(J1vwLR1HugI zg=`3OXj8@KIjA+AU}X!tpA`ecLNfGiwfI1&`FWeB%PSvab0r(p=?cVs!9EW{53s-s zU34H%8=bJ@pQ9}o>!J)n$HEbAYXhrXl?hF$zvb}*-;UCQ%c)uoC#jN{Ee1p(=H_;_ zt95$Ew7Oy`+$N#<#}@191jFD%`4yGfs?`>9)te_rHQEa7J5TQd$qa}W=?Z-KAA@wT z)3L1!rSU6YkO}U!UR;TIN;Ev!(Q%|QO&Rk%A#42!NSU_jY?+){(^wM=@0-swmCEId zH;PCy7zOSwOK_I)!^^YeD!Az0$e!_eL;i}(xjNc_VUB@4`Np4>>hKj&i#Mu~pti(+ zRzD=){i*(BdXN<=e}$qOz4Ni_F;&BHHHF-;wJ;K|_Dm0Y;nXNEBAbXyxpZ{8jS037 z`JI9@T`V9!MBzm?Ft}+5mjh#Jrt2RG)|$uC5mI8Grc1^&=pEZD&mRe1i+;_M)_swY zaYCo)s2Y@j3DO?urx|R@P&aLij6mc=A&!cVz{-a>o6S%tuR?fiwDtP~mZ028+3FM0 zUOdTLAv4zH#q25Xf0#RCWr8s1jpj!7SvYOnR(wUAKrr2B!+J3kunQE9hXM%aCaSESQwebqG$3rlHO{`C5bMRZ ztHIcGbr=A}EEoYYc+}zh&uq(cfJ2O>GmjW0D8cS=hI$rra$ds0<$8;iZ(Bz8{cDPU z|6Pk0YvY6+eP=|UF0ksY-4Sriwecf;3|B#v1Wc3AZdqsPEkXA~R^8t0$qZ{%;Bl#G zjr-KR$LhJ1XiUm|P7*fyF{6U%t^8J1Ts{H_EFbYP^i(^KA<8mBcu<^Sgs%)e!exsW zrrfzFif_f~G}dI!Qe6UN7*tL)Z1MCMi_F*i!bJTqrlJI0)L>4nLbwZ|6D97<00f%J zVvED`#hFv}a;H$Xgsz<92AqwNHx=n8!@vvLZGo3oyYqhM<4xz>_*sm=D1H%d6u^)2 zA^gp$l-7M-7JYt_15rw(6h>*)OMy-XCQiSGfv<lW_B`iBF|Go%g0lO^OsnLYc@r~JPs89%lECesxuxlD6 zGLWa#|9ZhLS83q)`fbsAl&eY}nC`%c9rOs_b5w}9a*>55Ko7OiF#ZqTVV#HI21+RG z;6h^TaBjkZ5IvF`=<(}`;3X_AgkU>q(g-6}tf@@y8Ld>BQ*TG!d#xLfR}uOv>fMT? z8Ff8Oz%qgWZK(vzmi3541uLSb^RpYv8*`StOK;;!F5&w^2yV0=cb~&ZU{q`fPBp^N zyv>UHdjrJxclJ~Yv0Z>MX)Y=&CK1Ls%5LW0NE{Y#6zk-9y)$z%9#Cunk;^*r`*+kv z??S5_$UnuXe|z6?S<(tSrKq=%iJ#|t_$s_iM%Zd7)gxNT_*D=DQJloX)T{x4=1ZPl za9^@1jTImYhh(@xIEdZ@z}e*mX5ErnO@{1G*@S?O4I&o*q5E*(6M~-xSfJK+1=J7* zR(K=#s_QY(C-y@QxJr;0k!WB{G(APdfrwrE_1TBG*En)?g?OO($%Md%^1Vtg++KOy zmr(y!evrZ9!*s7^?mW%^>URfC8TOOpp8XGHcyg1~oaeAR{b_&QfmAWyk$KAb$bl>& zR3>Uw1k4~b3HMO6f-sH>R*8y{7z2_-jilY8OXJqiU{kK$iXZ+shsT+m`NuXXN^*_t zXoofMUiwvXa7VqzRz;mIOsw#Y%&~`zzrr1`$ z^)kz^w2JTUAJCwAplP?w;9g}V?48*}rz|0scuuMwbjNNb^v=i~*Y!ctuSZe3@pBSu zPw(Bb@zt3(Upgu|=orK`$7B*Uhvs<5rKkam*dHJ1L1K`g!&4Efh^MP6JC_b@>*Q;q zSaGjm4e9WKcQ0yH4L4i1Bu9=w4s$ehWj}bwwgJESqFnCVaw_odMFKlL0+~2CuT%TS zpnFnamvKORabKpy9|P;<0QkIs!EVVQptKC;rbM7x^U2D8FEGw_NXY0&B;IF4wZqP9 zM{MK{s?BHYxFtAu(-^5;GPHtp+W+dOj&Ul`?v#rcH-tK46Y~)U3#np@CKR~^bqawH7ct!VP*OQ@9pd%>mZXA** zRTy;^mkn6=SE2v%H>|}rHR|`pys7)W`Pg*ei+~2Cn4rLcF)4_W1RM$b4BA#bI9szj zxx2N;IrBj#Pcw zyRbrTTsHUsSS}+|qPYKF#BzP%{PhN8_iQkxvb1UXpIL}x#2%M}XlNs@`I|RynQ7;P z<`-lpu=P^V2;NVwN-^;>;IJ%lmI5WrVdthee-&3p=#R#<)NOhi=*6r&ORiL!X6s>6O2^S+o^<=B@Nz2yUi1$4qW!CBQl$37v^|HQzwbxi0 z#)Il+OrSBi6VK`an0{V|uQc6K`Cfz2kqzI-X_18nhU50F>t^KP$UH}l{fT~?uU^Mg zOqPyzcZIyAt~6E1kx~0XYvPVQXTTmyex(fO`{RvSBtZf-$AGsmZ$gE07<31_6*+Q0 z=yzUF8P$M?qSDD}(S;@3#J}o~Rf`fM?!GZgB!E$hBHlGPJ4Ri`O9pa15<)725|TS2 zz$|5so+Hc)93H!(yCt^7KGeZliy!=>M%?c|XEEbfC_K@NX;Hju{*F?p`@x5-Yxp;P zQjuHll3D^u2O-(L-zbDg2>r<q zUHaQ4MX{ctd9$k3jz+`r%6bD;dA4U}-uAS0F9%^L5sRHYI1IF;)4^-57ng7ri}>hE4SS4|WP z5CyVfn0eI+s?`#>Bvy-PWBZbW%BkF>(diho$aW-2&0ypV3WdT!$AS^79-n?;N2Ils zy)NN}jarHA-T4NW{_;-t!En40;}_}qPV*c!h9|Gei0y)-->vwk*VHaxPR@;PoUef- zq6fmVXIx&mBN~&AuXB;I{XuKuZIg{#JR{&#SY+{^l;cyKNyOBlIT5NGA%$ThY!LeO zTN)!rNidCKfI;8cI2XNey_-qhWj>N<`+i>3hAvd-v{X?NJA2-zic8eH38sK+4{FGR zC%U;WR`*>+Rt0X}wO-4DXD*|nAl6F$6L-zDla3+Ns+gtBu=|;KR3hnp2{Evc7Eg!; zF)`rw3Hq1If7F`_k=N^oKCnn-3K8|R@Rh?0LntYTVurUnA)K>Z3N4A1CQ`h92mw7H zwOjDV+hmS-BNJW*F22YZkbKF39h%n*og@xUd{96&o1%AL#>+xpKVOZAM{~h=2cg=5t^VN| z$Nl@22UnnhmnnA$^Qbus-X~?p86UgE6015AWp%$OucSaz0=z%8kOfHx(u|b9t|BA) zjB~a{YWr`hDMrVS-J}MYMWw88#OG738n}$4ruNcD;>&?s?Rx@k|G>rye;>UqeCorh z%)0ImCs=J(e1^S3(;!?aVgDReOq!vhLgG{-678tTo&r>q%c-M$VoyQ408EYWypi#u zAB1j~XB@6CRnPt7F(nh6Qp98v0CI`Jqhukzj1bM*K}WMYx1%+vyMR{StTgUOsWLkaiYV z_`Uf>ngLZYQV=#EHs&4j^`OO6HRh8t;W>j9v;9YGS&-pf&rOu3mGGEn=WooLBb|+^*plp#rnzyprHAVHkBF3P$0$zBO}Ec(L-9 z8z?>VC0eQ818~pEdTU@Va>|XlQe)ifxY)%3OSVc(^ z%5z-5GSLg&4$rQ$MTXs6D&Qu?3Quy(x|!wgn&f`jySC!4_L(4EFv8hF|;+VNYngEU(RopF&_gr5g zXoHRwBZ}iwrvoe8zLJ&{NwF+sA^6c#1I0+|&IC<^#~st%9|!*EiGppY-F5|k{JhRm z{GnXoD}LXfmou!(4Fvel+u9yYv(7fdra2>C5~Jckb#`Qx<39v|tN0dby`dk}W7xzE zG>V-hcVy#-BBrCi*e>}LlGXkg*d`8T!QB$wxq`zr4RSh)aYMf%G%&4KC|=QX9}d{o z?j64f<2}mn55F2!I=$zma;&*~`5|D{^OYr>BRW61!$=X*7JrVjaQ?ojnzs3byg;x7A!PB!>symy zK{#-P-OPuoWTl(%>g~#uN+XOLDclmwM{nvk^xtgKgQ#-!g#wnSzNl9m_^e}=itDdM zp!pBB1EH@)#BlaH+f&XS+$(#Pf7*(mhAJ z>aFJf@StNoz0lkt$vJE7ATaU#2dAL-Z>Epy?-oD@elIt?{q64*g7z2Bnng{({`m~3 zW+5O|r<6~GVihUMn;VSWHaa;CtpUKx9x`C21}gUj&}GV@C18ot2)Ys|6??ADjwBDM zs+Hw~rk}5vvR7iNFyq&ORyi}s`nw(;_8k^=4*3IUuFcgB1xlc|1kr`N&xa5Q`~2E> zMfymI8li-cBFb?06{E%->V|lS8HrOS?A0Ad_#EcHlJenMYc5}aTw<v^y#!aTsYB-6J1-5TTU#9~SKq%e;-;dLl-CN1G{L z!P!ynY6-nWsZQMRhqs|s2sWU-g#V<<$<5*pFET-q`_ZyM00Eu;yX_r%1L9lreeq&x zHt0xp;f~M|r^8&;wXfpY)P-X<+xUcba2cbG6K89Xp0x!x}1 zCaPCmcx^g}Imhh8jM~wETNZdgh?9E3Jj3y{`z)OuYa3<%ngIt^VXVlPV1 zDC)TvHpIO6lngs)ju+~;@Tg&T5* z=e`;^lcmKGU!I1{8M`$5Jo9w2B$M|Lke$WDT4UG}cYRst%`ku zogzls^v$8Fl2!H@azD~p&`_e=q2C&63&m%FPZ_Y$ZJoB*aJ~dgy_33d5S{C%pF4Hk z370^=1D7YZmS=ULe2Jfp8Q@5)lNz+U|9Jv6Q=a)_^v_l~|6F<*aflo#7HdF6!i} z$FB?V3Py-lr|_u9@!1+g+r= zcRZ^xn+Ft+ehMY{HU#=pNA31w4wHy7rYA5tPVIpuVT38_e%>*%-+FbXid}C!0(lcI zK)gL_CJ~)jXL%gM=v%q-p*yvA=TKj0KSy~tfqnh1%Gv1f3F@8(qfr7FR6+~~9#+Pr z6KNT{!76eeV~c0mpne9cw3dU2-FIm)tB98(j66igK?LLbRRq;nfS+lxrf@lgLi{L> z@m1_(Vbn3=d>N8EsZ|8HT+4m`>;@@d?D!TIyq-Oz835u6!fT23-ZzP6-9P_2ZCGpV zTtvL>c*jiXX%pD588M?Xzu{7%SE$DL{+mXOFg*!Uv1)rS%09X)7z?8bQu002XUkw~ zLLXVei!K1)d!BY!1g4TdqI-_BXoWrMba977F5(&TOHAuYq@5xCF_r_eHXqk3%l5yf5b`6NMRejZtP4KwMS*qc)bC zb8HIt=X%LOp8r#{p9Xf{OUr%3D8I}Fx`lo?Men@VI}tCY!O&UY{{BpS7z1y^>oCn^D32DD1Pa@RF~l$(64q>?i+!H@5-lIcRY7P1s1pM zK*&J2G_g{-k2N~`W0&Q!wD(!MwNS;Xo&rv)Cx#^kqgv(;Q>#R1n;k}XFDxK-X_6%JQE*2kQoFT)pED-z?Z&%43X0}f6 z`nMSpA2ge(MuY#T>{+fzZ=@QGpc#oog=u6wsv{ww`O7%9qi;%D(8mz=Cy=q9m=Kq; zefBjB`=>?YQ-Ff0+oCu~bPvPgOsA;Cq~L+blULhf<2@d5wk%;-#QYJeg`3*;tyUIK?b zBzf#?Mv0cYU!5Y&Z8urMY{{rR`N18yE^#)LQJA#y|7d#)s5qEyO%w?hv~ef6LvV)x zjk~+MOOW6WjXMOF;1&p$;I6^lq4D4nTwdotPtMGp`@cE&%Rn%bd+(|( z`G1`$Fhb&*$RHBd6WgF&>xeyoUVGazpm1=i+8iF&I_$+f9p4PNU)fp@bM%?HkuJM+ z@cy+TDgVJ)ugk0XBtCS{?mBEma4ut|s`9%yddzZUOFq1Hq(D`rGAH5#FHXo5eWoY$ z7vxCcdBxBVa2k=2z$LT?GF*dwmV-$T3W5fqwPnwx>gofONi;XW`-itvIwyUmlX3Zf zJjerEh=C%HmT;`Q(#mG2`#NzvSHEH6R>dN~Y6iRth=FPi{kmWH^bg-Ec)}?dGEb z-@s#i<#Q~l)j()XmWjIx*;lt=5Icqy5bMAiod5j6iOpMT$}<01wDOhuVxa+7934WZGS#j*f zI8!Q$J#uh3?nNaI8xmlGl7dDc{vcb3IB{9!r)Zxq5M_!YTn8WrsDlD9e#_Fa8AV=n zmAx__E3jft3z14m0E`Mm8Gy7wpn1NZRSgz^CiyAB6^p+0I50j1E+set_aX?#1s5QP zaS@T4+QihKrpx!ERB7C~?>-JpNRdWv+JMV8A9aTcV5KniQ{-TD(1~L=m(H^l#)~hrmq?N5lLfj>QB0cy!xRfyC^S{Z>;RQjAaBqoBtV`vWNNnd!)aMQ zZ9jfjRX2i~*b7Bz0b+fGK*5ZapR#)MrlVPz`%y8{WT=hL;?dt}DZSk>w-e1sC~WuG z>Zj9wFHW<@dwkuUvUB-@TPGta|BDKj!W5RGqgJrNg0cxaYA@GvY769^(}xCZivc<6 z0*9h_K_CUtC&g%9NHo+D)%ZIw4lsM3Vq6!1hfzlWSh~uDOsaAb^XI4#<>fD(Qd@x1 zFi0+^Zv*rR6(CRr5f^gPQ@)q%KC;x)iVXHa3_TBp?fy2v9a6akv=|P0xrc~!*WF&H z&?{~P^esoi0cc<9^C9}XvBVw51w6&u9UjQUdFqNS{7+>P0nGf-j-bUL&=1|dE6qMA z;4!ezN4L*`fbDzz=RlAFXhEt_b z9Inb2XI=_VJQYH~nc5iM9w1%^paF0JEpPWgMt8;6)P_&SP5h>Da0j#=!XMhVffEFUyUHryQiC(<{4?y{%Yxe0w zq2Q=A0b6nOCsF_{2Ae|kXGaMpsXi&tqK!o{Gi}{&%O1TJ6LDQdG(_t00F`F^cxPRJ z58wic0y8QDvWWEdI+b3+sQ{@~5G#gDrY;dPxCO@r4q$bV$vRHSkBcs)e?;*D?9&0F z%u|GG15^y^)MbT?Tp)P9$JQIS&CRC1w##=zB303p+&N%iARqJsHn5sNzDb^mT;|>q zD`kZTjv>%D4iw)AQqu%d0)0iT+KMt#n|vdgQRQ4Gz9)Gz^2kL?Cj(AeqX0t}I27yi z6pkaHDT97apl>XQsrVC6ot^{C2h{%%`ZeXx8^v$a_H>M7opwF!06rFdZ8czxo$nw} zUNuBKm`&>RV?t}PM>-L907~<|`5G{tt8X-jt9T6Zs(}5y{uMBN%C63rfK)|AGW&p` zhGNhH=*D6OnXy*wuGiSdvKV20-menAER?4nIAN_@Nj97*5-x=uljuILfc+~@!Vkz9{f8_B z7TI;K+E^%~Jn%FyT<`#Ac7TX#&?n$i5J=>Ye3k57G^Ur2WgqO_3UL#eC<)#0$alU+ zfU0%-n%N7rJlQY-0p#E&T$hEY&!M2s!;wmRh-7c;EIwGA>Zt1E#X8PY7^(r*`c-%C z5CC|8hBUILR|)f3R-dZBnWuOd0qw5!v+R5d1chn*AqnzWJkE(ujceVXMj8U!8oR{J zt-K+`Is}|Wcu8tD`8}4|`7=SPkdL!tIW?v_0C>->t3tY2(7?GZ_6)gM_ zGlYq`EA~kqL_9nP8I~HMsja}P<7>%R@ai1JO9}u-yinM62N;13KJf!MLTfc|RGZxCG|h+DT0o8ZD#`dAVu3S^q3z|{qukr!f6 z#6gH&&cxm;-%HCTGW$P2zDrKqsVER%h#9;Fo2gosvMysx(9&zni~ z=52G8EPw^M6z~8pjEfLlm$j&}FpxGd#q%@d!-<>R+?^*l(AujQ8$s#jz?|GdR0>-P za13PXvps2oil;W4C{lv!YS$7#2cX+51-~Ak7XXL{ah5_zXSO>{JafM$M*5IGR|06T z{54u?$2|iOjj{CsNXbkgBUvPZ4e_nT?7^%8e~DEk@ZfkbG1DoB8hZb zd2pYUPPf3Q@CKu9_zzo&+TX`DX~!S0ttoGtW;_z zNpG5Lt+|@HxhSBc-a+68_4BC8N?e-W^ect#$`9AkmL%{88x;J)_s2#hBI0ei zNHiP{E`OiQy%)YnZ{UB0RhC0QbYMuccQk^6@*@4a^8W@<2>)97e>W#rGiz2yM^*Cf%gn4VIi&N}A( z>Y+chDVId%d=w4U24@AT9E z1eaLB=fz%KyM5#BQvn1v6HkCl3WrQ|uTmzX`s+fqXnv5*MwQ-`aS`-qE@sWbI>>la$mgDTPo%e?v?lPjb@Ql=jV z>&`+!LGeRF{Y{evD=57GUMc@`*9ENquj>Lt@c;KiXhhDg=L0s}ra)aIx7&gO4|Bad zPY}d-F)l#=AxRFO9jpI7&e9FEZob-@)p>Ft#_PQ4yN^+h0Ch*QuhW@-n15F)lZY-E zpnlyMA%YV57KLfnuPn?^mZH+GuxQTX{)zNs(P^+WJ<-XH0<)3nX_+CUM%%(?@8A7e zabE$l%?=|B21M!8<0(Xy+xP2>a2d-wGcBK6hnc2Wq&}SceymA2)=;Mv4FdEG3(yJP zo&)lHZ>D}PWtFiwO*9J&!Tb?6qxTk3H$>QTkRN3^*f-cvh=_=gzyHUF3e<;xP1qJ3 z5I8$=uo~GzU~KXqas2)-7z_Td#QOh;_y6~Ij=F-=%6pXdTP;Msr4N?h6+Dp=NZ{RC z-H4R27s(M3`wPqpzL_7G9o`&C>3AIT9wK5H&((TaP7kC<)wzQd| zlZK~+;OL=jLt^W18x|ixL=~gV`3;O|Y9ye(5=FF{ zGZ@CUsExtEc^lj3?u$8-9qT`BR=efyRIoV#5x ziuZ@HIYSDjZ)fBr%wnMeOgiNX%H(x)qimEcDI?buuuBiWVi+e1xAyvawIf#{#q`pJ zCAYiNj1+o8j-C6J!N4U858P-cSEXD-Ao*iGbd+96B1Xj0L#gbcOY|?!!PjrVkyC zFM5-c5D563NBPEi4p?)vu9g)X{W90MKTNABp@to)EbIYC3I_%2rMp=kK^;m&2KUmy z#CBBITwwfoH=f{Ykon}`;J7hMql9oBJn8JCQ`HYwhkJ%`^ssFjCbY91n}ak*X_!D? zWR^axG4GNqNqNpeoje1~{GF~DaB__{WQOkD&kavs4chr7@@Lm5j?u|@!azY$A^hF0 z(fjY%HUCUY|K|Qlk+Ua~z#m*VTC{1hxw21ERYk>RK>OZW06>I;D-UV__7)j4Sx|xI z?R)pK*-s=DsNMyM)jP54DYDWi1~sN5_nxUAMK0-gmi}$)c7uB1q|Oe_fBE* zx<`oC9-9)(EtfBo{T(Z*?9C10nq&XyW-ysrJm0BW9p1d2WmxSHa&y<)#dCc6AVT-T zS0r6+ZWt1!Tc43iWx51|!4qCKwqU05--!T}t#b9nZN-BI8TpNC;hgx&8uSaImSevb%Tc%w3UfmEg$U1F04g(?n~;uFmHo}C-??8sFyI%%S8+!fi6V9g zA+-O&$#nSVTf^x0@3nQa$JVQmktN?pLaybfJR6b>8vycK+Z8TecWO;RpU4V&>WNWgs!-MJyA>NJZ=)#aXGI}Y{Lbn z^F4)@8B6@0j67ntEA9PdYBJBUR@Ph9q(+xLs-SxZTM{Y7jDK2UGsiYFZ}bWH2z;ag6-TtImcn;a!(qYoI(k4bQH zxz0`rpt^L3`!1WO_0edk32oj_=bH>kHPQ{5l-A=V3;9>)>&BE)%zGB8jk0S!uG?0( zwWoxhk|HMROQE>&vIeGIZPRDJID2{?toxw%w7Y3>WeHk*-a5r!%YJBuV}CV5E1q{V zun;L-l2$YcPcb??pk{lvBUX_1GLRBMd?1(d+)Hu6(`d=xTThm2TuL~`Bgw%&ri|l$ zRK>b9i(AcRKW&oD$UG`N>Y&kKSux8)EVVs2$DtfMk=+w7=gVe0HsklTV}&$Jtnx7h3A( zK!Q^y`u9>O z2Y7BJ>?kuQ)w}m$qT55(RfRX-NvoW&*0{0(oqv0xeS zxlUg%)VO=sCHO68WoY**I`!7?TPW@KR>DxQ_jWlo1>Hi~>~`H?|3v61Vm7PPn(-Lw z7x_%PX?`c|GXt4Ln1dhoaJ7Oz>RD*ASRGNVNXQ9~%cx!au)cDRa?1*c2#Y0n7aS$F z1#`+OZCQ}yrcEmG7?eWmL`~f0i;UQM=OY|4)#Vy69^G3LH*40TtjL?sJO>>Rvd)c* z1yn}X1k*Xw$m{+oepTtwF&=9bM+Cy zH!4t55{_50nXTyb72Rh#80<6XCJCZs-@LP1 zFMsLV2;awS5i%OZPfWKXHldu}SS3^p-!LVn*-Kt}^UVuU^Bjr0vB+A?@ z`hwvw-$DO^^?$>N8;DVjQN{2A&4_ECfDsJ0(MU4UxB^T(-u^goKYqI=aO;vwToo1`N(7c?JbZxRuO`q@>K(5eYXW9L_I> z^-0$DXoul`GVI$82=njEZ9IC}mD&0=X{b2>*2pRaw{Mqmm+|HaV}GqXG+b!yMv$mg4Hl{3KAD(FD|(}SSFdEOQ)_+&b>({ZiW@h~&35ztQw+oI)!(Y~VQZW0<~8|t zag--tIE);D9pB0C&=a;peW);=POLqqnwYslET=?A96qr79H=JGJ5;|luXX-nIMvMQ zRc&egmT;5~)K1M)+G}|H#r$R(xdT#k_EKKIRVzWToT}6-K*^aMLpzgbAa=KNv}&0u zndD8d+G*28j(N}(T*UMBl-qYQ9@BS=(pQJ|L7pNc$Pq3Uj|IGVgF3m-A2={#PL+H2 z`PAXr^2y*VK1h_BaV$PtyQ{$WH}#zs;zp)GMq9V3Rf zJYTo>CRS(NxkO+25+&zK?$k!J(WE}(%?tf&R$HQ`GOlIwaMhiC?yyc2N4V*UOGhG&@A{c8lliDq5l>5+%d z+MMG=F*_gD(jGE3oa;w#8=d} z(68oVOdRmY+I=qBUCiHc$a)>VlgNFC^#rpJn^ib6@$T`lQzfW$lXFy~dClOF4$?ZK zpZ3#U(62^3UODBEGy*FrWI0QrjPCVIMfx|Fc)(^S@wYbzKK@(i z1=Avzvr6QTgMz=Q%5Oy{4yE#YmZw&U57l0zr*v?MxIA zoT0P8bm)L_))xwOuv~5nSt059Y%ge63&j&eMbB>zckYRT{^`!WONsKy2?ZKDA)qk8wJ#wHc1wshX>FwWYj<$cY`aCU0&82+d`17X}Ki0*nnUGK=1_qrdu6Oc-1+DuQL9*H=o5U zj*+2lk5W;Xr) zlss5`DB6WnRg&;cd_ zX9)jQyD5kp{rMMK5slc)JA_A-N1$~|LbX)W+UbB^Ru|D_FDou9FL{rSk-s2cY5@R;=F)lM`EKdyM z&B}XyVFk^!!^BT=@*}35XOIkeO;mq4H`3od1*qW(@U)7z$f+<&*s)PW!@utIMzGt~ zEGLU;^0f+tT-h$Hcy6qOFRc7m^CV`GU%!Y%{+1HkupD6fXpcXGYQ13=^eowTAMg#e zZKCu|)k7oSZjn5`526$0x9IS7F9fOsO;^sH_Zx=>m>2Qk-}As|I}JAd=&A7X5%Drp4uul(W-8B0dj~4F%UT8*S#O=N+K7qHVXqFVo=tpfJ?Sny>C}p( z0k|qkhx%u$I;H%Kx7InaQ<7u7;Wu;#ggqg4ZjJmHC^m{!&5cvt2_%V?>$8csfgHTW zw{JPw%r<-?mn3*fdkT_Cn?e_StuViN0wR4PlO3)wH)4;{GzjwuE}GM}D`8vOCgRBE zc#8SB2xt%Ub(oj18+Ub(mU6uIH|da8t6X7TiiQP-mq^uaFJcdS&6yrJJ+Owo05_Pu znFcxKSLTw`p8}YrS}H|fAobdi%RJQ;vyg*!ZQb0*FszdbJV}%8xtte|1Q4yXCqALzsfxS zI9kln(z7SlBDi_Tl+WhAecYXu$#Sn>k3G>Rq;&yPdDzDdDy}Jfw8pd?Y#q$KI2}LM zpI>LLhzjj1d>e_7`w+-5EBtN~T9yn0PeVeYEl5_Q+*Z!30z)tm14f;Ks)K{0HJ4z8 z%4BzG&FS?j;5Fc7h3`dHU}a%`o|{d8Hr^t2MQurD_s8+->`zo`0S|ZYRa-fB&`Q;t z);RQFtsvF}xEVv06S3*7;xO#;Vrd}>&F>v$KPb(cz`sfg(oVmZql6k5eYCNxMRz z+F8DAo6)-JK~>2}L15iZRhdPCB4cYFy3@11OH~<>gIbNjx_|}v7{r^YyG4~QS2A;m zJ>`(4MJxg7K?T>oniq0eg6QW*@-P;!C^B1^u3Lx4Dl%?okCBk-Hi#3WA`|slRF=vP znJDt!)X7G+H(DVE;RM++Ud2#xh|G6Ykr^pY!zbws*evTCs z3SAXc$Llv=<9)2Rv=)IfLx_c5JGtCtc6|RiQhC$YPH{AQ5+&vnzI{eln7?ZhP@-&R zFoT$~a~CmB$jQCe<;2#oNbLJ=W|8%0Mso=@1DN#4%8S4$at#Cm(e$8?L@T)9>}|(6 zZsp?@N|9y;KZF&c2R_4a0kTGvv5FOjUV|#0qL`-Csx^C>>*Qa&s~$4UCn{?M_`n6D zOAhK~322q5YXt%?tR1iP6m=kpNDo{e&^~?kLyMKr^ut4uIJ&ql!lB`f80Z?G;2qDt zC2dK`;QqP0geMm`LbkePudo_-8fQg+Qf^f-WUc{uL~QO{bsw)89PMtVBC6W2zA~s7 zR!Zpf8^gxCb!g2}gXVd{e|ULf0CKn2+WpX`Q_~d^tg7iQPJaQXRTri?o!3l`waM4z zc5a^CR^8&oT>r+2%hBA{z0}rx#5UJzdURELJmvaczWCI(ge{wtc!alQ6oJ9Eqm0Fs zwl@Nm(hSWCyOW`h2AOV=S5fQNyl4~c`C}B>cj`5TE8YGEgJJ$YmIyTD4V%}pPbnY4 z&PCe&d_g8>zii9ZX`e)C2LL6ZDW$9L8qicwW5na=3f{Z*+VRgy>$n9jAH!=kn3FPU zU}Hx~`_}KfFKC{4&zLG`^AQfOLpoR~Fl)&QQd=f&qTz=O0o>R1_e?3s)ww-^>6O-& zJszQ-rftAWA5d~Z*{SPyS{+raI7Sp)6146Xk*mLZDwnw>hofaxzCA3OOT!7@WnHHM zh*L9lv{5BzI*rw?-m!M1P%3hL^-@WwGCSUZC+(|#97%G|&H>pV8u=aSdghtW6wK*t z(R)@<2N2tV)HlCL4+_%S7OPGJxV~EGo$f2Z4qrTAiTXs5#7c5F;of!m4*$fHk^~t& zC%Fe3fF{JgV({&`HD(|8;?G9YUkJaCx-~T#i6>XJQ?Dr8PqGKUws2Gl7(6cBM-aX7 z7pNwHQfda%d9$$FKg~aG_$?^GOUm5g^<7XMq5lXC=9W*d@@PG!!{^~Yi0Ln~Uc?^l z2fM_`Gk2XMWjl&BHwx}96tjxrtzWwa3o|BcwvCb7%&B(E@nsBL_|iJ7e}i94Pq8UFoTylLMO$R(-pwrN{g&n{Uaqo#dTyQ zwb|zt6QkWY$Tp$6udMB@vb#RXUPU;*?e+nlz>=rHcaoG!-fav5`BaPccP#}=yZ#A| z@G~XGro?Y&GNa1tZ(J85s?j7esSSNzWQPeY+TP(73rl9s zO^>5bu!h8^M{8v59Hin#tehXWmW?&Ktu?&~ghC!w}f)R*OVuKBR zE{Y1kekwfYC#DV@(l=ib`W7gLBTg5o`+atLYyd}3+$7~B?iYn>YD*H%L%QBWGSM$1 zBo;Jgzih!KLp2(>?#~O$!TD`<2wEY!`W8d7^Nku~u?|K?U-;;CwheKR65S(GIiTNCAKH&QiTNAA* zdQRrJ;jJm$LY);q9{4ZQXrm9kN^@4(+_#ck#tRT$)~}&@<*Q|-1uT+xA_*d719+*( zj%PL3J_CBr+=lW*?}$U2gZs~5tb(H1?ulSt>%|q_OqtJFO$XNFhBuIi9@P--58fuWvxJ^`js%39M+Y-8`L?dapNe{eNG1E? zHu<6=Hoah!jLx6&h2m~$F9gH(feDeZ9}|FRnFI$;mYZ5bflRLjaxWjX#QmXbd>5;S zFUeYWM4&gIU!*q^o{~=!D)W%HA`C9c5l_K3M;CY-gJ7R7AMe6TouJM+=FXrqqn;~Q zCD1W5`IA@k6ZD(6xt*b5tWK99mz+W}YHoogHsQI2A#NbFnVD-8A-RbutAqQ!ruCjC z%N;VRomVPCS2S}nr?-jBj`Nl~1))z0REA-b7X zM+^l}g)W7zc7b6+MNn(eegmi_1;f2X4T$s0Lzf5if?ha&V6 zSEPXQ8m3*EbxOrM!?3{YngP<4V#bAktMn3Hg2rn18R?!*pH6gY71PvDqqgGY^5_Kh z2a~S8akYUz+#-}eN84S_=ks*7-Q4xEXaTqvh1Mtf9h!5#AQ8v(0Cat5VX|bS15|=- zu{+37089p)3AOfsD14#Q-p>GTBL zOP{9$!QBSi{WJdK;=FZ*ql1C_TB9TP^efySJJ8$i4JT)X;84Iox0^0L<4`C6ez34 zPg8AY8mUlU`Q~kVr#&-QFT%{`CExsijzxY@orGm8Yi7WEXOhOg4t(A`T%#z~^ z44kE`%rCuSiu>XAET?p=e%2Gy3M3}PFVvD({AnAmY5mn^9M>@}s~A5Di)dwur)p@W z(qe`@f~CUB&tws5uIDsputvH+v)_lf=FEw{#g(d3R?lF;!{ye#@W8=p8eZc0=9%+L z5dLn>^^A(BWmwl&mmx5nfJ_kb+Tl;EzriR_!%cb_d4H z=gjhHJ;PsZbxV(!-TMHk&pn^`)NPyX%DN{jtUu_)99rky8?7g|6Lx=RUM6+PfdHW$xiC zKlR_Ti@9_q7EGeVs>)6B1c!cvYd3iL7Q5n41UnuA|89DzGNK@oG(b zl+t_4-FJpPYt%wj2`%FbdY>(QReCq+AiL;V^+1qNUUS_MFil(rP{V~e%Wd@DaFM;q zNgjAgKCp$VZQvpdN0FA_qImXE#K0)f)g z4HrhwW2{#SZ@GeYE}{cOT?p`#9l^tQ`GjTFr5Pi&bm2gmWV3TspC25UJ}6P{;>%Z-%F?KW5A4jBx2@NOC&yZsdTZklr6i zXAeD4B=^3*{hcVh=x~%^RPe}1t1GqGH62XI%>&r+Mt3C(MU4kTg6sqAdCSf1m-jI9 zMyL^jxTJ2(5#D7vEhzIJ-a;y$7(Quk5CM|6#Hq~|dL*2-d+Xd_5Z5%j0z1SW9uPIy z#YikjHLlBWh4>q*3#AO^iGBRiE9iHpm*LXAOJs$=h=Nn(XR2>ueiOntR#|J%*H>Ux z798oJX2_C$w0NsIS6)?N-M9!)Uyz1`2(KEItT6Q!U$bZ2Tt;$JYU@E21&@1jH!$Tk>yB)h4-9VD0qQPD9Rx)JFLQzh`$o}-jv;^sSiKPc4R~ zMC-_T`mu0%g1Ap)LP@f(y#}Tju?fxRWgS|>Ow4*{EwEV(e8{-jDt^5y?9T&5>zPhN zL^Vx^%oHA=g4(v9j#zaof?;bIjVtyvS81u=!WK1N(^Z?2RBI-=W!5tzn{j8d>O^Zn zvzpO1cE$60ZFH)K#|Os6;%mmf?!&-55rTLwH>&MOZKIsdhN$AN565Hb;R6gGm9V9z z${`IMsfa&RHZrSfGa?~tF^Slix@N8xkzmu5f4xYVi5Yyl&^8j6(*JBGcWB3TaS2sbnfFoLKU01ZATTyacD1~ z>6f&tX(*S){B2>SR-5SNc;wFC%(EEL1vCZs=H3s>DlJXZbVxjkk=qHTaaciZ_z79gBu|&MpNG(dMI<=WHB1qvwtQ2u zOJ?5wCh9R${Q?tGj&cuvi~*3%?qyv3m`dc7`C_i_fSYiX6k!TGRi|Df;{Bd)3ZNX4 zk)VkhnuKI0hb;0kZM=jRV)SvxQ=cIxB+p4fx4K4o2ofSC%}bp%w&=(=`EL39x}cHQbT9z6P7G@#f*% zkRtU=K{X2ycU}@@J!53gJKw$?qf?YsIC7!{jdto*axAPeDJ-Mt*3+DOmp#j`iovmA zE=ZjPgG8|(9gQlrV`}yT#oI&pchyNt;G^HvAAPiODo3oEevzH08&#f4g==si*RvDV zb0B zH>Jxby8KSv2e?$3pREO%o-iG-=MC61|Ogp1L1%-VLKWK$|g?3r(QGyXhyUR?i8qv>^9+&bR?sA&GcL(~pO;@SSxt}x*%BAqTv(g;``b$QT(#oB9VCS1VJhyX+?yZk0-lW^4 zbr&BoJVg>%l`j`mr#IgD4-ag>_`;ue9&9oO4{6Byfn3fO?^-c#E#AF~562f3k*)L_ z>g+*vOpPxrnWP2kk(hpMl<|FY;o#wqc&=49fJWibC8~g?%n<7$b^Juv=Z89EB5PSx zq|+C_bYCCXiFPO8cK!vet|VUN63Ojc&&?Tk0#8!5rcr0i=oJVaUynr zChLwgTb*L6DjWCdXZJ+!t<#nlJ%OU!Q*ECWmGBYvsJkqf46jOvyiV!uu~($u2>mH2 zPxfgB^a|b#7)&OD)Nj6M4x2qw{v{OC3f@fiR@%F_knLcleulb$p~Xh4f$f?xFcr1@ z4)ibSTabOSPuH&H!rVA4>}aJ*lUeeVePT)fUg;tCw2!f|7i#hI>I_==m_khiT=@7x zS9}U-g7Rg@rTcO%g`XVKPy4AndExuzlc>Hb|6L)~rJSrVt%Ptq?|S?X5X};_Jm@=fAUZtkYCdy9~y@M*$~0`UB4Sd?h|c8(dfP zb<$jNn))U*`UEUH`dEQaX<14zFMv(vw;2zbVK?U< zvhK1i1}WyjyE!S~q;BgAi!+>;lHgl1bFIGh)^`^Z zljf{4JENd1p=_Vc*?u+D3l{XVi%q|`u`Cy4Gv-{RiB%F$wGl?=o4=8H5+l}u(k~;u zkZ0~FVa4X@*uxk`H|H{4pPZ!*H^njeP75mElh;XEAJ9{I%5VFWYzaWwi-_&9=iGM% zK>zVzo$2%iAx1pZ6UpD1t^!ab|C;Ig*Uc#;_SwkN>@P2s;6FD?bJP@^vj4;{eXVsh zrH;bo)?h5URxK~(EL|7@Toj@Q=oB4==J#(Du(7oEW@6w-=Z#wLPBV%L{` zT0`$Fo*zUE@xk5C4D3FhJIxw9FKdY#`$I_@MXJkaakeK$`<5U zqHm`*@((pToqYcd!IXn`Ju}D+x`-ozInW;d2H9A|)7TCu{K}nCvz_qS-b&ZIpqO#l zv3r!I&AwlbHrKLbfxY&IQFBknqX{ZlCNO?%9u?Cf-6*|f1KW}QY34Zq>lA({%Fbt!(6(`J{6c6)HJwBe}aC)tlq&t@-W~W`w}G@*@hH zIgER?ndqVL0dhy8WP{7OO8f8Ua{f`iYxpyt+_Go3%b=#&L%eM0LS277yvR=m{B%Wyi?(YC70fqVR0Pvsv zBeeesip6SrcC#O_$4@=%VjFc=ygOqUQyQ(oIHFZ$o5k`oY3|*kDG8QVSq+Egv>9&A zP94&30z&S7C8y78<~?HhV!g@py_Gl@?c>NYAg=55RNy;_ zoPC)9DJrdU^=YplVijQxOkB#XDMy%DXYk^r7dl^ASs*algc*shNOBt16;DPcacHhd zVw=Qh7}XcyWKqde)< z*Dgayqn%X?M3Sj#DN<3ZvKE!#+T?=j9vHLcqZqHIE?-q`8))Nn=VuHqBIfO!DbMPGN zn0bR$O{JS~UbW-vbKof9m`_qSU-lr}cOPfKt*HV-^X6Cjjd(KfVEOMhp2pmr_B@w~ z%Um&svRP$vxuu9^%Sg9uxqE0|L^8!{ynIp?x?i3`8Qw&vgDV$M>p`Ai(KclC?iFWT zkzgq`e+;M1`10SFV3FUSFx!=?wE{aV%6k3M4vW2tDTKugr<&-)bOePyk z_D2+Xs! zyfcY0CtKb1`T1o4T4hKpzo&y{!QJVZ?0EX=veVW{tw`M0$BVM-8Y3^ZAJSEIV}C_> z9?;9hk3kZTX#Y0xO9zVSzrcupyAJ=%l63zQOaA9+NbSj^aWn6+!)L}DI20lTFl)_p zaA!GjX6VJFL;5VtVN~gj$#F*A*9O$~!F@LLj2>Rp#-lUmXiT-qw(7Wuu_31j2&X*5xq@*H#zvXqAi&oOA@|E!tCO^~t3Yy`} zCq?es*GPizqD=|935G*{cZUyYW*8>gyyo(u2d9+`z)#DO1~rfRb8rNf7ZDOT{t{*) zhGT@$-f`1~I3S0qWUs>yZvx34k;n+iq9QHWoX z$idn&uzvWNvhL0n=U}+PJ?sc(xt53tf?&&v$e>>Mq-Q4Un? zAPqmVP)H}T$<^yLtmo{|j(hcUdE>@W#!A^I zB2CA7*IbEJZN>oW-RjQRQ}wobbJ_Ku%K?7{#AJS~tAvJR0*S%@ofcPsdh=hv>_5!N z{}4IlJIw6nv842c{H=EU!githwu_ny7sIX=Rqm2((ffVk0hC02Q z3=Ti|Y@vy`N4cvVrs{B$q>p+cu-hjuhe^m1=8|WKpM~=Q?4Z% zkE`NEepU$=C+W_X4_CuO(k918H_jo6R&NYp>7g6@NKMUnV_4E&-=VoraZ+rZym)9C zaR`?enZ)KozU>Q@CetBV)Kz1?P*s9Mz3cn&&dXEEENhRunagA_bKOrIwKXDLtYa+xJ3r_I?XO^;<$9cRM!&4fO;t2Z}mduTKARE+~}<|C*> zbKTI0roz{s2IZZx^$`wfFxYOzD`Raiua--?We+Z>^sDWRQ3b6}&bTuLn7xQG0gCKx z9iZ0LBW)p41gf4@@M65zAnL;`9#zRUZd#U|SgRw&0IKC=su(P0piA~X@(0WhX3#gL zQ5LIA%M5+xTyONe&M}f5=>kzNNekrY%JywHU1S=){nlD6YWdt;DkK@~iXZ_bgjF#t zdE`nZY%`hNdn&(wK8e+T|G(IK%h<}gBwf?Y%*>EZGcz+YGc!Y)nVH#Xw$sea%$#Os zX6EttRo6`Q+^*`Xx;-O}G?ITD$=30Y9qV0hMC^EimTUq|t`H$IUufL`k@@o#O#yW^ zQ)`s3EGQl)f~S~(c?rp3&xiB6h5T)rC-D-&z@j+6K=!=&XNO=;=khr!$V1W z^-yoa!i1qMc`^*OO8v7hK%oM$@8 zNs*1Z4^3KiGHFe*Dfz5m&wL0U&-*id>o)P7A?dwAPNRB$`~~`tSau-6@1XyR#}|KFNi{QGz8|Ds_Gf4ZOlz4=Au7+K3cy07{7cN7k?>9pB(AneGjMZ9!POabw; zL8Zp{!5LJ4X1IoEH}`n~FVT6gcH>eu~4P%4)Nuo#d@=6NP_Nxq70j_IRru)Z3S{YwxU-&XY?ElaRSpp#b8-nvM zKBT`DA=v*cLLCVcwsUkCg9$e03s#X+z(@i+OOWz&D&>>{VuCw{41gsl)v@9Gtv0*! z&vrZYiO5ZF^4(#)5zsCQ()+&C1x^wLsv{YP&(C4HK4m$p$;KV7t3PDHo_3G7P`z1? zvOC?vz{#g{cvDn>j~hv?QBHu6u#knh?UKQM8v;JnO3ea11u{%$*6G24;QN`Cw9_3i zX$6irX#-8Gw{YJU#*6+v@< z7T`-x1pgcR1Nv`7>ff3H$SeP{v#oyiXq7Z>hIrb`c?>^CBvcu#?hg;<@5Sd_XOY-+udbz!`iS>4di=W6^O5r zI$wt;S_LI4}BrGR=n6Br8)n{;#w z4O(TqfZr5MFOryHDrb{3^3kgG>#WvS&~PmY!|G`~#b%(Xv)8Tx)w$U_>Jr(6;RT8; zjY!?zhxb_+*k^Ge52&2uLNSfmej|>L7_m9W`I7oy11v1ph$(X(5k<~&sVdYOWiXs) z-8XQco6`zs^vkevO3^+^B}RrpV;%xmOWmLnfx3{knJ`mRP#k9TO|@}itui%rRzPy9 z++AST(yeEfXI=#`vOV0u|Di{=NUxkG|AYZT{hxixf2%!+|5=`2y95XI2#Z)^qc2ut) zGAdlxx&HH<=D;EX#_7M7o%Z?S=_W%Zc-^XS3e~sI#S7?{X-g@fs(ums7)4E;RF1Xw z18Z>{HN+rkxVpaMw+Z)1Q&fX|OKEw|$lG7jT48R#Y<&H&UcH=eHb>_f!Pa@Qjpcyg8hY_4`(bzUod3r5?@YTUE7;0=@ z4~L+1RU7>FyEH&9`Sq&&Q8xr-QrZ?JYTD|ICfC0Z{VPiJbY#$;Jq3^CshIy z08cIq(;-zVaE~Z~#&=p6jtLcP60I6=#9T%OV@SQMZqITq-vGLYuq|CoGNo&Fc`lgr zncC~4?d@HU1Uj8q*Rx>>OeNGo4a?zeHq;kkdDx11ZjJ@6%uqYOsS-^wt5o+jMkR^B z?zNae;- zL9--SFNmzMxJ+vR1&f-dXL<0SCQ?c=h@K}D$XSp%ZBA%GTyl^(^u*!%SPiDai%U(K zCLx}^z@iH?#qkrIxYi#9OF_laP6#cLyHt2R)Udk|K! zcPxA>Nec17UT^BSHIvvFP5(>z2Lo^V`u}DB!}eGIqZ~W)<$qv=H(ycnWFcLP3}Hla zUj40Qy|4wFzs`TFOLbP!`|F4ck_H4nhpMVp3o{W&H?4h2=Znj_nbG=J^%s15Kv?7$ znCNW#2dB8#$!>Cw?m|qyLRqTZOs-!*eUBT_477CvHzFs8X}mPJQa-&a%DEd-XWvE( z<1z2#XrEUs6Yw-INA)Q5#*0-a`q zC6jiYhJ%G;Ko<}P0B;QG-!YfCw5ukat^$%)cD%GZ0y0V!oL@Ayqp3U7d!oBil;=2p z21^);XojB{<8)}(hNkYUVMyH{{8{Ipx^X3>{<1M*|4khS?%z0;QRuD}3{kg%T(w)H8$BP>AKRvHKjSu9|fj+EvJ+ zJKfaaBqSRE_S@`FuPE)nRo!edK_%`64GR~Co8z9G=}pWIV|0;y36)Kox4QKnvTvpx zHm^^^m*>0}IAVQdzOd#<*l-|avcxEm%y3GZGUiC@g3mOw0zox%`CO=_EtVr#ZtU>1 z3)=NTKV4+uRv`AGG^3)B$ZHqWDw-^(FV<@ zoDoq(RVzRl%SxJG0$_4?CdwLj1$#U z%27`1{FuyAvjM>So^`!QaHws5znAY4)dQ?<(<}>CTogCUv^4}a2YO^7tCxL}4 z@uv@z87DL>)$~b=rr=hW`IzV+8O_1yS429!&THLcuAnw(Ea8#L?d(acTo&%O<0X%U zaM_rj6<1@CrdPn-RRBIy_ngz4e6;f)`%wa2wD&)z7f3r*jt&by09%#IQqNJY5{|vV zo{+cXK`mP7o&PdmS%?-%h4>Yp&i}AJBM(6LZ^Y<7;IaJ$D@gS>(fRlL9)JB!#ee3n zxk`Je`JU0`tQM~N=5@pI^L>NEg-#+B#J6nHcQaagRPp$tpTv=Ym5*@85*Tdwpu)R?4%0W)3K8*33{l!hO@B2=P;r& zv~-CXwGfQ+#r?#ekL;VY%MIjEu&Qc+kq!!)m4x)r;o@>|^p!Z3yOpMF|C}e#56p{0 zO+k2F$z4%d+uCNLiR>Blm&{SRmON$ zQESTDkvT~&PfTxX#BtgcqV^^xpnrCEI%@`(>l6`}FFh+r3(A>xCML12JUEXA$Yc=) zjcvFr_Z*E5W<~v7;l*$S$gC4Gb5J#?s zUu!l`dQGQ7^kXCETpBt5TF>&K15$I>0Xv~h+D`mGC~R#pxa+N76gDv3w<9e@kJBYQ zb;CPZ`)**5a=EN@n?4>#b9+S04e(&u-^iOH1QKYfu-nkSB>u@2=W}fPQd6+d854sw za1Z0oP9tm`M$e3>oUC6MwisUYZc_fQ-FYrd`#2dcdIgRZ|AAq1_zw)5%TUljM)6-T zY>mqve_+_!Zoe>Wtb=BCY@5GwBW!9*JzEPS+(vwFN`Fg$*H4QVu~ni=Rbm zBZeddIL#X0&MdT0$JMt>g&gG=0(-v97w{_tAjnDx?>`A_ z{w~ID@9R^S^qZTJkDytTX6cO%jY2Yslx4+ZvPwT`Qe?8-+7)ljtigQ}o7wbSIdjZkQdD{JOtDxMTZ)cf%`vTt2509cgjGAb=ryVL`%hohL9w?w zVtPj(An(}%n*k~(d?DCA5WMIRzg7JTiCq-ZAG@Gasz8&PqawlsDMwamwq$YjsDx_q zIPwZxb7lE7lNZwQfeY?R!NWI0qw5+2Uf^qojB1ANB&bDNgep_+7gW-&$%^IY4TvV6 zm4xAHp$pRAzn+8;Ida;$&bgF-nXY(#Xq}0^_Hq(hXY0ey4?&LUmiED^_HJ3PUfsR> z%_sT?fh|&y(xzzw=k6OvuvL?v7H#G+0!yrgf~RZ<*V&(`{hxcevDK=+;jOcd-^)cpri16s>o( zjmBHlsXTny@7YBuIdpBfQ{cyEd=Wp>2G;MfKA5~n5RvcT^v5ZktJb&SER|MRen1D< zMm;qEXqy}<%Jo2<`r*!NF1RmN^!1h>HuY9oHk@#Z@E2qhgTzv zS(=H~?$XOP%^f( z3Ze1LPQRi%4{4#A?2Xfd^(mJ4IGKbk$T@QmGjo8Q3#98|tK-UgOP|YM^qPk&c<9=j z%a8mTg~u0u$Gm*Rf>B5k(kHq6bT5zQYSmw9u0q{`LAr4ksEc@5n8HUo4x4Wi)kt%6 zQ-K8ZhMT`q;#ri67TQ6&aB+SO`*`7^)hFIcfPAcb1AXtYvmJd8+#kl2Zv%M@9u#xr zn-f$1UbHciGrl5bTrI{}42ZqbOL(GT&3z20oA&6unm5ovfz})(_;U%tX6YR#^J7Zn z&i&M0dSrR;#U$C1cv4pUjb&Cl*jyJ8MDh)G)*8r58o`utlKrBRhN`1_?ZjC8dwHKd z;!`O>)k7iJjU)fY`1f6J$--5Oi$bIIjCkWY?gvn|35wj?FAUp|@=J9h?@33(Lm>gB z0$v3C1~dPHw4a=cenEq=U}0mPC^x)z{|cC4dd8`Vt= z#O^EN<-fzQvHoi+_Rr1I{iP7W`0prKh0_1UUqgz32sA=2;Z{B=IXAY2 zP=`wesi=vgmtLv5T*3g>&p+3v?ZN9}wLNg#@sFz%+$1%pd}d z4IhOwyaP3E3H$l=-eO=P33JsmChm+lL=nGpNZC(%Poja14nyW*t*zjCgjW^x?`17e2yYm6l%U9mKX+shO8|htIp9!Hly>}`5nd_S zyx!*&*p6rl3R7=3$Lz!@j|3@q8I`BA7v)uO35x=$XfQ$!uvMC_$~$_Z>`D8Ha|qwY zzsdBaIrF%Gl&(%M5R#Ofkcx8HnkAN7krq7cGJ*gTJ8|Zzj&c%)oIAI0M`hEB0mnhzF;+(F`Zb|+aiyL(m1JTarJ-8Z5T;v> zL9P&91`M|X_CH@;|6t$;VR z(r`rb7vKlHcsYIx3d?sE>6mSgS{%|qt7OGP1;?eBV;zh(#~L?&mTl)NjqAj#@k!Q< z5r>24A46=6TzXm9QF_Bqxo&kOn#-mKM_#~>F);1f9j=yXpz_hcmb8vP=-2OgvNvE} z+i8S-F^(4deO|!-tUQOA0O)<)@Js)&zo7rGcEbMov+=k0{Qs^06{MnWrKF7UbANJL zCU;t3Ic1C|=$Ov37#c-`PXZ1c7UnvAMJjmG+Eg!j;}}3Qr zWe*8ieT?Y)_pQz?G+j?REZsZaN1Y4qLq5OQanG-bu}7c7&#AQ44jS{;zHQf|ZR%#m zGb36TJqMn6gDMr3!w(;DwO+qsc`X0Q9Q!c_2N2ao}d+?7J3Z>68d(k-^K5ABsaN> zyfc}S=Fw*@*jeLG$iS3mwdQi@T>LFck{!ifP_ip<+FT~IM{TkhbTo{*QhkZ)qC>bkqEY$*-)mUOo zoVp+Rm?+G{LCEL@jPtZSvo`G*7R*+lrDlzqO^ejeTct*SpApNc$)eHwMy45FTV6cl zn6~*|pv5HMM4W68&co(Ti?}5oJDJ4&@O_LH_!ZZl1jRqA;P4{#>i&Y6!VpCo>s+PtN3@Xk(w(^Tz(8AE-g#A(; zbuSKMW_6tz#zf+@8AqN{^gEYG{I9G)tQRWFKr-P8;PNFrrlB0jx<>7l+qyrq_Rm7p=14WbXYNiyEA5%-!`zKNb;!9t(ssXS`;?wCPXT0jNvh(+(kGOt;y4ijY#M&a&bDKS&ZKpqNn>K0ZwOn#UL;$Q)qxy5 z=HCXkYz5E2@j#HD+$T^*I?dFf+&Bj;vTT(`6+im+?LPJqv&i`bSY-P(Dxs6`hXPg* zx@ObxS(W?(+_i76LWLF)cW(oOe$4#_>umF~lkv;YWVQBpYewtW*@x%g%MZNMr=?;J zKwMu{&T>nrInEeGM{%_cZ;C--8$h`Bis~yg0u~YT-6TCR>k62l)mNJm{-Vx(NHE}VRVn9o0mfLbuNBo$n!qx0V-`HX?)3e8W zZ7V2yte~R*3;5d*q-rwVaG2I`6v!UG4ilVmuEm}pvl&;qFOHCML}q#|(3IVdn+$CB zqlIe*MP?{jE{9SKSw6)tKxyH*X(uM&38A`aD<<#>;oI2IgM3gkLXAMQd{Q%tn|zTz zCrl(J(!hrtV60An4;217e6$v>DARbs9_cw>h0S1EK#qga z6>KhdUC=jyZ(g`Ti=asQtLmX8Crsa&FP1Z+k1;}^; zT@CqqU~Zxe6}1envhxUDmC3weZOHXOmgpS?2monp}Bn5scq(Sm<+>{ey}!0NF_*MWb6?*5#f z0r6vggg{}Bjul5=qlDcAs0}A816^ng-aE-zXzATHnNNc(RtkK1N;GXRR^-ka<%9i`%(-jdRuHTjlr$>;KqxP1yZ~n}}g? zbX}5=ffsItd=AH+tPSo0SI7~s3W?^8E-K}+62|W_U4P=(!UqUB9w_5F1K==oU@kr* zS)$$=@elR^$-JK~wg4YG;65v%aCjpaN@3R_b*=Di0{VcwLgZMHr+K7L=jw?gH@`tK z^+?}Z2l9rzvUd3V`t#PF>m~?qUEdyyCsPJSTJEnOG{2(K_OtRb^V-3&beXH#;?n3{ zYzR1aJtC|R&?~H!@`SSA!U?DCXC)f43D~Jm>r4%CWuXu>9#=fwUGe5K5s&W6x;>_5 z4*11uvR7?*X6?Z~z@Di(ZychX+l4V}891*j)bGBrbM3Bx2wff{mwD2q5^B&Ne>QdR zfxva!zOL1K#DDZAkQ4y)zh*oCE;`WB+2GI0HTYk>W`)YC%_3@0&jQu3o^@=1!4n};R4k=*`sR@NGsx#gx;lh~3h%kSXMPH7 zMb=>DFz+k0Nt}!B3jTP%2{|jJUQl$+c>}_XS+8=WwZVL+MdT5iQPP1vdK%Qd zP+nOU>&26=!~2acKqBINfBq6uU`TQD5-X%Z3R-q#pJOiKqImWxkTwnmPAZ4366=ZO zW1jCG3)0UkspiTlNg8((M>VPkMVgxnS5%*GFStUTPf1F}F5)7^U{ojsHI#pizR|8% z7T2yWHP-9r2>6b;inJ_!m!Zt*%@gy!Qr#3+qE3@kh#@>d2mZ;rsCLlj+l)dKKNgyn z+~_jZXiQX;A?;LDED#P|eR_1^{kW@}GSB(c);KRanxt5HNxcs2`Wn&HX<4z1%Di@# zzwoR4nY>U8xGO>liBJ*v_dZxC&Yplp8{yJKrsq8-ZF!)S}Gt z%q^bPLf%D}@(oTV_6MhFL^UhinhAgfmc%)EG8SiUxw8_bj<7CL<@FrR01LCD3u-fI z3NqI#{m%iAsU5bT#!J{;NU~>F-_AUyfa=D;5Lfe#v1~6k2wmUEJ@WfJN4r~eSCwT} zK;(yZv>{&YLMwrDrkNz<2xMOuE_(}n=*QZQFWf#Z=B+wfAUJKj({V3pdZQitG3<68 zAjrv_*rtLsr-Be`#}sx@z<}R;?tI4aL-_HP3CbV+j+F z0M<7(?4|cO)aOQA`FZrj%;C%pAIxC8Ftn2XEQi~xjDIq$+ykCD>H&_ny1kiOaE3Hq zV!u@pqCMm0-3ZCfN3z|sV|3UKuit3yYJLQU9SeMmFB#gI2Rp_V~Q^H*~> zFNP<*-u~^t=MRT|FCX^~z zY|_QjOwY{_vKmt^bn=Hhq75p)dV*_! z*FXe<3O!OZw4Ym$Jv6je{;|_EKhy}(2m=uy&U?cz$0M`S#050VBhRNkpSwPJKhHBg z873coI6F(P{Y0%gC~PTtE4cIYb~#y)rtrC6xocidGC}x}M(+ZQ4^kDcKxW*h5m%wG zqVjzo#@tAZQBVcNn%`Mu_Qj77?X!kF@LG{7n9a_pH zi748!q}H=w1 z+#pThIZ}Q5Bj6Ho6q|J zC3*}VGJh4G$>n3h?vfow)!gp7>fxR@S6PgMEGFfNxW87YPGc=+n`Boc)pjb>Tki*MA4Dp7O<#G95WzKr2 z6y5E6vt~4ZvXfy@`L9~REe3m~0n>W%brF$i&J=PHjT_Vk&US1+-E9V*gF!yN7VLLCC z^2i4Eck|VTExA5>IgJo$0E3rMP+o8<$xFl?+0ih!-2jvFJtUaxPN<7WK0}#bBWhPh z`B+sibqHJ0tpnLAI zC(BjKXI3yz2wGKLKBCgvMWiPvV=?zRfZWoxef1}~iaYXm>?gyBa}D+nL4rH-N0KBG zzQJ?SM>A05aP2?kHiVTM;(QN9f)botFA|JWaswYex3P1TM5|E{;m-|yVztz9q*}IU zq-JSOGR!@b=2JEwp4Si_xl-?M@e<*65cuV~4L50u9>!zty9|5qxn0V}e~>+{9` z({-04aOwEfDvvPk?P388pSQqm+`}~~Bf`{N_0y@MO}6H^`-JOJspb^b7N;yU@sdGy zs9j)Bqau&c!e-26jTVa|e)oag-^CvnTC~nAF|p@4TwV(cmsIB-`as-;kOO*MK#8vS zblwTdP)>97>amBuowkrc2PRIVL*=S?~?^cM(Z46VFWn7PzK3L;)qWrr^=)g=vyr^k5@3UbtQDiF9G0{{D6E{> zepAh?+^RqwK&+yv6>iah4rS{Pv4-+L!37tZs(EK|znHc)jdN~2Z+C9I&v5V3-!&+3 zqF*>Y|gQ8PiiCj6 z6%LS5Gi=h+Ht7Z2PRO12vlFi9M`*1{4>Q(xkU8g0;OpW)X4akH*P+{EE{eg;&`r6& zeGo4&6c4B(?_h@|KWWKIW*(~)4=f_@H2IqPnX#pOVw0hJQxJASZ{H%YybbUI zOagb|#B~i^^CBCRw~=lDen|H(T@u~!fhcH{SoPq} z@0R{E50gWzj!9H@j*vr2^oa34=zqu04~?Bs*6T>R5n-QU4gEmFt*qd~JZ^+g&U#rGqcY{W6hDCINR02+k?iE%58qzv$Yud{Lq(N>|e(ZD^)_}fcg}!-3 z!;@?6ve?zaH}ew00dsb*zWiP_yMalE2o)-zi1yiTX@ptBkHf!&uA_YjQoIlAR9?h& zEJ}L+vt=Q&<`2jEPvHOl#i_S{t}M&)XBr6rP@ytrvrB-oKBbydi4!K`P3l7FtU^3t zf|qfT2Z5MDqJnFvzgBd6?+BRTnf z9tdGxl0#0Gb_BsMYgRX3*XG^zSX7XstjG+07wVF^`2E+(aA%ceZT`R*HYzE*!w1kQ zucrES@B%jKuWcwD2DPICx%^fOwZ4(CM!Lts?|VfSBqCRZ0h&FQ-ba|nB&bLNdi)as z{{D~(zj4Rkw_rWIZ852wL{}Jk(^Y+1jXZt{(kB2X$mvekxPL-8#z*Xk4J&-oJRa`z z-v?(psU{o2u+1FEG1lsERA}bBPL;yUa|D7UbeP5VYFiZfxl9F}41E&xryt>P=b0`z zX~FC+;dey|R!nhWg^_>&n?k)5(VLm-on0a{_wQW){KRW9yW zHCQ5sj+B6`@KM0iQ=0p+F{Uq9yI86x3)T;|KI>CsoapD{km+NedD@m1Er^9J=5~ zq@sfW)EkM0fqmt*-(pTw6rF2SQYf=M-HxT*%F^1646ZGbEhiow^M^~QTXa_KFgy!d z@9SHQ&b-iyI{WV@ZWajWS!Zv=wU;Ma*1EASN?!kW&~{NfkVIhaIDGy!DlM0KfrLcoFT4lu1_bhE!js0#X=W7 zA5@TDN<-=h{M^7ZZqcx`n8D;>{IT|AW#L&G1->{j#?9{6n{i;;G!c{6ML$C^*&vTN z?j=R8V@BBn8x?^2z5;FC|2wFs*{BhGRNHS1_Y8>5e4fTmjAr<_{@^){9qEa5$k2qp zP}=XX`=SwCv};9hruRML(2*~%B}vcl6YP&{PtGL3)$S|XGx%?SfBz!?{hvShf1CLI zZ}Q&@Rn6@*=TRFQPAOh5sG@6MDB@758;vy^kxdDM$4E(1@8BxG8;RElSuMwBht16r zGR@79C=SPbAvDdP=YklVg3Y1l@Tuom#5qyS%vWYfsSA&tIAE8tb3mXDJIT4TJdEpL zV4^o3J3TsY*BvL@WI2rVB~MOHY?c~A9v;YfTnv45cN#yqSvP7KXExjJ4{(Dxk^r?; zf0+Vb#Z8{wUSLz>iJ{G%xSF_TZ*pSZxVSgW7<|V*n%Wx@jj*HCay<2Q8alMTK(ulC z4hnrM2uAysf{8f?=iW93?Nm_8)5V(A!kID(Fq4RtVRl0SN@@8m1je|&pa>P2P>)>D z@7l_NDj&tl$}(xnJPlEAA_;i6FQ;gOA${tpV}h_NMfZ7!UOsYD3Cd+b;hKd#dA!(f z+8Pw*SMt6WedY*+^KVxe$C&MKQSwz9_uq5rmYbW#OH%s`O_ocuNkunl5cb7M47=^Y zu^Gl=0s#XvMjS~vi%97k#rAd7uVgnA)U4^UaNrhbB_bSM$AYq^DwP(KV#U?e3Xo4f zEtJ6hJy#Xk8H~87h?F_}T~ujYrKAjmCiTX~;zpdXlzDg7kCbzd=qwo3O|8X6qRjh# zD9LTLW$mpp{*J_{Q!``^nKn!`Zd8XXHby(N4XZEJKp zX~+x^T7nUUf7OQG1bhg41$vomgraHza7IhAI%}0vPlVclRcs_S9}tzdcHU@ zb5*BvKY}u7ph#^12yYc_F1&@7n=5bv`dSq#oKiRVR0T<(`bfiSzMGRuH<>W!?_?Yk&dH z%a=YnOf)XHF#Ql95|QVq1(z)9+Q*Po(Fn#hmU*X6Wyi&>8E?qsuD$Nwk`3ne`6fTK*Ou1Pd`2?V8 zG-!!Dz!fhKm9fM{(8lnCJOmlsL4&1+*Rh%$Aq>sG91o%p!GLm#k5iG~bKJ;=n zB4%gEF?-x@bA5cEjRB5x1pXeyy}s8Z>33mdO)F(FD3W2z?~me0 zDvUx=B=0iwg??z(Dx<4QqRAT?%Q_crTEBpMp^8bXy_id)**`+A$!Bg8`n_nd3&sYD zr3#5bo0D3TNUVs1ACu6}8t+|@-52({tjNi#E~Ff}LA*hxJma~w3ef^^K!@5iPE#i% zbwE621HIBl%fu>@xFl=; zNGkRH1bOtA32xZ42CqOS?fyqMzCtFw|jCXi9kT$>)ueU@y+3kM7}~dW&t% zWI;Le1Ax~E-E>Dk?2}^%m?a%d>yTHus>7yHQG3b@34>);bwYv z%f#>(td7hh96N;9LJjd&&n38c!f4;HzDvPmm!_94FeXG~Z9( zrjPjFX}ktEQwrQudN;NTdt<3@ZHc$|IN8oem-Xtt+%)yBHIhmi{v%*17+*6j_cB;P zr_1eeuGbYbGgo+08)U*8lh-!nxB;i^SH<=?tXEo3l;UrQ(J`FIKepZRE}@6MJ}KI9 zhMJeglmmcO3^$sW+n3|7^cSIJpat_R)?`Xc zd`j#uCiTwN^qho~cvD?#=Fv@B3R&NAyn_w%`Ayvk-$i{LW6w1uz1XZD2$(&n`I)7Z zvT1lj+QioA)4QizFwB_xR+e~c>{XNT6KD-!sUl|p8kK&+K#E4bf4C4w*HI8b3;1GZ zDeuS?b4wekD`S@?=mNAoa}h7XN1`XF3tTY-ATASs(K?9GsKG|}D&PS5y6nM)@v3yNGyInL`kBuGH+TtE^EHw#Z$px#;D-KlrBAVtLbM%u?`*Hm8r=!rO_u0IHz`E9 zo?G~&V$%p3%0mhgt(Ni9sFWQJg)b_DMr9STcK;>mrS1I-l}Cp0;TumT$L>0%bD43K zGpU`FGzu#-{2*y7r+R6OQ4s5CjQY;`JoX<+5GXbJr1RGtQRP3JBhm-p`hO}w{x%6> z`)5MszifyZ$FKe|e-xZ`7rS7s_-zQ9MuZwEI`III2#bOMYJPzrNUWT1exZi-T4Cr^ z+ZL%;`SJ#f3y-#&dsk3^h(t0!tB>_I=CD&DTQk}Dx#ZC0^=wS}6Zm!QQrpXO>SdjE z@iK8=4o0(7fYQuLxzKh7%oAc}tEvsHtn?2XmLgwRlR*3k`o%TgcfAODwf~u zAWa3c+Ut*auFv`2%7k@ep47MS2rlFp7bN7fmViQqdTR zr=m#)`k>o;&>_mlYCE`iHgee8;MlnL6DnYkfmw+P^G{cBD0Ta4@!W)OE78wQ~Hk)Q9?Chq&_>|7wj6 zru~r8DG^|3iG-Uv)|($cWep}^TEa;sl&T~?(&qKP5U=D1@See3-?m+_ib_#GQBfTX z1epj-n9rko-M8o;k$@nW`{9^|KzdVF>6Gp($@^fV@>r&8l$^B*kBzZX{>F7^G725< z$?|>6udFAZFw3sw=Src*jTMEHV`x+|=jK{?OUmLgZk_x*ED?z-SLoj^(G)Y^uHbY( zKnj9cESIk)3baI^eypE~itYBI;YVoxoTd>CPxn$X^|eoe8fy4S7B#_e-!8p-{tPyo z>yabLqfqdIcJ^UO8`A&_&XMUfX_^+N3SA+MSgfuzDQ@D7hrtEYUqLfy^g(1h8>Ps| zRk!0zPb&F8?rW6ag^)=fdW1H4^2&44|w(_cx>bRK;_iYhU47C22}9+7UP5 zvL+=7nq8_+x*wa5CeAlNQ&5)+#XrDm2URjx0ex93Z_ncvK{V zzEZJFOU@GRG;_gb1Yk+v1!tFOZNb^^cf`OT4{^c{S}$GL|eqZn?}&&LPZS0(0mWvA)?ZL z;s~IzEHlfF-YdigK_{}32963B)e`&nt1xfV9PhwMvU}=z$4Fx15bVg={ox$uW`9Sg z_Mu!dy6qqbyNlc6L{1>=e9O35>r(3uRnIBA4lk=!z!Tc(U?))@LFar-PkAMG#rfS_F-GO2sz2Q=Qg4w!c zICej82<$g8>tM?lz@)5t&qaP>+PN{4rqEOoeEn_8GE1_Yz6e?cC4wwil4_Os(OOb; zovUMAl$DP%%>uoxYAZUyB5AM2V8HIitj@0X@x5}l5%kB%OkZ4tJIV!U^xRHKCys9G z@r?#;mp2miaDaHF5Wc}Ch~!-bAmn7D|NfCAyK%d~=8>T%iz1Teu05`eUqRz)Yhjol zN@K9adb^MSxCQ%nG93x z;U2*T8C#g8=%a5?@G-3?VP?MT3>xz{&SxTi5?+C{i0gbagP*9^Qbg4KLRAnnv#j*Z zI}5m-14%=;U%NyrM&%dJ)sm7m7V~*EPg7ep>2bK|vm8;@(K5f$#IKWetc zC02j=Se^9h579A$Hud!zYU+_*^ZoAN7ULf^-QNo4ea>)7V2llhF(L#Pq=O-*gF58% zy`=*~Cm2xPjeSTXp)J@?s;AB9>wFVzeeT_l88!wY(}ybBCerf9ObudB4FOdP9J2#W z*27fs?N%P{`(EC|fpRqg7OEdiboN{hlsz`Z*xAmrGd8sg`611^yQW4q7-fpIrjV&A z;~)%o3H0OuIAape#O?_-<>>}IlOldo2J*}-%G-C@Nk#O+g88ED|MoLqm+d>z3w;l_ zbm~W-7~1R&j*Bbub(Q$)ru&g8j%=_i^tCSc+a``rdR!Nu7v!}R%R)+nRXmm5o2keL zxIO0ex)sr*sC~ttq3z+`dM2%;7zYmT_y|5hCBcLHlZ@0^jb-QEpVQ*z@bxL!Ut>AL zUwy8>PfF7U!1~uT>n~}**SPp!uRB9q8z+5p8)Jw66_Q5x=kUlmPwE#_3CJ=t9jwefILNSiQU>48ma!{&4Q|Od$q6a*Dk_-=1XLy6aAs-pEnC zpPR3Mh!B};f6eNJ+}n6r2?@=eO@-PJP1$I?pe&N#8`?isF?Y&GlRRW*>|4u{CcmGt z9CYUbB0=vI*+H%2uQ_B5!_StfQBE#z|F9rpCmqbldd)I|R{eo6@PDxPR?&4}NtURX znVA_ZW@fS^i&+*kGqc5v7Be%mWU#bE^cik&}of9Ww z$Bu{{dlCSQ8lyn-rLsSxg=R2)*X+Cc2j_dl_{S%24Dc8A7XRwW|2~5JJ^e+VAzAZo zegx2q#RX+-x8wYzM4p1AiM1tpD6}WBeu`cn_ZYx!Gv%ZMlH=87FH05pZh!Fed$<@k z0H1Z+j9cgwxKQsDlt-N#F_Aa-ho0!7Z{Gx0gVYc5NorciB-JgG#_<`%jy?p(*GyWi z&s?$WMIL=QtaXeiR{89)`+$}0uv}0!Rc}jq`mwp1Gvho$E4nzHr9AABESYp^7Xl)q zbsuVQP1q3$1%oiH&A;0o9{+OCm`*FRJ?!Y}&f|ER_~%(a44Dyhy`S~Z^Zv(YEf2u= z*R1@119bMTmX?MNcBcBDf7-g;PYLAzkU!@72d4dZ^Oe8-@#p@w_x$&Le>eokqK`4V zRfCZ4Sq)(831}G)rf(Lzo!(3gjD&U^+Ut2PUV{NSre8x+@7^}CNGQG*tFYwFe$}!Z z>CqLmv1GLTY?=t)LyNhIhy9oLX*5KTk44cKxf+Tz5e~CTv*I9QETxNJt68Y~5v(Po z6)go_)bhOCNY(usWBB}UrL%J43MN9Q8qfk7A?9F1treCgy58mmNGROh<8~ae9}@tv z&Syw%`u)2u2?$@rk4Kdyyuq4D{VISTWycOyv-7j4J^Sjw^!r4b``B6DDD@A=X5%LTA%6X5Klii$k6hjtP?TD-BuU8aQxl9njp@cy%E!&MWda3UmkQ_l^>FuV#XC*grH@XzuiT!# z;`GV&s2*YTHo6l;3+yy^<>43Jt0q%0LY4U-hwHLy!cimK))jR1hqwfGU6Tk)MCYa< zcma8Sw3R`uT26j;_oHv0+uSp5n#RruW70fR&~?iXv-A8QY0U=3h{DUYT;q{tzgSN6 zhQdis5r)j{TvSor!ewK&9-G_0je`}-KP6!9c0OVqbIW;@A7bUca?e*wSm7DmwS2Qo zn|BO&WG#(<>jdaHiJ$M4BZ@L0(lDc8%&{c-umqba`^?iHgQ`uYZq6Rx4B4^s?e2bJ19_zq}fg1 z;CN9!FsmweS=bhk3c;sUgas4$Ha3=Gg3651tV|`5=tx3mkCR$_T+L;&o;*)3}>frzNd2 zsEZuOTD!REe9foM*8e&}>FDlt5O1-nb1Bw}*zoo9m3zY|&^RMAp?USR{lKA1nvxUK z&5upLs*E4fjXdr8W~VY)i!HlFHCzH=ex%+{PRHsK=aH5Dpl*2PhulgX1g&unKL`qO zjVx1rqq18~;`65=iM^EO9ySKA_(QNv!omSQ#g6RbVDZ^Esbk9wooRw3W3*8w9%W z5;G;$^#f9{HQ)UD^CN8*Al)Ll`t? zsMHi@xWg{xeLKV1vt}k=iwz%DUwMuahx}N?1*q)KPrWzsT~!!4e3`{=YPfd!S~BuOLb)o0g0}OYM1AcWfVcHX+7{A-;~x8eg~y;|bjkBRnfP zv?edMcC#Dk0Fej34a~KHiR^(%^NBODH9L=e6F%c!sKSn^#kdR#N4RwA zPYY6-Ai84DVL}FSbDc^f=gS{lKMdyftwKEJ`@|RWBt3J%b(tTWCgjTEyDr)EdHbo- zw<61nylZ{?Ni@a7_la_*vFQh^w3o0a-YpyC51x5r(wgwcq)+R6Pf8&cxn5YeAJJ|d zLp*$*FlWNlvKxqk@Fm%+g1N)0QgBOl1%c?oI?y@VNMmFXl@Ya(bZKL5K@qi+z_(Ms zG`lbx(BL-T3t*akMH%Ib0llU(RN(InIT$Bo&On~9kP#jxTEY-)2yOwc3&9I^YE}nD zirN3<$=u6}wgRLQ68Z-8(<8A)i;d2{d!*Svl=aX8Aoyz@=`Y|vhTnS3aQ@IGDMj;H z12Mq#IrDz$0};xtabPdjYH3JsAvAcjgA*oUwX-XExEsaYS~nQJdwx886wd$F2&cbQ zsd{uYRnZCxuoV){sM6pEabC4LI_(9sX{s2JBfKaC-for>sn2z2@xeJFSatRVaMJMV(_U>pM1}qsH~IDpfAa*YA0_+;{#L2Xe8=B} zKk@h3#LN}#FZ^Blj=$&EJ+>dvvK?CA@pr^K{+4d8=hVgt*NXiOe}70O{|$d9z2k2Y zN3@^#yZtBr&b;h1_OBS{6?XJ=@3=pN{AueX(vs1Cj=v=V!2fTZ`LC1`_~)@EME}yy z6}kTrN>~b_9%BW2+K}3TwwO%+{q8$jjBz;0^uWAIB11kcp#doa6V4e=#5Ccz+Pb)0 za_lXq$Fm_I0NWXDc$7hK;ijOYuZ6b;Bb9PDOEtT2l0_mb??wESL5?y>M|X&*P;=uOUWHnn-ij!B)n z8w`+o5Q(jTITU^nGnRfqRV2nyaJo7Y>w>ew|7Mql3g8kNXWT@cVsT{2VyC8jWDjf{ z{(9(T)JDaD0Dd_i;)QD*>@@4~b+OA!PCd`4kL~A)SKTVYUB6rT-5*-H;$NM6{Kwwq z{ltH7(*JAz@$cAgMG}8yJ_^l@a)Bu!*h&}-hDvRVFuB_K+MRW)8v-7;%Q_d?`_i)h zHxXVcQ&viE6Lqw>PHQT$%+Aj+l44+JPYiQYWh607urWvB8nEl~GB-jfl!oRn*_J!z zLp(ge)9(8k%Vm5I{nxaDyUvzM#@NS9OUq`*A6wW}8%dU3jJYze(o?9np+N$^y-M}% zNX{4w_(FCsx>EqbUtoR~DFuBL0+VYE9HMsCBAG+u%`5IsdD=}Lc#-Zv8Ih^o0-fZhOv5w2 zDHl%iJ>i?-ORstf8InS4A{P|ozGe7Ko&?j_6v&CCnJ1Ge9RW^=1r0SGn&5u^tuGQ1 zpmQ#BKwc;C)nE#%m=NGu5&X6&AkOz77Dlm>O5nZ424cOKvm8DYp*n#5IuBp;ZkpRH zh~cgNY@CeG+jWzK08(DnSbFP3l<9`<4YsFm2q+QztmeI4qAP~F3$G$Q&1@p{G8wrb*`dCtm{Dg@Ha3d~LVrIWR4u=uCfKl{E&Y+0 zuGLoT_4I51b8(^?A>aEuO8JvY=)YwD^UwSL{logJ`=33dmnD1N>!0(gvX_82f;Myt z5ZUdB#m1KtoTB-nFyd-vErgR_9j8wxp+UPmVex0B%UOyyYUr=e*_hs{tW#P;5jdO6 zmcikg%Q=+nPG`)~3wt@(x%u|K+n|bi^lK?(i+G;Y=FNXp7fluI2ze&M`|6@vcA#lL zEngOyWt&P$OLhT=Mso=?eBPS@p|%oU2FV_tM!#f_=)tO7+Gvbhey{fwq!Rtt%)(9#Y%EnQ704vRbfeB+rUb^$rV>x0q|DNaA1_rN~rXL;vQlVTlzkW^EwlTvm$&5~3M zFxylGWnHF75M>Gsw-@+lDU!_-gu2u5d_IX?(y)W=7onaJL=MjyaO#- zZ&y{Y0eWMQU@g)ZiQ2j@>xyo7UegUi{6G$~{M1>-vZE(u8T6z_ACu(6+K-wa)~Q~u z`L2HPuUYas1E<$_iowAJ#fONicIj{SS~=ANx~6*y<7XclO`X!;(yu@MgMM`{6mJLkw$3~b20AL%7i}cMoARQ- z@PPToNJ2$l^=Uj?*^M@&tRf^A^&DrN zINoYKUa5uUL%u(yv+}@jZZ$PyeQkjw10PA4a4QaAm;Jpuq1tCfbOB$)?mjLG?)wYW zbr06FrxPi~#>RcI%#2_A6WH&s8NU5#09E~~)6>6!5hE8mV>?|Nlh41E8vd)Y-Q!wF$ilai z-v$c$u*q7vCFwG>Y4mg~0uXRsG20v9BW!{$*$cFa6oXT^O(`!UVjT#7Bs=smV*uki zqFdhqPZR!7{C1dwCRH%n%UF@*t3WKANu5ip(Uq*(t?h`fVW|&#NNup+_q~ZeP@I=c z(u{=r;||867wL`=O{P^OGIy1vQ!PLw&NNo*H&GVIu&rmv>JQb*^KK*L-Q78 z;lgfD+rRD$yR+leu6hswjN4wKU2U|8zaCLtx}JN>m4!~#`ywwBc+pzl*F30AgG-en znPVrqHs)7UPI2KBFDp;1Q8i`Ur~WD(X`NkxqP;((pUTkxm{iyM=SoNaty}$lT>MA% zBdthjS^xL=m(-v>JQ=rkXJ9HH;x>`DM8YV9HJ2jH8} zW!{GdFBv1oWLKlLwkTLezSVeI62$N+ zi#@~a#5j_p9#{OtcHbfF3PO%}0gB-;N*uu$BY`q8P-qb8g{+Db?J zVHJh&drk_LhdNK7VJR0ZR*V>vo@F7n6n&JEp}V~q)lPU2J3fVXd;0>SLjC$na}-YS zp^EYSZj=AeO{xMw{4>$&Pw)1(-ESbj0#&&j$2)#SIJpk}LJgS($|Ye)Pyv)DIn{(5 z07_a8_mv1VHZ*EJD9BRPHZ^bu#@P9;2!sucml?lRR!P<`)+Ilc{5=Gj^G1_eB5cB5 z5moKZFf$FAtqp58RQbwNZi=*b86g2lX`jMt&M#2bJHM^xo+j)N-FHV<$g?!V>(`6r zB$1%Pc{r@Ne_m`$O7!LObD5DWaw1|*G(RRe>$xo0CMF!jAMl`*Xq^_1tSGkKbpy5- zY+*$b%2{L|qtbE=R%@!=`&#b>!XB{4)CL9iK|`R)YxGPszT572_?8%G!hoE%i+s#) zwy#lc>Hd{2l7=0Zt%}$*KJtP&D2Rjmvu+V9uYOmPow<9FajcT&h(2ZMNZ^I~V)RC! zM~0G}k&RyT&at0B2bDY;>o)>ey`%hOu)=U&L^5dYr0}F!yJNiBZqT(@Ms}3L74Z2< zN-!pNFfK5u&w`FZ#Fp_ly~S@83fS z#AUPW67d6ta2lzIG!O)W$OcLX?Ilf-p$j1tl{4Vz_->_@YTMs57z*0W4JhbGz5$5< zfkuF!*X3ut!GT~LyAcUpVraT|&$j>acF7$RVINDfx@Zx{vU<{R<8CBo-N<^D^0ZWb zyR0Y=`wgiaV_(-+6W-M}RxKnKZgpaMq9afgYlxY-qMSmJ^}!Sb-ac11jh#V=4KWOP zxzgR#pq3!AtV)~Tk(*M*eY7LcEy7D$$aYAIb?bY%mY505^W;Zrhp~gvrB(svkM}?3 z-6dxXhcQj&zI9YVVY{nwL4cUL8Z+o9vnxiV_W*w#%@zBKCG!JhBs+W9BVG#2><5>0 zj9Vvt8r#?y402Mw1j!SXLst{jP2lqa)F_QkNAq!{^6`9hQm^~L#XdFlC>T^uC%P~? zCQpIhV205;r0S{%%0g>)Da;gs!w7+%F1-O1PsN>5Qhjwmei~IAsP76FCi<}@`^V1h^f7GJJtuE*MmvfODKm-mo z!a^zzSAdIL2tHev7Qr!q6QCEGZo2$}&muSFD7)^aSNNoN3KaS`!rE`Yd=lG1{sY*% zWw!ibdzJiOMG^l?%E{urJwf-s_9rm>)~x)`;)iraY4c@%g!X+E8eWMFC{h{Icc~`9 zC8;Grh#Q@eszkB5*x8DOD6-Sa^D^ZcgT+Sz^uY|*Ya^$%X|!04VXH5KRl^fby1O{i$%wIvs>wl-r@aTV2rQZm&yU)RAPiBTfTngSN);bt4Q zz?=(hbzxZ10-#1ciEVK+dzp=MGjA3wScL#1UiY93(=WdutAFWl>~6VbILosdlPqpF z9~NMfnc2bzLW-*t>lv8#xnhwFl{akMkbr>FViTNtG+)a=`DUu12%z>nHdJU~?V=#C znnK`@_sPCK2_m!hoDi2*FyMW#rdawDVKv1t1M!FWp&KIL#iyfy<0}O;TsCr|e#xCN z?7H?l1}xbIgU*yH)(`Ux&1#_4#3X6gnEXS$9)|~sv}kr$hbPYDUZ>^y8U_)Q-o0?n zC)I+EN9m}~{rP=r22C(9pNq*mqWI%!&anJq2t%@5kJp%GI1nBBy3J~B%lvVh?ml1^ z?$hvnsi113&4chy|TaKu2U2yC;mn8T1WcGgsFbET?M zqV-Mt5K)dk6;oTwRr&qEML(Ri_BsNqr7}`E0pI#iPn|KVjf#o}?*N;k$x*_%0WLZt zfr8zFXyRb|2n#-jX$xjBDSz6$}07sZj9`KYqQL?M!hpxA!+g z`iDgZ&A&=r{kPuC?|u0{&tIj-OIcuxV7%*xFPO4P#F3fC$;-ngX36ZHH3$=+pyYwc zs|T8XtB;Q%s9`&{b)NEcxr;%N!HEXzje$nm@@cX$r~HJsOWO+@k`x`?WG6sCXe%U0 z|C@k#O-9LBr$z)OcQ;%)UYrR~rAKm_={mHvQDqofRfXvH$ zJZ*uu%;Mk<0wx=9>)(gDIawwMonl2vDts;9UECm%>M0pBjKz61NjT2DMKl3iu45I* zhXBB0Us$t&Hzejx6M9_Pd-tJI`Qm8WWvSBujIv-UPlGB#?gVJ}-bjl~5|U6@W%=)e ztHU~mnu9T&Fg_v^Lv#g(Rk|K3A3kYI!24DK>&>4bO_(W3PnQ8=iR59knd&qY^Q|K_ zKVO7sTCt{f)))C!@qzoF4&1{qhe1f03NQIM2@_*Md?u<%o(v3LBJExa+iopMtd(@9qPFk31z2=zw{gi}vQPMa~dRYYu{)Qan>uPpq&d z@ABa%^#m;=TVf)h)J{ZPwwmTlusGH9$06zLur%vV!G=~bI>T27fwQX;EA*=Lvg@XO z%!K5v4fcy2!g^seAik&{RHdW9dLu{9;J9L|G)g|%*Ti*5AlEMDj~PZ`U{l^MZDppq zFr#TW)wO7oO5mD(+CG_EllGW^Z=r^y;m1YWM4;(n#6j!4>w4W<_93=GiR=Ql!IAmq zZ-XS$W$FTf7s&J}Zq_J9dBXzE^60=Yy@whHm#)SB;0MtXrJYLxvC7bAr~?Io&)XF7 zSMxwr5Uvrqh50W$ah3Kr;gXq3_LdUDIhm;*ceuLK;*U9V1UrT&!>BwZM%#Jw zTwX0G8Vl%@?i4aGNxwvhKQ>2dBTRR8P3FaaJ~(g}Sl>Rli)B1>P009UZ=SE2sx;^| zH_6bowhwWiPqqV&^GIsA;wve{lC*o=L8Ml^ppOq#Xm()z{;PM9A~p15?i!aVzAZD^ zZt=;6=g8z?4dbglm8bZq<4~xh@)+%@4Kb{R6CsOUy+Ucwuy-Cud!zTNu-r4{HK0+tiQN;i$va?VsT+ZQahmm z2R%Yvzi5N$l$YlKSX$L$`zh(&NZY%9I7hr6wvd;}TBdi283ICtn1=^ZKy`-snlGp& z2JvSJ?S~W7qGOTwEM`cVbw^xA5)#}DwiKLjAtb31y@J|F`3Uv6(|wt0P~^;~L#vqT zn_u;kNKOI)>aj~y^SPzzwX(Y8#elzid4L(1PQRTcq916|0HowZ848$vXM8|XCy!27 znkziaPNrdtAJ)CiP#Iv@vj~{5XK$KP3pZ2Z15x{a;Uzfix49@&5;!^HM zT%5e;P?_)c`j1%=U4Xy1EA+p|b^YxkruY4!j_>{d*h(0;?@NPsCdn+dE#ow^M7Fn7 zBXRd9xtD~28}k@;3zrW~z3cVvgC#m}K+%{s!KqAikQr4=1cfg8XAkz6v% z=&1OyCc$7^`OJA!5z!bT4FrQ z%fSzi6T$AgMBt1vo>uEU=5CCZ zuN^YyWTQ%i{!NRqn(5bPky;wIS#?rhxNl2lU-QkTXruX`$2}IIJZ%Lp@CgQN_r(bw zmX*tM43mdo)CIsL3IPW(@{TRlYiBs4e{_4)79=P>nhB{Oo4AqrE@-q>q1@=d zC3^Dn2$jveYZp6kpbsZrhVM;IHFUl694+E&5rWO!|8zLuj4!)5 z8FoEDV>~hmiP|-Ff!bxHp7Mc`Ax=9WvDZvrK>QE~kc%d3xb+j+zEW-{aZ9VT$GVrO zS*ux)b$CxblkF=&#s@B6#93U7E2V?O0c>U9F7rIYmjyX;!0jusPh9W*Zb!O!92SnVGuy z#58|3h03zNPF>CSI3H|2+@OsD-C%a97ZImAA}J00CC;__y^Bc)QOp*`c|&I9ORFt> zq7B_y&ntVkBCu*zM6H1)fr6j3Ns{#1O~Al~Eq8Fx1*8WO{5B$Y=)eU#?-$u^CKn*t zmMcn}+6emxxE~W_^8y|kWf{cipmvZWYhW*U8?4W~LYZ6Rma*UtYuv z4{30~r_`cT$b+wEJ=7+^BB$DOYqTa?(w@8d+xO2RSJ)KJKAJm&`55@#$%V>-sC0}k zQR1ArRjoeMFM3SQ3z&^3pmko))X1Lxn5AGiemHhz$9kenmTA@H;RNxE96 zh*DS9>m`SKL(S3R-Wm1BOULiV54N8c-pgN$nTV^x8LM?Wlohf^16y};U$4NYvu3r8 z%VWUcPHC$Nte^@fR{0YTg?|WW_o-`+!M$lB4^lGlp03mf({i`*qojrbe79hMK2iQP zrN-fXvj4OHiT)3%U1NZMUH=o~&+GVocKFBrPk(3rAYNOFQuP4;ckNHPzuKSbe`|kQ z=Mp`F1n?Sgouf11r1)VfzvDlNkNSGP2``ib1PpzPVV0c~`~4_|!n9ti!>bpkIEX-g zNVHW*Vfg+lR|$H-_#8`tw&!KUwno6zX-bXce1Co&+iw4nix<6lZ7LF}zioe7t{8tGN%+t9C(iX+@ISAA$pi5JHT?RgS@>_zmHVHCuD?L+f8npP zS^mvm{hPn~f5cyziyWW*f5Bhfij;zxk{GAM#hfExr9e;IE{kQt1)e z&nqtwNx);OOj5;9i{)i4>D-0B+vyO@VPP*8NIV~NvEoBYxi3qdB)eL#jW89HG$wj5 zwRL*T-x3gFMLpaIL+JCcwE=_oGm7%Y<-janPcWCpGig#}tJ@J7m*;~+4yOo6I_=Fa zC#0rm)p_+ijjutLH_>p@*OfZJs#c9Xh(m!&)<)iceWs#Pf!L+!$^hh8G$-kr@d`Wyi1o}k1^_$pslYQW6^{9Bm7QAqyO9d48YCD+- z=wx>`NxnfNesx;~I?h^dh?GP%-S*(fMKrWoXfC#%)53`YW~C8lnQ_WS>0tK?bcgt` zSawjpQSmWXF{bMRK_T*G7|IldYa`6?kAa(qE#In#GkhAYPvCCWA`$^cgtWB!SRD?M zqIPWGMZnJ|r(iM(2CrzwYfrxJ4V+xWw&RG&z!zYzte#OuMxT>Xa9A|Du30cu&+)F9 zZk}JBzh)M{k!=-r{!G*g$`HBs-?M^@KcTLm{u)gE?@?Dj&Gh#<0oZ?_R!7Bk>t#iZ zh;#?b_6qaXdh^Em_HThJTcQ%v6BVaJoR9|&&OtMvr#VzLHT_y`q%tS$QY{QimwFk| zE&w1VoxST_!w7zW?m9x;7vGSrx!-qK@Tb(BFICu|R>+Y&KdjhyTzlRhS%o>UqlLBK zj!~(N6(^1DD$j&9&)TD}DccVlk9V5(8$daXpcDbX5274WaEC2{F^0N{e8_T*pAL7M zP2pFN5@$Pc9SooLQuU9{UxXdz|3ad{L6{uEpBe_$t}@{?(N#5PqG*@d9+EF{C2-(YvX^z2NjLQ)%)aglH;0J^luY zqNw?Jc=tOx8^{}=-A%I?P}g~=5xT{){PY2{8R;q*No{6^<#bEAk`D}8#q97?3)$x) ztQ5b3DJVT_aG*d^_B~D2FV4wIsrog_ z1nehP*z1GLHXS;JnF1+L_uHZ{Am)_3uMQhL!U;AQDswBig_z=zAaTnv7q(6T0#Fmw z6r(gtr*5J>Hx9i&$*XDKgcB?qxRo0*li~ZS)d)Ie%Z;|&s!94e%XTxAp+TQ`{}IX7 z62F~#2W;~)cq@DL=fo{7|QzD%n`Eo{I{1M_P5=IP|7A?r^sSqhf;EQW*| z9%IAxkJsk3W>53fr{^mZSPt!k=+Kp#w1#Yk#rKBowC7HgaC#U9Jo-GpWsZcB_UizK zu}2~|0iXAzH$gk=L!J-tJOD&8DAA$eT!UaDes9`9$ekuUf9m#cg1_Ge^nk$c_jiH7 z@9J>@!SDOYXoU`NKeEfP?@6?M;j$$Efaxh>Mqzlzpf@J@r4`oJ5K)u>{tcO zP!Cts)O+|G-W^FsabD-NA$X{BzO@9tRslc@c_Uh5O?w?=puvI zlcvXFUTkRU5gI1r(SLg?KMI@WCNZz(qVHFB*3!~?oy|_`bQws*pH8fuXXU|r;Xa)L zKgSoDI~AD+TT{^vEAWJ>;C@JAnXNu&cc)$=qV4m)Ut!+e9=~|+3iC+_Lw`|_1l~V~3ZbeZy_Td|_FO^H_mt@p*vaNN;OziU z5N6pnFpX2$roYu*;xdnxtdCw3l&QP_NZk}*%ulAOzF)R;YwnCdkmYhoa-C8QQzjXv zPEY2E<1!DPu{U1|?rMPMOQyMAx=UV<)nleUFP-GH@+M2z^6DL>H92G2Jdb{j;^N+S zpXRi<`E+PXs&-7a4vw!_Q!_mN zuN`cjg?u|N<=-Fl?NN^PH5AQnldsH2uaaTC&|Yijz*F0p!Ozv%?KZwlt#W1If#iY; ze?VH{1koSm7ua5E*YoDXKy_hwSx~51eZgET@0ex4DSF=#5BhmIgA1KZMa$t6<3c)F zQ>I}nxkc_k$jE&PP5ikB6AtG@(%L*|+qux?lz=b@Bf&_bN5hr$2HdS5@`Z09-VDQq zP1phgSP}EecT3z&po^>n7sIs&geYHU&GeiZQ9m>hQI^d^oYBZQ89B*!mx?B{KGQ}% zv$VkkI-=dQ*7PRmRokqxHn{=5nG-F`0ai}a;mHS{{RUKLH4S6=bbnvxiP{m$>W%Dz z{b-?zk&Z0ryFQOLO^w^>dQT>R9Flfus<;3{fw|EK_tSIha% zv{65cPD6MKT25X@YI*<*R zG9t67<#LMH990|>UxtYUiTrxoKfIB2f2j_H1&>M-!lDOq?fO1Xra;;3WBN3;K_^lb z(}W`uFocAOm8H7pZ1qJr2nf-03Uhu7Q2z*Xp3TU8tZS){A%8Ukt)6Go#Qtm|b*rGw z_jCo;=i|0!$w;tUJi{|(Wgt}taF0Nm$+xNg{euLI$t%w$vfknBN{E7nWxLBaQ^E&X zKE@C2o4~^5WHo?f6*5exCIIt&JEnv&tO1{TCJpTT1=#x!7F_{2)q^5)Bs=QfBKnI(X809diUF`!-yt9dzm-#3okK z?5D>A^F+AD(ZKPsY{YCz=k(3e(B={2)ko>$wK18p{D1+nkjILAkCdNShQ_`lCE;=q z!~{->aW34>Ce$#*(iv()H|5zxaSXTqc6vO9}W_}5amtdB+fHI(>21!gjZi?(J zL7gF`7=4Jcr)+j{P^{dWJ}+LCjE#pGjw!2FfN%;^29YWX+>*y7+d^Wjw!@UX7&EJ9 zQn1LjDBW{rc-rVR`%&ZUNlMlf_4dS+MTGYCi?Sq$=!7U&rbWls%+4q1RYuIi5yBrH zwQcdbf!NwZWK7LHue3}-3Y7wcIRO6gW;AP@luOAi<;)UxMiW8It@gFNyTK;hd%(bH zo7!nKAMdwT2}JH_C`Ks>M#co|1C}YejcTU{r8-WR?TN=8&MK2_`x~XKniSm5(ZyzR z3t}x-Z+4vOw_kS7VnJBmFwzzPr8k-!bLzBH1Q%GbJW1&*8Tl7O2{TaG#<^Yg7Dtoz zVZyMNs4R(#`#v-6%whX zRzIUa-&Wr6P)RGRg9Sck0H|%O1TkYDI#UP8iP$|s@smin_@`Do&tqxsW1MI`U7108 zCiytPMeAND4rWg|0DO<)f0k!8y=UiB)eg{tY|IQolRwS)V71%6;(25h@zFE+K6iho zw@EO@z}_~EH2WGCu?P~ap2SSX3JMbIf?y!vTPO-zLyAH@gDV@L|(R~^%$8$`sHGtd+WLY>${k}@^+bIX_Kut>JCh=jq3Wh$7m%+K2oF{E`_(D z-kO=PBTRwy)C27Y%Gi9(Pd0NmVlGK+u%FyjjM#SFxns(mss7Prrsu02K2T2q8$H;y zT?<&ms8nO0s%zPH<{#uptZZ#k$XV5#>N_g6VFw0;+AERL3D9Uo_pLlE8j2EH$-+PJ zb zF#okw`F|6X`k%<~_gOLhU#{hpt3!Gy^v#h=ptqfbok&q+QRdNxea{g<6t=-Z7j9R7 zHe1q8;ZM0CqfBk}Q&L<3{W73{;z>1Rzpes;Vk^{(DyJ!Di+;ni?!NxE;%?8xWO}fF z{|se$-TB60JeHQsVZXPcy)o-vZ#r#s1j+P}mpof2oyk%Dw3EzKfbaeBc0@u9*ST(y zEX&_Y-|fcgLCJXJij6Fy-)5?)LN*Ya7;yCF$iM61QVCrqi2R{Y*nB#n*n#mtmOQpT z<|Noyjpmt$X$SU+8Q z88ys;b3oarRkTH!XBZJQQVOS@ma4SsXixSn5M| z6m{%{n9rYps<5ntN34r>rqD<#9kbz~?A z42;HpN5>o+qUcD&IRGIpDaBG7r@iwXz+n!41WwB?)5vKu3L$==G)|Nqt@r#%oG77R z)uQjxhI2C7?~=I0?@TrOo%Iy1W}@qHs5X5>7!i9Y;5pl>*= zWB-atIij5#@mt{ZA&DDJBPL8)>zeFMO_f*H&4VzGf@2of>CNm{agpgsVeVZgvquEv zIU#(4y4*^B<_xEBO4ui{Bt6I58L0$O$3xHvOzeHE`Uz7^aoNd^BwkHRIygy$DmN1NT>bac15l%B9jlmQOR>x&1r!Z5ltra*BOh5~ zN}rFX`z&>PkEdhG(Df%>*p)w9Q5Q#&$HD@N5$-W8Az)$Nj5CCbJ{=rj6C8$(C4*~C zSF6Nrs;3aJ(xsKjzHg#etEsQHfdT`21vE@f6kO+@x2+SXs(N*6ZY$pksne$gO*0u0 zpW18WGiH4w@T}w1O$0q_89dHJdd=cKrV;Zug0nJ}KXn2r8bo-F=c_i>Jl!o8Z^dX?gPsZoMUZ_ZCUl9$ncaCMqZ{(SMOObDKX!-sv5r-S zcbbJMOE!UAi6inQB+u?FST+w>lu7C~T2D`Z!kSjqRP$D}g|j{@yGxurw>}mQ#{Mg> z;v}K8w-dyIPtR=(ZJlMPST-M0dV&mxu7HcYV375v^JPCA+IWOl{xHV&oG)miTJ3VU z5%ZYWxP6P@iEDPR8)$howJ1nrADO7taf%(c0`jK8EyWIS6B<;xiEkOoPs>LZV==kg zWEFCfb8jx2tEnjh2vbPR-$y%eBj=U4m`@+QOFNl1X|xHTm!)z>HpovXSnf*5Nnl95T*l6Rx8v0o6a)C;WQ ziFYqsB{V3W5zEO2$417aZ*k1+1ivyfa}6zxql)93ZmNt}h0cqHyY#()78kgP00*AD zh|jR}g)53EaAHX%uzjE>Kh{bMNK>}Vp^VrN4s!@ig}|~UR_oO9ix150$<ErA-DgK5PYz(hN7l&yRu<`OqvY%(NiV*-_R zZs6%xx-V zhmVxdBa1N1uuAf6Lu{ztgM;-y_`uZ5o#o+exp}0{OSm1KJXJZ@?wM?!4TgX89x87? zDPEWu8JiiEd*x(dB>@m8JGmjudro|2ob_6m2xv8rh>=qYq7bj1%Z$YE60;03nmY`F zG-HB;EC$ojU=F|rPDX4t$9BS=G8;9ks?4ap5wa5_WnWzCO?Lm<=6#&M96*6Qq(u^w zCK9_EvM9uKq<&q91~K|*VJfXppCeGSX>WIzYT>ac{ziWo<6V_GeR;@dg|tteaUv^n zyj?}ei+%|}JTdYWCB(q8ArpILXJRnoil#%yD9|qlYcyOVfr2v%J4Mg8${PsxQNSCP zccFSI@_0@RhGFvry08`t20|o7R7IkxqQa51pu~WkQbN5tHoiAv&N1(1tR_-`P(Icv z0mJB6GDVS;P-;-qnZ39mWv+h2ULIX6%yXhI;)!3nn5X8kqNC+tW$u>N1`b`~^Hfm; zD;aYACPs06TgNBsFsC4WuWC2)6k`p&=8m1Ufq zvs26JqhC09LfC9>oMM!q5g5_c3U*h%$R~!;&MSN-C50#mb6E9_I|bNkT+LhzP_B|< zU($nSv@nu?sf`T*8?OAZvY}d$9JU%Gn;#evlG6LY@B`WS0Xzzm1@48^4g8&_p-o1i zu}F-hGI#jVOM{TKrImSOR= zMG1u%OO}NNL=sKZAKExcS`#B(iwLw_r=MlQq1j#e(?DdwQM~VNazM8t?NEVeP0Eew z9_kabE<&+^rT78wK_gw$;;ton?5BEc-PaNs5p<|~zR|WR+O058{amccX4;#M8`(Qv zySMhw`S=OTT=^KZ?0PO?Xo*kMMf{%iy!lEZHGy_G$(JZ&YQ&!cw~Q8xnC*zeTrnMc~$K=0H;kN2Ivsa$%|UvN~z^ier7f zF_gbur_|`S5-6DQZt~7!K$@oEhS}@bMG#@OZ`PQxjfA9bMmR~BG2N4%%V)CZ+@U>O zJ&Ba0=-mxiLR~B^Mm4+EzEWz@wF}aBS8bS(@CqivoKc?=*Sm#5QTKpM(<3Y#*V) zvS5Aq2xqEE+X3CIAenrv_U3#Tn!0|~x&lG7l&~+-wOS#iuI-C47JS8U!6#}L#d1r# znu-{a*J0NkV^rZ-`jYQ(qp@#9l5X`;x~Qlqs(@IU<%TFPhcJbvRF*6Si+anzI@f6J zcrLhi9%FI5XIDs)={#3oEz5LQmQ<#6}Bh53>?EirGG0BNAONcUet{U3#%u z3F3P$r2Y>vCs?&*Wu8wg*Iw;nyc#UmfXKUW0JFk)#*=D+->shgMoUbMAG7YbFtqU43H_eBSOlO=~^J$wHcCl%8 z8?{zQIy$Y3?+xoy6xi^09Mq;ypFtgktw1TBwdZdI3`HxTFwO6Z zYptq#(%NI0W^OCyxX<0~Ki?!4Te}&S8ytsOsaqNLVd9(ZfgSFe8-*5wQn3>{8=(H+ z?@!y@`E2nVAs;ch=w1VKZx~}_Wj7AqoIkNcS_(QAjj6?M@0#;a$9-Ezdp;4P&Gz#M;-2=Q zYzuE~q%mgn%Pl|Zad*ft6m}DL{3zPtzSH5vg_!&7#aY?sv~*Xzorhe|HDe#~k^8P6 z?mWa`R};{lZy$2Grm^bi+>1BZO!!T}UKXWFELGMLw2-!I@oCYEVQvd= z=wZMrqDGEYaOlY?YmpFqbvG%+yzb5CdL2ZD>{jW{&yrJ$RzR8MgqHik;h4;2m(lLZ z{-n1Q7Ww+q2QE^v*cefp4jo(xD%%X}Skvp4QIn%gs}Hrb3(-|yXOPiU0pQXxq!~&o4&W)<21im0kKp{e+(G-_QmXbMoR7+o4BEqB+2w^eE75$Dg{jD zX;wA7`J$zV@w=es2c|5T*Q0&yqXTeiByWeN3AL}uLstgC$Y|;-7t8tgY6@wdJBWxwLCM*L~FCx zkTrPoz=q7}%LFAb&|?b51lB3J$wWy%$aF1M+o$_2HpEX0;haZ&Nfyqhj=DW=Fg8RU z+6{J46^3YcbH+E_uZi|SGY{bWxtxi>lO9mm{rnzyqOh( zGv+<;UHF4pRrxbYuPO$B7e4KFw>!iQ(r`j?P@^{j9vITC3L*icYjL3p#-sqOgB8^1 zZUSebXySP}fl}@+gAr8j<^(;CIXS^b_PInkv(&eT{TDq!GTa4EWM}hKo7gUsP0`j-OYsE zfjfwO!lGCuG5a);tev_WOFS2*XJ6ecllh9&iFeB!C^{O03m{D3o&7y!zRBRaM;p7{ zoS;l(p4ue3P@b#+si5aF(k`hfANWmMz6VWLeMmqBoKHGaJo_~~X*SIcQ-Buiv?_6A zs{`oZeY9t zzP6y9QszFHy@JAAYW?e!rW+ponyG>VzWzW z=LU^Xd$f4t0@w370?=$AfRlaN?eZaaw29&4t_OyWE}q%S)Tce%a9x3bV1v$}Yu<`CLAol`ytY`IL=kQwjiJyx_`RYl=dZhO zK%NUOZ)}5}V@TJFV1R**5A+)i-9h5D7p>Hu3#96uyqhi7x1YOjz-}1h2UsOHr7>uFsD|%Y1hr=Z_8L8T0fN3w zbR6C}0Q3k*<3~1LHdzy;#VIRV-e6h7nWdV@nr&>;fjacXu#>KYMFeM-^dUL@;@X*% zaXASVJE$@v(^}dBcpv?_WBP}qsE?$h7HSM-eN+Ks23N6R)zm3VR!CW&)dCWztJ%l) zV%qyhsL1HQBClA~hX(a^BZEv(@U4D92Gf;q9{z$1%A^WR$GC-tK?a-)R(BFYc}t;x zd7_JJjVbmVdqCBo|4thJntyr7bFfF+mk3fo+}x+Nmx;7}aYWVE2LU+dEV6&UJd_k= ziQL|6x;fw%Lp2KT3IT-O5c6oM``BA$54i1?SHxCY7R(2De0<_@0a-iT_RxD!a^!K2 zy)`E=njk6$vM>fCHGfsyr|WHJT(LE)ZF|gH;gT(NHVzI84+fTIw+2y5a#NK@V6P`+nJE4`ETd zAl~wE>$w0TnsY(tkI7d$LF*E(h9rV1<8+=LJg@-+=w~|OCw6@S`6trN{-|)!;2*_4+o}~WvNer9(`)$t0?yw zvsMgSD>=^SyW^RpVE2jBVO4dy35HyqW7)TB!nB07>lB&IGRSJq6nz$W)wxeZlcUE=n>5kat` z1hbA_TLoYgT-V#F=h|uSx?WqJl8K$?RYR_T~9Je@mF&#Nod;b6tgf}>l1zHg5 zfwIEAH)h$DZY;HTUDP!q<`mL9!czw5Mf6PQipOBvD+mP2cYj3ut^%}$c{UiaEp{yj ztkc~2*a3*TPhBo?3TSRlU`DA+?6g1* z-qaMC`{TDm0Li3eF`ro90UZj9nZ)f~INeZv7~_7=sdd;J#+||q!Tfu_-t{?c z=4-zb1K+i;+AlLc!@QI+_=<`NqHRUqxUp*XsML0m5?2}ch@Kt3a;DQ9vk_%<<<;yv z(Q~QoB0FCDd}4A_-EgeqOf=bGMQ{(@md)Qy2;okR9$(C!-UR?d){SbvcCddlG04=u zIPTDuGbh%Z5Y<)S9@4vj`fA4%^-Ur4KE`vn&2nH&!@CgmT`B5Bo?O-$Aw+pgU zXp>117=h{ifk}TfJ?vpJpcE^K-5PExUe|rd@JX5chGxf>^tLUpQPg&cMB9DjL8zC? z_0}o_b{&*R+BGrR7V3%6m1EPR!;>F?+?|Z(JvG7!_AHq$wE5C1h-Y|42Pg*pc+|+A z$~;{#pJz+NKJ$e??7!X-j3Ik=6B+jL79Vruvr%V$e5+VDJ5uGBmQ6!)N`Sh!?;ar? zm?n2~roL#|HHq1YY)3>S2m@4Yr9&ay6h(zAAtrEy6KsgdIes5B3+qy!c$&Wx2=FB8 zLIHBpVu$sX-3@lOiIc0|#F<`k#A)TnzI+-orLtX6b#}L1z@O!~VK$8gI$?p??_Z$= zO&q}2>Vh(fPu^ik)>R2HlGK`l5<#6K(~5-dSc}=*oM|iE+s4XYCq6d6-PA=7B04mc zzfU-(Ay1XBGhM7Z<`%2jUxK&d_lUFB!>b|ZFqYa77=6-NTk5;-1AX?Zy}1{^KJO&7 zY7`@;KmQMG^VI|X9|J9#anux9EjbB#XqBqs1} zGbVr@id%vFG294t^U9gt65cbm7aHai0H9GDfd+{o)7sd5^kv_ugK??-z`NlF*CiC! zrN(AbC{l?&w2yfX8TXZYQb(0Z9Wy2QUBFVLDo<54!?E%;u197^&zh0uk|q~yQ%%#7 z^EHx3a>u}$DN!}@5>k0{49mWud0k74{23tO_1g7;@u|@3L8Qpzd`{S8-vakpKkunA z?^Jy1_-%}HncfLE)E7)BVV~Z+5ZY^sew&qi`es{>cmd_9DjE4R(h1L$>ybI_W z37k(}Y#YX=59(9j2(Mn13nU{xISdgC%ucR=Hw3N=xLdsBIPtk8kszFrODwDS`Fql0 zAaIHp8Nw}1GOIGyG}NeY+7xqBibxQ-85$r0UF_!p#$*q`-_Yr%!|*PA2}7^%Uj^yP zV(VY%Z>;TT_cq-DH8upgPeZ?SmQj1?k_(dC$ID(9x}gqb!rj(LdgooXNY@;)_O5t7 zsBU<7-{ZG~Hwy+;przVM0O|0Mb2f4T9WY%x+qR&{5CZW49U`XQJOFrhB_NUFJkKq~ z?gmT%+!Y0Y9{9l*0g@5ayF(27t0r8FEb3Dvpcza6(UlqCgV{Nt_aO)=Y3Oy}6__^z z0A&LQ~H7X!{ zyc)E4UxMx-Xqa8cw3vKM*O=~=8P>?3Hnwh;&_cxYKIgWR#J}=BM9fPcI+PJ z^)7Cem|8Bqi!=Ed`A3gRw*Df|7Z(J?Qu?2rmWhC%{2QlbKNsjRIT-3YIvU&m)cg>B zcSh#*UiQcSl#ctK`%?@D)fXzE`1C?_IQ15-u_4Axa19%Gq|Rfn7h>+JtzNeBg^4A2 z#>5n8aG|Z*84A7TM=Vj175Da?RNRH_(WTPhvX!;wd~e2i)p-fUof__mCrbr+>f^qk zd!Lgl;tKq)gAHH6FLB$2qg%0+IWgAViZ>6x`jVxcbebU! z6J~!Dp*2dT5Jn#eEjr0SpJixr+9TK8W}P?xqKH9F)wt|y`?=fhbjD@5;K}TJBc%FX zgKjbEv|f?=uxzWizO)6}7;Kv0Bug0-8k^fg7Nn1JC_pAaKNIx0W8^42^wzVRbXG;v z2W1AN1IyopJ2wt<%d;X;iFhvlaC>GvKe7U1cys#+wq7veB;{GwbT7EE|nlXzc^JZvO4S8!R zLvbC;BB6f?(XIWN{Bi_hBe^cpFaqma%`oEOXPfNG0b`b?>U6Z@J*{t>l=xkQo;+!R z;Zm(1`w5e$kr!x)>}y?0M7jdP_v0dxJ`iZ}nVtW*FlH+XZN)X2;+a? zzW(hgFzxT|@W0NQ_lZNc{LZ6vaVf#)PNNzNB&Ohb{pu(KiT{5RdyucyQe zx1L8wPsRxlWLGlRA0}?s9VYl)CcZQT)u>tB3{tNrjS=9CpNtUG7 zE>FNMVy)B(%Dsk9Ae2}FNAZqT0WA%e`pp>5`!|#sweQAMqk|EnNnE?$&7rOpRaoKf z9-rgze*|AqI3S2hqwi3oBc61oAM99EV7fHdk@b>#R>@r!UdpJX2pDa*K1xEzrWO^h z%_~>>f9nf4Xn^>VXf zV@GWbP(~J(ylQEYWR%u;kyuc?{JKX!sgVx@D%o9du+)Ofsm+2sS5otCBBGeEq+N~0X9$8r7_20*&2;QAatL^ zaq_OeyvC75iz1Z?z4+ND@}AZ1WXe5l{f%&_0C!x~D+f2tD?ZdhGlD2vkkdg_%JdO} zI#uHu|Mi^&W2(e-YAiWr$6K)qEt|s!tq7kCj99Z7oX3=pY44|Y!DqCtt<5p- zgNebLp@3O>3>!_==N=`geI5mh`6yX&z0=ynYqV$1uoD~fXHsFhp>3W7K+vr@G+lTv ze&GAX;m}a@IHL&HkbY#LbrA1x*QyD;9;P>!$)Q9afe1UcVA)jTZ@&h2;&_s@19wA# z`sBCUb^uv4qGaF&3}N6R9#%j?f7P8Qrz`*25t%^F+8@Z!P znzT)L3Zff*K!mD$<3vwYKqo|prfW!z zje4Pe5d6S6jtH>%CKbVD%M_T&6bH1==z{!!+@Bt|;nUXxt@(I|RUKr7dSnu@gx2_x z!H{33M7IxVL2JyJb!OKi&a1hhJ`J%BoRJ6$Gwe<13HYHu$D7%~y0B>U*OU1Ii8acT z+`=AmgC6MzY;9ZiNbbpI;Vovc2jJP`t)38TWT|*$$8jiDE*))|Hik2D;Y2gZW#x(*)eYgAUp#Byw~U_ z_y^|i_#|AT9{u29+{H0;(HlSLV03|}HdlGxcl77ZZW%#vE|=U+SXg zF5M>>cu-^oe-h4Ena3bda#DK!IUo~J6#C&UBnU{*Kiwjw`0tG}FmbZ^xie1R>ThNk z|5^g@Z_O{rR2YHlWkzYgp}Srb!TA1Kp-bp;tKwr}Od^z}V%pC0Sbiccse#;mTI#5y zBc!NeS&0&51-F(+ADUg2n>Fu;1sj6_zv2AJB8=(x2wBFM6Cc^}$MaF8=0$N}OScNh zjjOpwBl*HSd8xaH8;h^s5HvP$9CG^k4w)Q3As^d-8WKP+GE1Nze0|f*HamN*DVB?> zv>zl4d0ZHDkhOLrfL(~T$Ac44pIUT1WyM0oji zERJ+69eG7mBpIpK5}1r<&Aqj9a`Bp*(^Xbgy_c6b2zvR0mZ#gjve@2Lxq4^Vrm^IH zUj0tH>&A6P1BC{GNiE`%#nWjK$v*WE;ds0o6SXyX)UPmcGQd9%W**fY-w1^-ja*Hl zPX%6M;9w|cZt8x#6iz#P3Qu@JZzn01w|a$N>#9CqFoy~}Ay@en-bk=mLYU(nTKTpk znb6Y6$Oz_MwAG9-t_8Bp!u)cj0Q1WLC?2-D01dP15vy4uoJs*U>} zS^q1@4m>k@^GeI)v`x5l$y0CyX2$Hi5g8N9;3toHVXv`WS;y+_+$nY7augJ^(}??&&InfW z4Q8~Gf1aQTir)z~sLDy;xPeq#E59hcbxHi>9+X9||7{&CiIE?(S*kz%^(`6AoG8+`*tE!__6zC2%zbkeuiD{=Sh*j{zOgLOR`u1bH zrR84m$-eQ_u=fa8OX0-a+A&W4V73w3ii{WkJN(l zv-9H!pm9V;M64JSvBoun-!|dEZyt@dnSi;CQbEtBmE?*Q#_zdf)Pj`(m!wL|CN}kZ z)!pEMW)bzZPxP~g*1KK+@g zwKXEgtVL`RyC!R!%;*r8A4#Cw`!I7@WAcx(F!Q@OMwYlGCZv+SplXmim>L-(auxEk zdbjaDW})ojA}mIAY4jw8Ss)L{H3ggb{Td7jamEOHyE816eNUoiU(xs)WH>79YeWRL z!?gLu=#xi$)l^jAvKG%t3~mjgBWSqi(A(ZrjbqZ4LNX>LIW+5puxk|;(jZmlB4>j3 z=YbDwNf}=(T~rM3H4cuhDqfizZ@=4qnu+?h=iE?p_VC0*-7L%+!h^JUnqsI58e^qu zTQ{fq{hdS`H7Cd=tqNCau^ZHi|{SuEa8a4P-{vFv^I# z5O*E&jT|-|)(iDVP<2VS8B?a(_Af2!NR3F9ndcN9!sK(J70Xyic!!Y!Lc^8KG??Y1 z`U!Y+GUQG;?AOdjCh$G}>teb&ihS_gi0!g)H$HRxUOG&ta%VPBp!a>&5$eYQx57az zM1dg;`wU+3FXqbEpQJwPp_l62E|tgc_2MA3#j?haZkFd2aLW`8Yhmx##P0I>^UhkW zrE^BreKuG#RLrFU!~f{*Ul@#;)EVHOHUm&u+X#zK_KVUUn{S9-yT;yVFy!G2e#}o< zhz4Qfg-Y)YC-Fi%-&7!%aor(8W71UJBtjUOJnu(y*brgQNq^}-SX18B=8Z_R4DrSk zs8!INi5P!v=vY{1S%u)_kY*B(nsekLq9scp`k3B`c!FB4MStqv9_V~=2M>ohz=V)% zW#xv6S~cq1`VhIT0&=7r^`*dq%|Mx~8?HtVUN7t8*`dX>U|*}=D>E8*m$2rfOyihE zucup7BPo6EF`^uxg!^lIKeO&avJA9Fi3&zFmo2mk^{_cROTTo1L(&Ow%S)+#C?5?P z1ti?t2))(9CV^bmZ)TO}RPOwFXcnVTc&V>K67>$v&g3m7`#%&h*UyY$sj!_Fc#7fJKx?%=Lt_#li0!d561hL1(v zn7q6E;jQbW$I+SFEk%3w<2tw78+3;vZBegP40Z%W)N`K^pG^}L6WZ>UTQ^?kHJQdq z63R7UO3wf)JySQ^id!gn74}!*J)LfZCVBEa>~;t6?$#Ra(X1^y((X1}l3b@i<>Y62 za6W}Qt7{?ac30-6yA<*Xi09qGRlHiX>9)OY6L#+isopB-)*+tQPr5-%f{P|qheyxG zc|$mlmaOx9s)ZSiV^vxuO$yN6S1ech6F8|Q0$QL-*f!B^G@`bJ!5%iYdPOyPMfi(L zL%H+b#ZIXS=e^wQl_YH7$T#JjmC9H{A|CNJxS}18<9Z^N1$dcI$Kc~FdXIAD5u+8c zkhOMt?CnfIx@?W(Gt^qi=-B)n?Au6Bx#$G+9e5ztVDb(*x42vag;^$vZd~1tr7N$* zc!KT5y{5gNr$lE+Qv|>#Op8)=5E&w_%qUeWAnRxcs^zT>Y8?5XwOJKP7&$B@4Jmri zCvrqDoOlZEcq&LmatgC&$&>DVTJ?a5wjHWkxsy0V`)sRt=p7O_vBtrPz}SHTgl+jj zrE_?q;%pIjQpw^RGubkz{}L1Mif)CxT(8%J}3yZEm|f$x4wV6 zpBBDludlkeUVm^#T;7^>^=~2rVy->yE8ea%KS3>56@MA~ycYOX@SVOLo(c1x!4=VeZ@t9J*s#CG?Vr@}AMKAwjQz3y14Zog zHk^Ms2YaQ14eSPeS=xq#zE=nRod*SZ%SUf7h9RVn*OLd0)9Fh%h-_eZoMmr)-sLVa z3iqZi;!z=06VmBtM8aun?nVetps|Hi4za3tkrjWtyx^OuaT`tv`(n#s)@RYWgSc=q z$DC;Axui0TIY$PueWw}piQk|G4w77slFTY+CDdE7?z6f>+`byQ3yL13*8C?`P}3#_ z8iR2bEMks})c}EtEzm@!YSh?%oW8qpgge6~*)5pKowp}rq^)*7`A;u5T_W=5>yR_2 z3rnBFsiUt=QbP(Y;%)nE0JPf9l*+2P|K{ByE@%zV(l%w#kB^{yRzg zzh3^|Mr*|1N9)2De*0And#yg5!>KEsZeA=wFSL4O24U0l;XRpHnFe8lH% zl6B)I_~oW)$}mxC_Z+Wm?{kvVg~d_$m5Sxnx2uKn`OnE!+TpZ3;;m@1Q;)y{JLm`E z6BhZeo2{>`^Xq`G0BGJR!<6;S*$^MJBN}J=AkjH`&cG=3A(NuuC6y0z{lA6Upu5mo zz=j=;hLgIcL^?B^eJ(UEaGAXIM|zXH0p3gq#7{1Pu3Ub5vsH>q->Ft^W-*1(p>rIG z_3D)kV6g{3XUTZly0J=K-y;PhffPVuckYP>WV&76_qmoev}8I^F@Bzhc(IjXr+BtSfVQtBw`1 zjE$I_S$F_`Ov}V*v9B-C69r8A&={6QZ!k#^z*$hs z7j*7C&lI)!=}*$oS?_I5*H#-C+bXKuP6614eH!IYHN8CL`Xdm*m8*Tz$N9C3K1z~U z1tXwTA%$5GuWSp3UBN^|()7eJJZKvDr#43?aN|_@C+OYya{1;8IrMP1qxvTAOH=|o zv2DpyMnE;_b`>MdudyBBJo+9OB(+}IGw?|2GF2c8PkgDKAN4$6A(2a^<-JghW?5Pp ztt&PEw#%_G$G1XBZ#hNcUPvD5=3DuO5PXE~(pA8Ug@!cp{3B?8d%|)%c~gOS-N%nR z)!)cMU{!kQ$~SH1;RA7(vIZ~bn>LVQ0&3HE)HEDZ)~IQ=mcTl=zMurs676B`#p2D4 z`Ie3AwSuv4b7?P5$`K^PWt5X$CdMBpR1)ue@IF{Wez-uJSBAw88BjCsndgt@&&+2H zLd()&;E`fN5a2;-rmwM+v0AWKTvriMiTUjB6j))ZT}ijVjvr`vsWl`&YK(i|yn5>D zDFP~JH84%0uF9uray$*~%_HnqlZ|Qv=U3A9 zUD)Sr{Ex1%=XH~VeP&asx$-9z!=rrKkGdx1R4sn`MAA03a@bt;0i>p&Ax{0)riUxd z6>*DPoQ*5ZL9z}l>&+dB1>X51R%^`eUr*WjYSv(y3h;mvxY8q0Vv?QMEFKBgfP%On zbD+23q{AN0rb<0=ezBusjRRIwAX~Y@Vmjf%ywauRD+$?A0ZqtkC%mGN*Tm-(i( zA$RwK$`GlfD}&C86f;K9OK(jE8S~;+fo&njpVz%yPpO~>h3!K}vY=;J-Wn!UULt4>cM~z{HIVmf=#9q>csUgC4wkV8tgt2W@HZz8IP7)*V*_2B8#bq z=?+SUl%sAzrp2;Cqo{(MJzZ?<=lVS1p8Cr>l01@YOaO|0ycYt6uFS}J&YmN z_^8j%D#`1bu}jZqNMK^^`{$=W;iE?^k2mqgL(XQ|0&@wAX{i@k+!tA_rsF`S|9kvs z^1t$<+`sUn!v7^d!uiMiNa7biy7^mvB=?`=M{WOtADxE$&-szuf0G|g{&)G&@jvEA z6#pxJBzYh^c~Sm8Kbrc7{HW?*^P}zm9Y3=AJwKv(;YTMKeEDJAGnKiWHsQFz!7#U7yIppybgY;g zUmw~Dcx@>)4^YrgiP1ZI(5vg(o8~L=oP@jaD6FmF+M0tj5AdEV>#Na#oNKX*~ih&{6bDRhG9fuc*iL`hKt$sX~ zX;A%~qCJyre@GSZ$lfBu9c}2o^Y}c_)6XsDv7qkQLh>* z77vkt5f>)%K0de;VJIGdC;^Nn9<9EM%4NeLvAkzr`y5=I>ShqCMV?~_{5+PARC7l{ zWYADC_>5|Y<~EFv46|0Ybcfpw)Qbt0LNGz~7e8A6$&Xfk@gwd(^P|r9Px~+Yh~Wo6 z5`1U`wfzqtDv-jb#MqMq8}OWl_9QR1*iaAt z;Paz%mbt^+#`Z7qks=7fzr!#7NqlDcNt0my0x|x`&;N=1{Nt+r783oDpZ_=KuYcs{ z|Hk?2ANl#m`RgC~`Tx=R>mT{~U!1@Gk)Qu`{`yCL{v$uXoWCN=;eVW9yiVKgVoH2& zaa14_x#zKc?z7dLd{z7fy`7+^3UJ+(Jp3H=0dKjg=-2UU*ZHsGR|4#Zg^vIq(%#BK zf{kC>mJ??B`~P3$XVyRRGsu6wzxd;-{_pZL9K(A^5t{mXPe&MCmbiiVhwt%|C}0Hv zxm-|1*i{TG=$gbM^C6eowc5B`r7_k12rSohG^223|5RX4iFIB%0ER&u?r)%n9J zQn^o4Sx;Xk$3;G0!ge%QR|5d*h3z`l?aQSCHdd;1n({>KrAIf}RvPf6L7R}4aXNlg zNGrmOteJkRIL)LY3vt}l^=R&D3K%_ifmt9p5HXan^EK6T{_`K)Y0aE2JL^hC7K$%T zCfTuDD0YyJosm`fzaJnU9CjO-&E117O&q+AmHh~D1hEREaD9GmAJjs&;usse3_jD) z&{&2n!?x&$GopuKGY-emR=9fTP)!OJukUaNL=Z(qvb-A=3dI_ zdl2x*k>UfEgr&6H=PV}$T?cC~WW?{nrnAn%=|Vw5Bdx1W-IGiQnK|GMpGPwQZWehaVxdf|GRxyT~$8#w7-daP{C4y;!R$|Ce# zgoyPtE$vld=h4L9DfgI_g<0((;BYx7ewmiVtt1Omfd;IG9xK|x15i{zrL7XCcNv*|E{|3#;WZ3;)El%- zm4#V%sAoZ19yB0-zl@XmUGXBu`&eSDlK%i%g3*Cb32Xrx?mH!C-=VoErJC-PV@~tZ zZ1sXV9mOr&kr`xzKj9kVT)OORkelr6atMG=egZ-=GOiehhiTHNAKH0a$d(%Ii`q0E z^rO*!K;Rk_fh`_1rK2ZGd6hZSH%{W~DAsSBNNbSsr?{EOlIhBrcs|=;Lr4~%_3G++ z1nz@7xrd)$KZ8kR@Dh6RE#Jj2T*8LBUUt}EfBM`zXp91bWzL!+!Z|fLxlBJ>+!t5` zlF@uA8EI;=Tq}|4%28s?8A*0@VK9VlTH>ndEev}LuRN%cn0Q4S7*py zWU;AS-~^#(hL*sGL50=F2gC}q=r!wn{Jhb}XBPM2%{bO31vm?BHcbEt9E;W}K`Xmz zW+Z%R+O-Lz35)tV1cfSKwglyaj{KWX?sK4 zB4Iup6{aq8Xi$f4$uwJ1pvtZH);)}pTcv~o;eH~iE*p?sY4F1d22Qc^Qa&wafb1v# zUDGrE(B`YIr8?mk8EA(u~;q2fK57YcEk?J)T}#jHJrj(^H;874Z6 z3YGfw8qdnJ3xH{GUbg^pZzhCYw_U4a{g_rMwe_d+RPPKdCF}cLI`Mu zW{nkrTs8deBJH}Z4!+*1v6uXSJZmly*Qn@Mah6Zy9|;dj)W85rj8iqsuto6^EU!Ff|JRTXJ|;tKD`bl%Tj!(8RHN<9bPPfH=Lbse*I<`&xihy zOy=SF_c&D!Q|Sl+kbIJ}E-zNW?v9>+nnc5}szSXG#^Kai2MFEH@0lKieEUiNN=@ zX{}jBn;ic8+g5Xgt83l>*ortCN8D;;u6_S2-Wo=hCXrWzy}5IM&W$Qh_nHBTLDJhm ze6oR|;vH6d{|xf%zAm9o;^IMb`(S$EBl_F;3^LuG6}Ok>BI5dbY{ZV{IYGO&|MSQW zT#HmERj3x($PUltS7Oc~2K)3-a^Vvpk043%x6E%*Q>n!$%nwFl>4)O@Xktlegzus4 zu>@3ya6Q+^1mm4v%8RkkMhSf6F@uJ+;@+fzd?d!$K2lk6*+UMBBr63{Im%vP)c(~M8>v3M~X;ZU6|Lj!qa8uZK4ztYZdT;CPf%P~2MZ(|p z7nff8i#K`zBBkEvaG16v=g?>P9{}24TW|AU_ZO8w{=IEF|5#Od{Yw`5^ZuOwKk{d7 z5W4>`)&F@>e;c5w{sQ>_o^<=0|5d2{kNO*I#@QVsOpCg;6Ll^gH9mSw*Y>v8?$4jI z;(q8q%cj}C?{EBH^ndxjLn~^|@$T*}oP$K;Au(bD zbdjZ{wJK4HSv5F8+LAB>+oCbYw-^LfBHYLc#5>{s9)Bl)Mt{nlyT~;}wj{QN2I(=o zAlZT&P$=wV`6*+{I(E_Lpr7&ikso(CVEof}e-1x5za*!&Bj4QYnH6DZfS;I;ei)kj zsPk7}F*OIXCcVr8I+7er(D#=%wgOuitH`JsD&*gaB7{nL!0IexoCYd{<+VjNEi;il zDkQNMJ{=a>ILF=F_#$9`;A1yLAAQ#a$p==24%LIv!y|hd@~WGaBPw9&J~y|?$)%hz zcoo#o*Scazn?g+*LtGg$|7GVvDyz}PqPEE~>^x2@L1@SEYxD;8J`k7onN`ASE2Pna zp;lb1H`N^TkY(&`yjzU;WjiwLB=u4oeS~c3@wVMq^|)rv9#&8BxtMi428Ab)nAZU$ zUB(`#VeI-V1zw0^-+ivP=&65p_g!2V|Fpj7gD2T(?I=KOt)gu8&;U=)`w25( zY#i$T*z)d<`FY?09{%4!n5d{_okBX) za&L1gA~a)N{tByzcm7=eCpa`DBNU11PFPj28Ib9)J*q+V97wzGS%Dg4Hvok*l}Y`y z&4kHXXpLe-=kr8Q=?R(I6Y>k~0%_r!J&!0;t`Od5MQrH@bxq9x#0J~~g zp=zBe+Xhl{SN)Y!We%UiE&L)1ckwG1^br@#&BFsM54=o4Y7V+h@pW|}!P!iX=0<~G^X@GwcayEmtyo>Dc+5`OfL`t))U!ig zeP~fXsK7Df4IFpMPV4@@DGBjOl4$G#mv+NZB^Wk=cHCr|nQB>=ed;ZXOlj4&W6h2X~b;cNHTF=?L~J!-Q;?1>r2Lgm}Y zIj>D{`xEr9&fA<(n4u#JZYlk36Hlo+W0({7-63{A=+K;t2gtJo;qS}Eeb7kcFI9ZK z7)Yz;%~4j+Vh7d7xD!e4z*R0q8swU+o<^4ez2y|h# zUWtBC;b~6R9$R}Nr)%Dhv7Vu7ol`}A6F-#e_Y|ZU{b%aE1~QPb=$@i#1Ig?_Pc95t zbi&(^{*ifQAaox~Jzq^fezOANLD9B_NqSgk`N4U-%=tJOjmnW!y8@1j_32fU3};W& z*tGOJLw17kkm11{=-ndg01pT{tdTZCrrg!`Cx4N?Gk8&IJWU<(emd41M#1f7%x-t( z{MRM8QEGEA)gttZU@26_p6zLu6V;3>B&}s`xx-%iB!$yup;Ilk|(X~ z!A~dVQy^|#&zBo`U6Nn{699P&p<&p7@_Tngnw%3I8ExYIl1=vDlutuWj!u{*#I3@% z<4X?SY8AXlb#99>;70-#6R3MJr^O%Me#4~Uw_d0+j~%AN>3V`aLL9od^ZrVGvMKBC zJdR%tfOd4S=q?r*^|y7zvZSzM zhdtSfIWoTq(WVexasIgX8FXHI{>Jfv3;oWokFTGAJU~k1FgGil!Z)+e`F@!;o{E>T zwWd38fXxZJV@>hVoq?MJP7cP#mD`>>la$3DH-Kvk_A}9n)kVUZlDh!m<(j*vjyK$? z>9dPm)>MCn`GSHjr#PahXyC*8xo&f6Vk(@SjrUq~CT9YJV`!L5EbRIQ?4tUbre$Z3 zzj9QNLA7mGNa{hp93uXmzfO8m*0v1eZG2Wb7uq@YoA%l3Fy{gOm;ZAuQ2)8)48m3dK-c~_QFz{^|DbBtm4?fS<$-ShJPMs) zI!uB6021(=g7&2PtH7cABR^}Th_n6c{QRHqKePP=(0}xwg+;}69SrUD9sd*kjUN~F zxAFNu(BFuZ77>MsMGD@+PBCb2w34^-qt_%tGOBZI^GMLG?lQ_YJ-s$~?$$ZpT|2&d zir^<3sx{&@&-N;%s$pk+S@pHY|FXX1Y~rN=-O|zmEk9D&AoaLwvir`fOmWTgyjn-S z?Z&k)4V?yILjB@Jpl?{>coFC?zdNu06zDq(F{l1Uphy2D(9e5}hr?+Ty$JNGJ_oPj zR+==mwa$JD^j-JBEonN$@+&te=MWAQ@ zjX*Da(kAdrpqF6|>7aZO=%aD|D$ozU2=u4W!E4j2aW4Wr-VcEu>W4tD@I#>IzH z0t#lF%{X$Zc+5R_8Aafqqk@Aw#w}hCsj7)ef5N#0IM>XZC?sL2I2pL53 zjZL~`QIZK%A9=WI$1#72*I7TJSRo?6q&#p{T4&AO4$$)wZhO}ST2qy&U)6cT5$maG z>m#&WU%Cji#FBJYV1-K0LcCr|zPu8Cin+z&+WLC7u{|}P&|V}j)SrLq*e4|W>J4Ln zP_qzT4@PSkRPek(E(cm&DsB+D38l2&ecj#`@vT#gSKkT(hV)>s$-QZ5xA-OyiGA9A+ zT3g}pEGQ&L(kfC3DEEvqx>0)hO8e^rS^*+-@;z2KDjrlNEHp$ka|&pZ0HbcZ4(f=W5VuLv?Z^z> z;ADisPo6~x!PJ9xPECh*c zf=>Ad2^#(P3Htcl{=XRXQLSl8H!3>&KMeXSf)|6naqax~2K@?DdiS3V`bf852K~kl zgMNAut?u+s20g>y81%CZ4J#{bzcuKGMPCehynkTOyZ_0c|G1s>)1Ytuok9P>mHjYV zpMV*@p5Eh!LH}JmW|9Bt7St&GmqD-jqXGS?@0UT}K>5R^!EVg`)_dZ1Aj@-D1S=OEI$)8%}atNeo4@NKN56^b>q_8 zQyP9EWOrMB0Vct~o4WOk1XH%xhRe#cGqUgcCQ(S9IUliXOx#MrGE%df4ED!d;R*D% z2#k6;UBR4_Zss$rtM!x(aWlOHQ%FoYfsD02a7!#raT5%Ux#foL%)ow{V^rhehWZ5io_!YFyC#52!L87WdOHiPl=b~z!!-=0rA}T2ZE-&%|ba(`Kb2*>n7z* zJRzBC6$j@grz5m3Eix3dgPFQ*S&{VQVfBB?yYhG_zwbYG$yy?0Dh}CM~-SO zjh`N7z8U|feWTW%-#pD5H-E|65lp*juJ%_2x? zNU_Ao1j8O^!BMW38ZuI7UPg)Z|6~1m^!IN-79DB+?7IHNeTh_$>7n8;s8h^?-`Ll7 zisTik;$F(w@6s&4axqihDX&nsB1P%?R6?v$@KN&05Qj%?Hn%cvooMMkC-#eHLn{&g zy*jU*cWF@1(c<2Q3`OfH znl2@6Q++06JG331N3^5471Ri?s<)0%bdL%CCh6v-=c?b0za;w3|NOaIR#uT!GMC+| z)Et$oE(Wfb*Xh=enAwV(o7AeUxy&-LewSR5pucFlRQ5!=DsSG@n4K@%D;A`k_@TVH zdZ%?GU1H(N1@58k$sN}WThG|5N1f{;PionDQyk4G%^MdS}!xwHx>%6`CP;JXcnKd#30iL=OG}_}IhMxK6 zYVl=SaGgT;wrTrJ(`RgY&l4BA`_Sv|Jmrbm+CFBE4P?Li_t|?>qT)jGHm{j4M%nkS zLhaq{8)|;-^TX0lp5j)yUs^4ExWz~B4Nt*^9An9GM9sE@U(px4)>-Dn?y5`JFwyMg z_}YDW(mitGKgwi!*TT010 zICn2-eoUUgR!2&+PF}Ueob;xbuy>9sS=bC}_MCGFz-4HDS${dGGUzm)=aF zw6@vR9`?LBo<5`XWz?S?9Kyry;Fwjxyn{o#8hr;x!mv9y%9NRQaDa03zz&X;5hU0S z4q0di$E3pd!b(!|CQ_?34mlhNSZQ?C#;YUstb>M}nB3QN@(SatSqTZ=Uu)+Vha5Dm z2`-8*nNlDW=2;MN=-f+kqS^B$F)#OTx{{eOcb4(^LQ|fAZB^GhoF-nIGi3*EQrn&I zbyj?7m1R1F<@cT~mi@=tG+TGP`U4K+`Xp9} zZL0Q{*y~6%s_%_{J@al=iEz3~9Z~c1wVjJ{l=*5J6V8l(JKONaeesEg*LR)Io;u0e zxHZ8vvQjK7q=aB3_9NK6@pzBv?Vq228O*XPoO<$9`*%Z;<>9K$brys|r)P=ctz07LO|y(Oxj?l#{isBT;<8?95)PLjloGA}t@? zi+$;u_^3Sb^{)?ol@FW_?$>XZefK`|G{I+kQlIPZ@y3_*oVY409=*8G<#jPmRQI!y z-fOwpT;}DG{uRb9xo0mp3V*4%q%(0t6-c0uRA*H`p+O0B)uoBd3G}H;0)EZkeqDcB zqSBv0zf9Vj^wLnkDC_e;0=>!lmlGp_PPzFLuXZr)v4t_Q0!pA?Knb)+e**m_E&0H^ zJN*gtA-!&AziTaD_y-eczjos_`xpsyGn7CFJ&O2yO-Qn4-t@Li-I^B^VYNKl{KvjU zj08I8ZhmQl&}yae0?v0p0^RxGo`RzCUvH;Tw@gu0-0e^b4%CPe>f`Q5$V4cjr7X{uIjfTRX-6t=_j(C2E}J?yM?W!rJM^rAwx!@LuO@ zpENaDrC7zr^O*SF6GyeJE~+f(JTY(Q3EuXPr2)NbRsBDOZ;NuMec*O+en;{W>XF$> zVh^OgZ4&R?zK8HrH{3E>#lbF)yjvsOHr=XeyyXLjx2mgO`Jda{N9!)~OYOV3BJ-43 z*)5A`$GMl7j-V2&x_SS_#;z9|w_GtXOn=ob7#(-D@A``0#_@gQo@+CmLDdHKaELMO z;fU$q!(jzhn@pJ!XmA{oAUG3=2n}(P6H2W9-)> zqI>J6&iZghHvHW#-iYl7)Kg>QgVnyD3&?w6>%F{l1OBPqo%uNT~YE2*7HiPbGkEnxf@QYY ziyNIvOI+(jdmC`?ud1c0imKD*3q09Nm_NSkc!OTxW?y2Ip~JeLMALMJ|wUSTz`r);9H%8Vhnk3?- z*CXkuEq#Hse2>A*x2yNwIp1{G^peeVwOY+fb%(Q4DqI_6$>;gZjy1&O)NaS$D{7Pv z+fddZG^H_gx`x7z9HY|p0>XzSF9*w}7nCg*e;wpWl@MK90`B4{CzU>1y+47haqrNp zo^?L^;~L}dOXrEHX=aJ$Y!kPYnE23kSyDocRh9xl`*+={Jr{a6$8Jp3PdCZ<`=JXy z;7atBqI3_jNMg^m**iay*6;?2)P3fe9qavhO8R>5JMDZQnr&`u+2=;)%XwpXV^`s3 zkK<8z=OKn~j(IMZQ+ zAdp5U1k!2RI<}UE|K{aP8-7^cHaGW1wl;pZfOv(xTHOrwA5cT*H4{T{{^2z%$e(O$ z`LFR8!%bwIPBRP7xKCaPPbGPT_>w*GbW$LVLdA#b2?gWS)m;PtCmQ%of;TCctN*_U zSyMth$Rwx!p9%$YyMR-daXP^~EWHO0yhBZyd zf$B-3l02<_iFBc0{u#^Z%Yy~tW-+=bV&IQm003&}R!|+*3ZWz_&6g55jQ$3UZc$25 zO%^x=4r=H!r{iV};}IU=bP@&9%+^vBn?I0!>2xv)(mQTWvkbT>0tYp84hFc%!*H18 zNuU$7X(XyIf$SSWpaUD=eLZb0B@qef8XB4Cniw1D>+0(n8k-mx>KcQ;x`sN2`nq}s zMmqZ7kFJrC5yWuMnWO3IfF0Bv?YSUh4Gwt9O)t8k#}Bnx&_BRlOa67WkQ7Fz60`|q zGG#rU?xn9cfXxU57!D3+0{cE0e1`=)h(yJcJiSSHdUy~CPYj_`yu1da3=G*uH}?2K zUJf;Fm=s7UEK(Q;K;b4K0y%&wHcrd zy|ln1!a|&i4H&I8XFYH&mx$eb}Cg02VN z)fi=c2t`J$!iH$fiiqw#NkW)7ny@0O+~r9`e%6!0-4GbGHf2SerF~EexCstws-O+M z_G3fT{nwy@LrMx`BB{$3HOK3N9u7n{9CANKNVc#E%{Go=49vjE;gCKe*jNt64U(6` zA*;l&K@J8ElAFUJ=ZRy39E_adS&B zK@AQmJ`o#Bw&3~uyW?eC41fd;4w*C!8zfuwoc}1h2pLlR1SUv5w&<~lT^oi|0xUse zVX4A}CB*gEqNjb8nm!}Id08RFZLmQOM$hn0lw^kuaxi)ZTpitsaEq`(vPI8=J7WIe zQWhN4SZryJ4RSDghG!`rh7FP}dOmbr+Zw|M+!8bvmf_eS*`lXi`cuXqA7X{vhz*i0 zdQw)rAR@=OP7F3kw&+Rt$o&NL7z|Vv#W!Js)MtwxbV!NK*dW=WXB=64+CVl0XPJx< zaxi)ZoM>~b>r&*grz#E`%faXwJ|G>pV}oRi9_ADau6PkfNVe$7B|WH|2c9_8;E+i> zu(2GB9t?`_#0JS0J#7 zD5w4tK64c)=ib#_KBD4)3MPD0F_6;Nvpeun{o#?*Y9bRsbft>_#VFwcysqmkLq3gKwom6@>&`}WRXaf^F zVH$^G|C~1-rtM871o`0my%<5$MVjwLq(Qjg!BcgBi4;{EC6Va*R!|?hK(~i<@v-{v zDNPQA!(x?6@C21l1Z|aW#D*7w=Nbmh>0#QsXpf3ObX|AvyVjPYgTrZpfQv+n1 zfgI8e#^Lup4mtFDHi+PXo|#Aqq!U0SQ`s*nFh%fznGvt$iUEbEpn1cnc$SPY6?FS7 ztx&gH4K9AW?g3g{&WOcZdq$m%g8fo>Ci zt&QOG@;IC)=%V2^Nvh|N&Y*AnS=tMtg6xJ!*B)5v`|~}5O(Ohxd7zELVc@PUxJ_`4 zV@3kqCO@91Dp~-WWPrja+$Mr89MZw&C(y^!Sp6hOeeLY;z$QPzk`CM^V(-U{1iDRd zyIpVo0I_o)jHc!=w=L`8kPgF7Ko^VmA|mK*S+L<3A29wQAPAnO*!TV?LFl@*&ah9c z06I+v`oYr_a9SH@nJz=O00P}d8y`ra20$yMBs>AENry5PN)hxuNV|{)tv^_TJZUw| zux`IbT{yZ868CnBkbwSA0Tp=iA^{fu{(V7#CEI6uzHB`rlBZKu6bp5M*vsIl!^5qI zYm`N!>;L>=?TuPsep6rr0_-sq^NxfBx(~3~1Ug)tHTs)!HIkshkQML>e;6Gv{{I0T zbURTd{4n=I^b_%MBO%t`53t$97{Mm!e)2_VltrWK&#gAEv<}%%L`Fh_13!U2gu&`3 zlNG8yBm0TB*#CeIx}6?%hAC?SKUv7upNNAs_)+UmOb~2xQYv0k0*DP^>rV)3K`g49Sz3{@1^Vg+d)QtmbGE$^Qi13c&6B{K%%(d|Il;e~StcBls( z8N72}p}-*#Y`GLtl=N^5;0pkO9#9>GckV&TV@3kqCOy`c*|&jnCV-q9K3gwW=a3F+ z&P@yPKnM-nhRveJe-dr@Y<+^(=t@S{-q9;IEC^`t!IoVM7<0%0n@1QS7~)No{TE3v z1IuR1u5spLMgrX?d|J|#A)vQB4(D0n#VDB)W;W+c#U zQne&AW#0Xu7QPP5nr$GKwFtV?O$*%?*lR3(4 zFv&-^gkW~ba%kRa0-^+7_awP-$b~>Z)YZxsK^yO1iDQu&t9o42Q=maO7Lh|;XNWcnEF*+q*(Z@0=9vslh78+p_ilIh)50RGrCCSaZ$_OTs^?z0B9aV6u>(* z^4PIJw@QZH(hEL-OB z7z5#Ba4MBUK7%tDlocgiq*QfnoL~&Jkr7%_f{(#vVAjvk7>r3ix+P|`Bz*b+{DXZ> zDJgS^_$OU_yA zV`fd41d0F^_MWyec8sZ@+sEJLeFt*%IL2{EYFO_@au@XI*|~izpsXfB>0oMfPjrn2|uYiIr2VYzmlsK2ZgWLcn#0UV?i$ zqyw8@Fg|~Y5F$(Rx{k%jf@KDK)@sz$BcmY?UDL9Q@AzE6C^8Y0=HQw-f`N{sUYwyR zV@j`0BNFIz#>d)OI|C6bfuD9@SuqaG9N~30^}^ARhpuUEueV$oc#!`9Ux$yEGIuzX z{KwDHFJM4Q#nY9ewhbI+3m-2J-W?11=$81J8~eN)SOVIaWi{m5;9Xqhh?sz}Vdy$! z1ou7{bGp0-L^mFU6ntTmw`x=bqU(zO)Z;(_fg}GO_NgNce$01J!=L)|+Od#75=-2D zHQG#&mQ$H;6NFnr_RUzxABiP+Ka4gLr1=%|wJ>l?tZ5$$`PeK0FSOcx9c?Cz`%_ql z1LhOH;c4o@-Z3G7%@*+SAr9;m9^IY-X@1FkQX||eo`d5nMqmC&EKw>l+Dwp2Gt5Ws zz%3ywHWu<(EirWB0rOEhb73RpIGGVKVLI@KH58anELjMXRq&r>p=-!|9?1-t)S@ZF zYdCl|O20BphGRP5V writes my_mace.model-cp2k.pth +``` + +This conversion only needs to be performed once on a machine with both `torch` and `mace` installed. +The resulting `*.pth` file uses the same tensor and metadata format as the NequIP interface (inputs +`pos`, `edge_index`, `edge_cell_shift`, `cell`, `atom_types`; outputs `atomic_energy`, `forces`, +`virial`) and embeds the metadata (`num_types`, `r_max`, `type_names`, `model_dtype`) that CP2K +reads to build the neighbour graph. The `torch` version used for export must be compatible with the +LibTorch version linked into CP2K. + +## Input Section + +Inference is configured through the [MACE](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE) +section within the `&NONBONDED` forcefield parameters: + +```text +&FORCEFIELD + &NONBONDED + &MACE + ATOMS Cu + POT_FILE_NAME MACE/my_mace.model-cp2k.pth + &END MACE + &END NONBONDED +&END FORCEFIELD +``` + +- [ATOMS](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE.ATOMS): a list of elements/kinds; the + mapping to the model type list must be consistent with the coordinates in `&COORDS`/`&TOPOLOGY`. +- [POT_FILE_NAME](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE.POT_FILE_NAME): path to the + exported MACE model. + +MACE is a message-passing model with a non-local receptive field. As with NequIP, the interface +evaluates the full system on every MPI rank and divides the energy, forces, and virial by the number +of ranks. + +## Further Resources + +- **MACE:** Paper [](#Batatia2022) and source code at + [github.com/ACEsuit/mace](https://github.com/ACEsuit/mace). +- **e3nn:** For an introduction to Euclidean neural networks, visit [e3nn.org](https://e3nn.org). diff --git a/docs/technologies/libraries.md b/docs/technologies/libraries.md index 2e5bf4ebbf..86a2cb3451 100644 --- a/docs/technologies/libraries.md +++ b/docs/technologies/libraries.md @@ -220,8 +220,8 @@ of each atom. ## Torch (PyTorch C++ library) -LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP interface and for GauXC -Skala models. +LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP and MACE interfaces and for +GauXC Skala models. - LibTorch can be downloaded from the [PyTorch installation page](https://pytorch.org/get-started/locally/). diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 89417a3cf5..a016d826a6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -355,7 +355,7 @@ list( manybody_deepmd.F manybody_gal21.F manybody_gal.F - manybody_nequip.F + manybody_e3nn.F manybody_potential.F manybody_siepmann.F manybody_tersoff.F diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 621576c26d..38ca082835 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -66,7 +66,7 @@ MODULE bibliography Kantorovich2008a, Wellendorff2012, Niklasson2014, Borstnik2014, & Rayson2009, Grimme2011, Fattebert2002, Andreussi2012, & Khaliullin2007, Khaliullin2008, Merlot2014, Lin2009, Lin2013, Lin2016ACE, & - Batzner2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & + Batzner2022, Batatia2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & Luber2014, Berghold2011, DelBen2015b, Campana2009, & Schiffmann2015, Bruck2014, Rappe1992, Ceriotti2012, & Ceriotti2010, Walewski2014, Monkhorst1976, MacDonald1978, Worlton1972, & @@ -164,6 +164,13 @@ CONTAINS source="Nat. Commun.", volume="13", pages="2453", & year=2022, doi="10.1038/s41467-022-29939-5") + CALL add_reference(key=Batatia2022, & + authors=s2a("I. Batatia", "D. P. Kovacs", "G. N. C. Simm", "C. Ortner", "G. Csanyi"), & + title="MACE: Higher order equivariant message passing neural networks "// & + "for fast and accurate force fields", & + source="Adv. Neural Inf. Process. Syst.", volume="35", pages="11423-11436", & + year=2022, doi="10.48550/arXiv.2206.07697") + CALL add_reference(key=VandenCic2006, & authors=s2a("E. Vanden-Eijnden", "G. Ciccotti"), & title="Second-order integrators for Langevin equations with holonomic constraints", & diff --git a/src/fist_neighbor_list_control.F b/src/fist_neighbor_list_control.F index f16cc70787..0e23752054 100644 --- a/src/fist_neighbor_list_control.F +++ b/src/fist_neighbor_list_control.F @@ -39,14 +39,9 @@ MODULE fist_neighbor_list_control section_vals_val_get USE kinds, ONLY: dp USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: ace_type,& - allegro_type,& - gal21_type,& - gal_type,& - nequip_type,& - pair_potential_pp_type,& - siepmann_type,& - tersoff_type + USE pair_potential_types, ONLY: & + ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & + pair_potential_pp_type, siepmann_type, tersoff_type USE particle_types, ONLY: particle_type #include "./base/base_uses.f90" @@ -236,6 +231,9 @@ CONTAINS IF (ANY(potparm%pot(ikind, jkind)%pot%type == nequip_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF + IF (ANY(potparm%pot(ikind, jkind)%pot%type == mace_type)) THEN + full_nl(ikind, jkind) = .TRUE. + END IF IF (ANY(potparm%pot(ikind, jkind)%pot%type == ace_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF diff --git a/src/fist_nonbond_env_types.F b/src/fist_nonbond_env_types.F index 26360ee060..045df06365 100644 --- a/src/fist_nonbond_env_types.F +++ b/src/fist_nonbond_env_types.F @@ -23,8 +23,8 @@ MODULE fist_nonbond_env_types USE kinds, ONLY: default_string_length,& dp USE pair_potential_types, ONLY: & - ace_type, allegro_type, gal21_type, gal_type, nequip_type, pair_potential_pp_release, & - pair_potential_pp_type, siepmann_type, tersoff_type + ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & + pair_potential_pp_release, pair_potential_pp_type, siepmann_type, tersoff_type USE torch_api, ONLY: torch_model_release,& torch_model_type #include "./base/base_uses.f90" @@ -497,6 +497,10 @@ CONTAINS fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp END IF + IF (ANY(potparm%pot(idim, jdim)%pot%type == mace_type)) THEN + fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp + fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp + END IF IF (ANY(potparm%pot(idim, jdim)%pot%type == allegro_type)) THEN fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.F index 6de5a4894d..0d6680b31c 100644 --- a/src/fist_nonbond_force.F +++ b/src/fist_nonbond_force.F @@ -38,9 +38,9 @@ MODULE fist_nonbond_force USE message_passing, ONLY: mp_comm_type USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, gal21_type, gal_type, nequip_type, nosh_nosh, & - nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, siepmann_type, & - tersoff_type + ace_type, allegro_type, deepmd_type, gal21_type, gal_type, mace_type, nequip_type, & + nosh_nosh, nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, & + siepmann_type, tersoff_type USE particle_types, ONLY: particle_type USE shell_potential_types, ONLY: get_shell,& shell_kind_type @@ -231,6 +231,7 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & + .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = 0.5_dp*fac_ei @@ -722,6 +723,7 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & + .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = fac_ei*0.5_dp diff --git a/src/force_fields_all.F b/src/force_fields_all.F index 6f9106752b..798fe280b8 100644 --- a/src/force_fields_all.F +++ b/src/force_fields_all.F @@ -64,10 +64,11 @@ MODULE force_fields_all spline_nonbond_control USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, nequip_type, & - nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, pair_potential_pp_create, & - pair_potential_pp_type, pair_potential_single_add, pair_potential_single_clean, & - pair_potential_single_copy, pair_potential_single_type, sh_sh, siepmann_type, tersoff_type + ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, mace_type, & + nequip_type, nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, & + pair_potential_pp_create, pair_potential_pp_type, pair_potential_single_add, & + pair_potential_single_clean, pair_potential_single_copy, pair_potential_single_type, & + sh_sh, siepmann_type, tersoff_type USE particle_types, ONLY: allocate_particle_set,& particle_type USE physcon, ONLY: bohr @@ -2194,7 +2195,7 @@ CONTAINS atmname == inp_info%nonbonded%pot(j)%pot%at2) THEN SELECT CASE (inp_info%nonbonded%pot(j)%pot%type(1)) CASE (ea_type, tersoff_type, siepmann_type, nequip_type, & - allegro_type, deepmd_type, ace_type) + allegro_type, deepmd_type, ace_type, mace_type) ! Charge is zero for EAM, TERSOFF and SIEPMANN type potential ! Do nothing.. CASE DEFAULT diff --git a/src/force_fields_input.F b/src/force_fields_input.F index 89bcf55132..1df71ce40d 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -69,7 +69,7 @@ MODULE force_fields_input USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, deepmd_type, do_potential_single_allocation, & ea_type, eam_pot_type, ft_pot_type, ft_type, ftd_type, gal21_type, gal_type, gp_type, & - gw_type, ip_type, ipbv_pot_type, lj_charmm_type, nequip_pot_type, nequip_type, & + gw_type, ip_type, ipbv_pot_type, lj_charmm_type, mace_type, nequip_pot_type, nequip_type, & no_potential_single_allocation, pair_potential_p_type, pair_potential_reallocate, & potential_single_allocation, siepmann_type, tab_pot_type, tab_type, tersoff_type, wl_type USE shell_potential_types, ONLY: shell_p_create,& @@ -109,8 +109,8 @@ CONTAINS CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: atm_names INTEGER :: nace, nb4, nbends, nbm, nbmhft, nbmhftd, nbonds, nchg, ndeepmd, neam, ngal, & - ngal21, ngd, ngp, nimpr, nipbv, nlj, nnequip, nopbend, nshell, nsiepmann, ntab, ntersoff, & - ntors, ntot, nubs, nwl + ngal21, ngd, ngp, nimpr, nipbv, nlj, nmace, nnequip, nopbend, nshell, nsiepmann, ntab, & + ntersoff, ntors, ntot, nubs, nwl LOGICAL :: explicit, unique_spline REAL(KIND=dp) :: min_eps_spline_allowed TYPE(input_info_type), POINTER :: inp_info @@ -135,9 +135,11 @@ CONTAINS SELECT CASE (ff_type%ff_type) CASE (do_ff_charmm, do_ff_amber, do_ff_g96, do_ff_g87) CALL section_vals_val_get(ff_section, "PARM_FILE_NAME", c_val=ff_type%ff_file_name) + IF (TRIM(ff_type%ff_file_name) == "") THEN CPABORT("Force Field Parameter's filename is empty! Please check your input file.") END IF + CASE (do_ff_undef) ! Do Nothing CASE DEFAULT @@ -326,6 +328,19 @@ CONTAINS CALL read_ace_section(inp_info%nonbonded, tmp_section2, ntot) END IF + tmp_section2 => section_vals_get_subs_vals(tmp_section, "MACE") + CALL section_vals_get(tmp_section2, explicit=explicit, n_repetition=nmace) + ntot = nlj + nwl + neam + ngd + nipbv + nbmhft + nbmhftd + nb4 + nbm + ngp + ntersoff + & + ngal + ngal21 + nsiepmann + nnequip + ntab + ndeepmd + nace + IF (explicit) THEN + ! avoid repeating the mace section for each pair + CALL section_vals_val_get(tmp_section2, "ATOMS", c_vals=atm_names) + nmace = nmace - 1 + SIZE(atm_names) + (SIZE(atm_names)*SIZE(atm_names) - SIZE(atm_names))/2 + ! MACE reuses the nequip_pot_type storage (set%nequip), hence nequip=.TRUE. here + CALL pair_potential_reallocate(inp_info%nonbonded, 1, ntot + nmace, nequip=.TRUE.) + CALL read_mace_section(inp_info%nonbonded, tmp_section2, ntot) + END IF + END IF tmp_section => section_vals_get_subs_vals(ff_section, "NONBONDED14") @@ -541,6 +556,7 @@ CONTAINS ipbv%a(15) = 12917180227.21_dp ELSE IF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN + ipbv%rcore = 2.95_dp ! a.u. ipbv%m = -0.004025691139759147_dp ! Hartree/a.u. @@ -602,6 +618,7 @@ CONTAINS ft%d = cp_unit_to_cp2k(0.499_dp, "eV*angstrom^8") ELSE IF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN + ft%a = cp_unit_to_cp2k(1256.31_dp, "eV") ft%c = cp_unit_to_cp2k(7.00_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(8.676_dp, "eV*angstrom^8") @@ -826,6 +843,54 @@ CONTAINS END SUBROUTINE read_nequip_section +! ************************************************************************************************** +!> \brief Reads the MACE section +!> \param nonbonded ... +!> \param section ... +!> \param start ... +!> \author Xinyue Sun +! ************************************************************************************************** + SUBROUTINE read_mace_section(nonbonded, section, start) + TYPE(pair_potential_p_type), POINTER :: nonbonded + TYPE(section_vals_type), POINTER :: section + INTEGER, INTENT(IN) :: start + + CHARACTER(LEN=default_string_length) :: pot_file_name + CHARACTER(LEN=default_string_length), & + DIMENSION(:), POINTER :: atm_names + INTEGER :: isec, jsec, n_items + TYPE(nequip_pot_type) :: mace + + n_items = 1 + isec = 1 + n_items = isec*n_items + CALL section_vals_val_get(section, "ATOMS", c_vals=atm_names) + CALL section_vals_val_get(section, "POT_FILE_NAME", c_val=pot_file_name) + + mace%pot_file_name = discover_file(pot_file_name) + ! MACE models use standardized units: Angstrom, eV and eV/Angstrom + mace%unit_length = "angstrom" + mace%unit_energy = "eV" + mace%unit_forces = "eV/Angstrom" + ! MACE models are exported to speak the same metadata/tensor dialect as NequIP + CALL read_nequip_data(mace) + CALL check_cp2k_atom_names_in_torch(atm_names, mace%type_names_torch) + + DO isec = 1, SIZE(atm_names) + DO jsec = isec, SIZE(atm_names) + nonbonded%pot(start + n_items)%pot%type = mace_type + nonbonded%pot(start + n_items)%pot%at1 = atm_names(isec) + nonbonded%pot(start + n_items)%pot%at2 = atm_names(jsec) + CALL uppercase(nonbonded%pot(start + n_items)%pot%at1) + CALL uppercase(nonbonded%pot(start + n_items)%pot%at2) + nonbonded%pot(start + n_items)%pot%set(1)%nequip = mace + nonbonded%pot(start + n_items)%pot%rcutsq = mace%rcutsq + n_items = n_items + 1 + END DO + END DO + + END SUBROUTINE read_mace_section + ! ************************************************************************************************** !> \brief Reads the LJ section !> \param nonbonded ... @@ -1272,11 +1337,13 @@ CONTAINS ! Calculate p_inv the inverse of the matrix p p_inv(:, :) = 0.0_dp CALL invert_matrix(p, p_inv, eval_error) + IF (eval_error >= 1.0E-8_dp) THEN CALL cp_warn(__LOCATION__, & "The polynomial fit for the BUCK4RANGES potential is only accurate to "// & TRIM(cp_to_string(eval_error))) END IF + ! Get the 6 coefficients of the 5th-order polynomial -> x(1:6) ! and the 4 coefficients of the 3rd-order polynomial -> x(7:10) x(:) = MATMUL(p_inv(:, :), v(:)) diff --git a/src/input_cp2k_mm.F b/src/input_cp2k_mm.F index aeb0be36a1..4938f9cfea 100644 --- a/src/input_cp2k_mm.F +++ b/src/input_cp2k_mm.F @@ -15,9 +15,9 @@ ! ************************************************************************************************** MODULE input_cp2k_mm USE bibliography, ONLY: & - Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, Drautz2019, & - Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, Tan2025, & - Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 + Batatia2022, Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, & + Drautz2019, Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, & + Tan2025, Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 USE cp_output_handling, ONLY: cp_print_key_section_create,& debug_print_level,& high_print_level,& @@ -1185,6 +1185,10 @@ CONTAINS CALL section_add_subsection(section, subsection) CALL section_release(subsection) + CALL create_MACE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + CALL create_DEEPMD_section(subsection) CALL section_add_subsection(section, subsection) CALL section_release(subsection) @@ -1483,6 +1487,48 @@ CONTAINS END SUBROUTINE create_NEQUIP_section +! ************************************************************************************************** +!> \brief This section specifies the input parameters for MACE potential type +!> \param section the section to create +!> \author Xinyue Sun +! ************************************************************************************************** + SUBROUTINE create_MACE_section(section) + TYPE(section_type), POINTER :: section + + TYPE(keyword_type), POINTER :: keyword + + CPASSERT(.NOT. ASSOCIATED(section)) + CALL section_create(section, __LOCATION__, name="MACE", & + description="This section specifies the input parameters for MACE potential type, "// & + "a higher-order equivariant message-passing neural network. "// & + "The MACE model must be exported to a TorchScript file that takes a single "// & + "dictionary argument (see the create_cp2k_model.py helper). "// & + "Requires linking with libtorch library from .", & + citations=[Batatia2022], n_keywords=1, n_subsections=0, repeats=.FALSE.) + + NULLIFY (keyword) + + CALL keyword_create(keyword, __LOCATION__, name="ATOMS", & + description="Defines the atomic kinds involved in the MACE potential. "// & + "Provide a list of each element, making sure that the mapping from the ATOMS list "// & + "to MACE atom types is correct. This mapping should also be consistent for the "// & + "atomic coordinates as specified in the sections COORDS or TOPOLOGY.", & + usage="ATOMS {KIND 1} {KIND 2} .. {KIND N}", type_of_var=char_t, & + n_var=-1) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="POT_FILE_NAME", & + variants=["MODEL_FILE_NAME"], & + description="Specifies the filename that contains the exported MACE model. "// & + "MACE models use standardized units (Angstrom for length, eV for energy, "// & + "eV/Angstrom for forces), so no unit keywords are required.", & + usage="POT_FILE_NAME {FILENAME}", default_lc_val=" ") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + END SUBROUTINE create_MACE_section + ! ************************************************************************************************** !> \brief This section specifies the input parameters for ACE potential type !> \param section the section to create diff --git a/src/manybody_nequip.F b/src/manybody_e3nn.F similarity index 94% rename from src/manybody_nequip.F rename to src/manybody_e3nn.F index 9938d0b82b..58e5dc64c6 100644 --- a/src/manybody_nequip.F +++ b/src/manybody_e3nn.F @@ -6,13 +6,16 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** +!> \brief Shared TorchScript evaluation path for e3nn-based equivariant message-passing +!> potentials (NequIP, Allegro and MACE). !> \par History !> Implementation of NequIP and Allegro potentials - [gtocci] 2022 !> Index mapping of atoms from .xyz to Allegro config.yaml file - [mbilichenko] 2024 !> Refactoring and update to NequIP version >= v0.7.0 - [gtocci] 2026 +!> Renamed manybody_nequip -> manybody_e3nn as it now also serves MACE - [xysun] 2026 !> \author Gabriele Tocci ! ************************************************************************************************** -MODULE manybody_nequip +MODULE manybody_e3nn USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type @@ -28,7 +31,8 @@ MODULE manybody_nequip dp,& int_8 USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: nequip_pot_type,& + USE pair_potential_types, ONLY: mace_type,& + nequip_pot_type,& nequip_type,& pair_potential_pp_type,& pair_potential_single_type @@ -43,10 +47,10 @@ MODULE manybody_nequip IMPLICIT NONE PRIVATE - PUBLIC :: nequip_energy_store_force_virial, & - nequip_add_force_virial + PUBLIC :: e3nn_energy_store_force_virial, & + e3nn_add_force_virial - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_nequip' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_e3nn' TYPE, PRIVATE :: nequip_work_type INTEGER :: target_pot_type @@ -89,10 +93,10 @@ CONTAINS !> Refactoring and unifying NequIP and Allegro - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_total, fist_nonbond_env, para_env, use_virial, & - target_pot_type) + SUBROUTINE e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_total, fist_nonbond_env, para_env, use_virial, & + target_pot_type) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), POINTER :: particle_set(:) @@ -107,7 +111,7 @@ CONTAINS LOGICAL, INTENT(IN) :: use_virial INTEGER, INTENT(IN) :: target_pot_type - CHARACTER(LEN=*), PARAMETER :: routineN = 'nequip_energy_store_force_virial' + CHARACTER(LEN=*), PARAMETER :: routineN = 'e3nn_energy_store_force_virial' INTEGER :: handle TYPE(nequip_data_type), POINTER :: neq_data @@ -132,7 +136,8 @@ CONTAINS CALL setup_neq_data(fist_nonbond_env, neq_data, neq_pot, nequip_work) - IF (nequip_work%target_pot_type == nequip_type) THEN + IF (nequip_work%target_pot_type == nequip_type .OR. & + nequip_work%target_pot_type == mace_type) THEN CALL prepare_edges_shifts_nequip(nequip_work) ELSE CALL prepare_edges_shifts_allegro(nequip_work) @@ -146,7 +151,7 @@ CONTAINS CALL release_nequip_work(nequip_work) CALL timestop(handle) - END SUBROUTINE nequip_energy_store_force_virial + END SUBROUTINE e3nn_energy_store_force_virial ! ************************************************************************************************** !> \brief ... @@ -564,7 +569,8 @@ CONTAINS n_atoms = SIZE(nequip_work%particle_set) ! for allegro ensure ghost atoms are included in the evaluation - IF (nequip_work%target_pot_type /= nequip_type) THEN + IF (nequip_work%target_pot_type /= nequip_type .AND. & + nequip_work%target_pot_type /= mace_type) THEN ! label atoms in the local edges DO i = 1, SIZE(nequip_work%local_edges, 2) atom_a = INT(nequip_work%local_edges(1, i)) @@ -708,7 +714,8 @@ CONTAINS DO iat_use = 1, SIZE(neq_data%use_indices) iat = neq_data%use_indices(iat_use) ! Only apply the local mask for Allegro models - IF (nequip_work%target_pot_type /= nequip_type) THEN + IF (nequip_work%target_pot_type /= nequip_type .AND. & + nequip_work%target_pot_type /= mace_type) THEN IF (.NOT. nequip_work%sum_energy(iat)) CYCLE END IF @@ -717,7 +724,8 @@ CONTAINS CALL torch_tensor_release(t_energy) pot_total = pot_total*pot%unit_energy_val - IF (nequip_work%target_pot_type == nequip_type) THEN + IF (nequip_work%target_pot_type == nequip_type .OR. & + nequip_work%target_pot_type == mace_type) THEN neq_data%force = neq_data%force/REAL(nequip_work%para_env%num_pe, dp) pot_total = pot_total/REAL(nequip_work%para_env%num_pe, dp) END IF @@ -728,7 +736,8 @@ CONTAINS neq_data%virial(:, :) = RESHAPE(v_ptr, [3, 3])*pot%unit_energy_val CALL torch_tensor_release(t_virial) - IF (nequip_work%target_pot_type == nequip_type) THEN + IF (nequip_work%target_pot_type == nequip_type .OR. & + nequip_work%target_pot_type == mace_type) THEN neq_data%virial = neq_data%virial/REAL(nequip_work%para_env%num_pe, dp) END IF END IF @@ -745,7 +754,7 @@ CONTAINS !> Sum forces, virial to nonbond - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + SUBROUTINE e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: f_nonbond, pv_nonbond LOGICAL, INTENT(IN) :: use_virial @@ -764,6 +773,6 @@ CONTAINS f_nonbond(1:3, iat) = f_nonbond(1:3, iat) + neq_data%force(1:3, iat_use) END DO - END SUBROUTINE nequip_add_force_virial + END SUBROUTINE e3nn_add_force_virial -END MODULE manybody_nequip +END MODULE manybody_e3nn diff --git a/src/manybody_potential.F b/src/manybody_potential.F index 9de5d3949d..a3a706a7f1 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -30,6 +30,8 @@ MODULE manybody_potential ace_energy_store_force_virial USE manybody_deepmd, ONLY: deepmd_add_force_virial,& deepmd_energy_store_force_virial + USE manybody_e3nn, ONLY: e3nn_add_force_virial,& + e3nn_energy_store_force_virial USE manybody_eam, ONLY: get_force_eam USE manybody_gal, ONLY: destroy_gal_arrays,& gal_energy,& @@ -39,8 +41,6 @@ MODULE manybody_potential gal21_energy,& gal21_forces,& setup_gal21_arrays - USE manybody_nequip, ONLY: nequip_add_force_virial,& - nequip_energy_store_force_virial USE manybody_siepmann, ONLY: destroy_siepmann_arrays,& print_nr_ions_siepmann,& setup_siepmann_arrays,& @@ -54,8 +54,9 @@ MODULE manybody_potential USE message_passing, ONLY: mp_para_env_type USE pair_potential_types, ONLY: & ace_type, allegro_type, deepmd_type, ea_type, eam_pot_type, gal21_pot_type, gal21_type, & - gal_pot_type, gal_type, nequip_type, pair_potential_pp_type, pair_potential_single_type, & - siepmann_pot_type, siepmann_type, tersoff_pot_type, tersoff_type + gal_pot_type, gal_type, mace_type, nequip_type, pair_potential_pp_type, & + pair_potential_single_type, siepmann_pot_type, siepmann_type, tersoff_pot_type, & + tersoff_type USE particle_types, ONLY: particle_type USE util, ONLY: sort #include "./base/base_uses.f90" @@ -105,11 +106,11 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_nequip, & - any_siepmann, any_tersoff + any_gal, any_gal21, any_mace, & + any_nequip, any_siepmann, any_tersoff REAL(KIND=dp) :: drij, embed, pot_ace, pot_allegro, & - pot_deepmd, pot_loc, pot_nequip, qr, & - rab2_max, rij(3) + pot_deepmd, pot_loc, pot_mace, & + pot_nequip, qr, rab2_max, rij(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v REAL(KIND=dp), POINTER :: fembed(:) @@ -132,6 +133,7 @@ CONTAINS any_gal21 = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. + any_mace = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. CALL timeset(routineN, handle) @@ -177,6 +179,7 @@ CONTAINS pot => potparm%pot(ikind, jkind)%pot any_tersoff = any_tersoff .OR. ANY(pot%type == tersoff_type) any_nequip = any_nequip .OR. ANY(pot%type == nequip_type) + any_mace = any_mace .OR. ANY(pot%type == mace_type) any_ace = any_ace .OR. ANY(pot%type == ace_type) any_allegro = any_allegro .OR. ANY(pot%type == allegro_type) any_deepmd = any_deepmd .OR. ANY(pot%type == deepmd_type) @@ -189,21 +192,30 @@ CONTAINS ! NEQUIP IF (any_nequip) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_nequip, fist_nonbond_env, & - para_env, use_virial, nequip_type) + CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_nequip, fist_nonbond_env, & + para_env, use_virial, nequip_type) pot_manybody = pot_manybody + pot_nequip END IF ! ALLEGRO IF (any_allegro) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_allegro, fist_nonbond_env, & - para_env, use_virial, allegro_type) + CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_allegro, fist_nonbond_env, & + para_env, use_virial, allegro_type) pot_manybody = pot_manybody + pot_allegro END IF + ! MACE (reuses the NequIP message-passing evaluation path) + IF (any_mace) THEN + NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) + CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_mace, fist_nonbond_env, & + para_env, use_virial, mace_type) + pot_manybody = pot_manybody + pot_mace + END IF ! ACE IF (any_ace) THEN CALL ace_energy_store_force_virial(particle_set, cell, atomic_kind_set, potparm, & @@ -578,8 +590,8 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_nequip, & - any_siepmann, any_tersoff + any_gal, any_gal21, any_mace, & + any_nequip, any_siepmann, any_tersoff REAL(KIND=dp) :: f_eam, fac, fr(3), ptens11, ptens12, ptens13, ptens21, ptens22, ptens23, & ptens31, ptens32, ptens33, rab(3), rab2, rab2_max, rtmp(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi @@ -599,6 +611,7 @@ CONTAINS any_tersoff = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. + any_mace = .FALSE. any_siepmann = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. @@ -660,7 +673,7 @@ CONTAINS END DO END DO IF (any_nequip) THEN - CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! ALLEGRO @@ -670,7 +683,17 @@ CONTAINS END DO END DO IF (any_allegro) THEN - CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + END IF + + ! MACE (reuses the NequIP force/virial accumulation) + DO ikind = 1, nkinds + DO jkind = ikind, nkinds + any_mace = any_mace .OR. ANY(potparm%pot(ikind, jkind)%pot%type == mace_type) + END DO + END DO + IF (any_mace) THEN + CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! starting the force loop diff --git a/src/pair_potential.F b/src/pair_potential.F index 6e2d4af4f5..3f56b1de2c 100644 --- a/src/pair_potential.F +++ b/src/pair_potential.F @@ -31,7 +31,7 @@ MODULE pair_potential USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, compare_pot, deepmd_type, ea_type, ft_type, & ftd_type, gal21_type, gal_type, gp_type, gw_type, ip_type, list_pot, lj_charmm_type, & - lj_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & + lj_type, mace_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & pair_potential_single_type, potential_single_allocation, siepmann_type, tab_type, & tersoff_type, wl_type USE pair_potential_util, ONLY: ener_pot,& @@ -188,7 +188,8 @@ CONTAINS DO k = 1, SIZE(pot%type) SELECT CASE (pot%type(k)) CASE (lj_type, lj_charmm_type, wl_type, gw_type, ft_type, ftd_type, ip_type, & - b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, tab_type, deepmd_type, ace_type) + b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, mace_type, tab_type, & + deepmd_type, ace_type) pot%no_pp = .FALSE. CASE (tersoff_type) pot%no_mb = .FALSE. @@ -206,7 +207,7 @@ CONTAINS END SELECT ! Special case for EAM SELECT CASE (pot%type(k)) - CASE (ea_type, nequip_type, allegro_type, deepmd_type, ace_type) + CASE (ea_type, nequip_type, allegro_type, mace_type, deepmd_type, ace_type) pot%no_mb = .FALSE. END SELECT END DO @@ -605,7 +606,7 @@ CONTAINS nvar = 5 + nvar CASE (ea_type) nvar = 4 + nvar - CASE (nequip_type) + CASE (nequip_type, mace_type) nvar = 1 + nvar CASE (allegro_type) nvar = 1 + nvar @@ -688,7 +689,7 @@ CONTAINS pot_par(nk, 2) = potparm%pot(i, j)%pot%set(1)%eam%drhoar pot_par(nk, 3) = potparm%pot(i, j)%pot%set(1)%eam%acutal pot_par(nk, 4) = potparm%pot(i, j)%pot%set(1)%eam%npoints - CASE (nequip_type, allegro_type) + CASE (nequip_type, allegro_type, mace_type) pot_par(nk, 1) = str2id( & TRIM(potparm%pot(i, j)%pot%set(1)%nequip%pot_file_name)) CASE (ace_type) diff --git a/src/pair_potential_types.F b/src/pair_potential_types.F index 413632847a..23aacc5225 100644 --- a/src/pair_potential_types.F +++ b/src/pair_potential_types.F @@ -54,9 +54,10 @@ MODULE pair_potential_types gal21_type = 18, & tab_type = 19, & deepmd_type = 20, & - ace_type = 21 + ace_type = 21, & + mace_type = 22 - INTEGER, PUBLIC, PARAMETER, DIMENSION(21) :: list_pot = [nn_type, & + INTEGER, PUBLIC, PARAMETER, DIMENSION(22) :: list_pot = [nn_type, & lj_type, & lj_charmm_type, & ft_type, & @@ -76,7 +77,8 @@ MODULE pair_potential_types gal21_type, & tab_type, & deepmd_type, & - ace_type] + ace_type, & + mace_type] ! Shell model INTEGER, PUBLIC, PARAMETER :: nosh_nosh = 0, & @@ -468,7 +470,7 @@ CONTAINS CASE (deepmd_type) IF ((pot1%set(i)%deepmd%deepmd_file_name == pot2%set(i)%deepmd%deepmd_file_name) .AND. & (pot1%set(i)%deepmd%atom_deepmd_type == pot2%set(i)%deepmd%atom_deepmd_type)) mycompare = .TRUE. - CASE (nequip_type, allegro_type) + CASE (nequip_type, allegro_type, mace_type) IF ((pot1%set(i)%nequip%pot_file_name == pot2%set(i)%nequip%pot_file_name) .AND. & (pot1%set(i)%nequip%unit_length == pot2%set(i)%nequip%unit_length) .AND. & (pot1%set(i)%nequip%unit_forces == pot2%set(i)%nequip%unit_forces) .AND. & @@ -1289,7 +1291,7 @@ CONTAINS CALL pair_potential_goodwin_create(p%pot(i)%pot%set(std_dim)%goodwin) CASE (ea_type) CALL pair_potential_eam_create(p%pot(i)%pot%set(std_dim)%eam) - CASE (nequip_type, allegro_type) + CASE (nequip_type, allegro_type, mace_type) CALL pair_potential_nequip_create(p%pot(i)%pot%set(std_dim)%nequip) CASE (ace_type) CALL pair_potential_ace_create(p%pot(i)%pot%set(std_dim)%ace) diff --git a/tests/Fist/regtest-mace/TEST_FILES.toml b/tests/Fist/regtest-mace/TEST_FILES.toml new file mode 100644 index 0000000000..4e86987486 --- /dev/null +++ b/tests/Fist/regtest-mace/TEST_FILES.toml @@ -0,0 +1,3 @@ +# Test of MACE using libtorch https://pytorch.org/cppdocs/installing.html +"mace_test.inp" = [{matcher="M011", tol=1.0E-9, ref=-1532.363300232407482}] +#EOF \ No newline at end of file diff --git a/tests/Fist/regtest-mace/mace-test.xyz b/tests/Fist/regtest-mace/mace-test.xyz new file mode 100644 index 0000000000..de5d503ae3 --- /dev/null +++ b/tests/Fist/regtest-mace/mace-test.xyz @@ -0,0 +1,34 @@ +32 +Lattice="7.23 0.0 0.0 0.0 7.23 0.0 0.0 0.0 7.23" Properties=species:S:1:pos:R:3 pbc="T T T" +Cu 7.19929385 0.07184150 7.15208419 +Cu 7.14664045 2.10236709 2.01651087 +Cu 1.82143618 0.04226192 1.92285339 +Cu 1.99446521 1.95857840 7.03556683 +Cu 0.04124875 0.03433693 3.81793753 +Cu 0.13296440 1.50725440 5.36672362 +Cu 2.05785380 7.16421454 5.34153878 +Cu 1.87904775 2.29484159 3.46181587 +Cu 7.14343690 3.63361819 0.04539203 +Cu 0.07856581 5.42264104 2.00907147 +Cu 1.70046840 3.49032697 1.45196525 +Cu 1.52838588 5.29338639 0.08402179 +Cu 7.04010983 3.63297407 3.45547313 +Cu 0.04993241 5.06858718 5.39256856 +Cu 1.57620067 3.46938961 5.22644546 +Cu 1.85045246 5.47919762 3.50191702 +Cu 3.66469285 0.20246133 0.01048150 +Cu 3.65200112 1.80572076 1.95822174 +Cu 5.62157919 7.09211077 1.57513403 +Cu 5.42582769 1.92125447 7.13092135 +Cu 3.74438701 7.22849521 3.62250140 +Cu 3.71553234 1.93544475 5.27911967 +Cu 5.41897600 6.88436492 5.32462967 +Cu 5.23975470 1.60760854 3.77619340 +Cu 3.72354623 3.71850028 0.15023152 +Cu 3.53953689 5.32915887 1.66932471 +Cu 5.31356798 3.64843433 1.81519742 +Cu 5.24884208 5.54500604 0.06504144 +Cu 3.76661054 3.88873128 3.46537226 +Cu 3.74258866 5.40276336 5.55936212 +Cu 5.45073160 3.94041922 5.40526077 +Cu 5.72305460 5.42694152 3.73428797 diff --git a/tests/Fist/regtest-mace/mace_test.inp b/tests/Fist/regtest-mace/mace_test.inp new file mode 100644 index 0000000000..feabc680c5 --- /dev/null +++ b/tests/Fist/regtest-mace/mace_test.inp @@ -0,0 +1,41 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT mace_test + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD FIST + #STRESS_TENSOR ANALYTICAL + &MM + &FORCEFIELD + &NONBONDED + &MACE + ATOMS Cu + POT_FILE_NAME MACE/MACE_scratch_run-3.model-cp2k.pth + &END MACE + &END NONBONDED + &END FORCEFIELD + &POISSON + &EWALD + EWALD_TYPE none + &END EWALD + &END POISSON + &END MM + &PRINT + &FORCES ON + &END FORCES + #&STRESS_TENSOR ON + #&END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + CELL_FILE_FORMAT XYZ + CELL_FILE_NAME ./mace-test.xyz + &END CELL + &TOPOLOGY + COORD_FILE_FORMAT XYZ + COORD_FILE_NAME ./mace-test.xyz + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index b20afb6390..4bcedaf889 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -3,6 +3,7 @@ # Directories have been reordered according the execution time needed for a gfortran pdbg run using 2 MPI tasks # in case a new directory is added just add it at the top of the list.. # the order will be regularly checked and modified... +Fist/regtest-mace libtorch QS/regtest-floquet QS/regtest-dft-d4-auto-ref libdftd4 libint !ifx QS/regtest-dft-d2-auto-ref libint !ifx diff --git a/tools/docker/scripts/test_misc.sh b/tools/docker/scripts/test_misc.sh index fe39415cc9..d3fc3dc645 100755 --- a/tools/docker/scripts/test_misc.sh +++ b/tools/docker/scripts/test_misc.sh @@ -44,6 +44,7 @@ run_test ./tools/pao-ml/pao-validate.py --threshold=1e-5 --model="tests/QS/regte run_test ./tools/vibronic_spec/main.py ./tools/vibronic_spec/example/example_config.toml run_test mypy --strict ./tools/pao-ml/ +run_test mypy --strict ./tools/mace/create_cp2k_model.py run_test mypy --strict ./tools/minimax_tools/minimax_to_fortran_source.py run_test mypy --strict ./tools/dashboard/generate_dashboard.py run_test mypy --strict ./tools/regtesting/optimize_test_dirs.py diff --git a/tools/mace/create_cp2k_model.py b/tools/mace/create_cp2k_model.py new file mode 100644 index 0000000000..16b097b0ce --- /dev/null +++ b/tools/mace/create_cp2k_model.py @@ -0,0 +1,190 @@ +# pylint: disable=wrong-import-position +""" +Export a trained MACE model to a TorchScript file that can be loaded by CP2K. + +The export script must be executed in an environment where MACE is installed. + +Required packages: + * torch: required for loading and converting the model. + * e3nn: required by MACE for JIT compilation. + * mace-torch: required because the trained MACE model is loaded using + torch and its original model classes must be available. + +The MACE version used for export should be compatible with the version +used for training the model. + +After exporting, the CP2K-compatible `.pth` file can be loaded by CP2K +through the LibTorch interface. No MACE, e3nn, or Python installation is +required during CP2K simulations. + +Usage: + python create_cp2k_model.py my_mace.model --dtype float64 --head default + -> writes my_mace.model-cp2k.pth +""" + +import argparse +import os +from typing import Any, Dict, Optional + +os.environ["TORCH_FORCE_NO_WEIGHTS_ONLY_LOAD"] = "1" + +import torch +from e3nn.util import jit # type: ignore +from e3nn.util.jit import compile_mode # type: ignore + +# Z -> chemical symbol table (index == atomic number). Covers the dummy X plus +# all 118 known elements, matching CP2K's src/common/periodic_table.F. +chemical_symbols = ["X"] + """ + H He Li Be B C N O F Ne Na Mg Al Si P S Cl Ar K Ca Sc Ti V Cr Mn Fe Co + Ni Cu Zn Ga Ge As Se Br Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb + Te I Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu Hf Ta W Re Os + Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm + Md No Lr Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og +""".split() + + +@compile_mode("script") +class CP2K_MACE(torch.nn.Module): + """MACE model wrapped for CP2K's single-dictionary libtorch interface.""" + + head: torch.Tensor + + def __init__(self, model: Any, head: Optional[str] = None) -> None: + super().__init__() + self.model = model + self.register_buffer("atomic_numbers", model.atomic_numbers) + self.register_buffer("r_max", model.r_max) + self.register_buffer("num_interactions", model.num_interactions) + self.num_types: int = int(model.atomic_numbers.shape[0]) + + if not hasattr(model, "heads"): + model.heads = [None] + if head is not None and head in model.heads: + head_idx = model.heads.index(head) + else: + head_idx = len(model.heads) - 1 + self.register_buffer( + "head", torch.tensor(head_idx, dtype=torch.long).unsqueeze(0) + ) + + for param in self.model.parameters(): + param.requires_grad = False + + def forward( + self, data: Dict[str, torch.Tensor] + ) -> Dict[str, Optional[torch.Tensor]]: + pos = data["pos"] + edge_index = data["edge_index"] + unit_shifts = data["edge_cell_shift"] + cell = data["cell"].view(3, 3) + atom_types = data["atom_types"].to(torch.long) + n_atoms = pos.shape[0] + + # one-hot node attributes expected by MACE + node_attrs = torch.nn.functional.one_hot( + atom_types, num_classes=self.num_types + ).to(pos.dtype) + + # real-space edge shift vectors: unit_shifts @ cell (Angstrom) + shifts = torch.matmul(unit_shifts, cell) + + batch = torch.zeros(n_atoms, dtype=torch.long, device=pos.device) + ptr = torch.tensor([0, n_atoms], dtype=torch.long, device=pos.device) + + mace_in: Dict[str, torch.Tensor] = { + "positions": pos, + "node_attrs": node_attrs, + "edge_index": edge_index, + "shifts": shifts, + "unit_shifts": unit_shifts, + "cell": cell, + "batch": batch, + "ptr": ptr, + "head": self.head, + } + + out = self.model( + mace_in, + training=False, + compute_force=True, + compute_virials=True, + compute_stress=False, + compute_displacement=True, + ) + + node_energy = out["node_energy"] + forces = out["forces"] + virials = out["virials"] + + atomic_energy: Optional[torch.Tensor] = None + if node_energy is not None: + atomic_energy = node_energy.unsqueeze(-1) + + virial: Optional[torch.Tensor] = None + if virials is not None: + virial = virials.view(3, 3) + + return { + "atomic_energy": atomic_energy, + "forces": forces, + "virial": virial, + } + + +def build_metadata(model: Any, dtype: str) -> Dict[str, str]: + z = model.atomic_numbers.to(torch.long).tolist() + type_names = " ".join(chemical_symbols[int(zi)] for zi in z) + return { + "num_types": str(len(z)), + "r_max": repr(float(model.r_max)), + "type_names": type_names, + "model_dtype": dtype, + "allow_tf32": "0", + # MACE uses a single global cutoff; leave per-edge-type cutoffs empty so + # CP2K's reader falls back to filling the cutoff matrix with r_max**2. + "per_edge_type_cutoff": "", + } + + +def parse_args() -> argparse.Namespace: + p = argparse.ArgumentParser(description=__doc__) + p.add_argument("model_path", help="Path to the trained MACE .model file") + p.add_argument( + "--head", default=None, help="Model head to export (multi-head models)" + ) + p.add_argument("--dtype", choices=["float64", "float32"], default="float64") + p.add_argument( + "--output", default=None, help="Output path (default: -cp2k.pth)" + ) + return p.parse_args() + + +def main() -> None: + args = parse_args() + model = torch.load(args.model_path, map_location="cpu") + if args.dtype == "float64": + model = model.double() + else: + print("Converting model to float32, this may cause loss of precision.") + model = model.float() + model = model.to("cpu") + + wrapper = CP2K_MACE(model, head=args.head) + wrapper.eval() + + scripted = jit.compile(wrapper) + + metadata = build_metadata(model, args.dtype) + extra_files = {k: v.encode("utf-8") for k, v in metadata.items()} + + out_path = args.output or (args.model_path + "-cp2k.pth") + scripted.save(out_path, _extra_files=extra_files) + + print(f"Wrote CP2K MACE model to: {out_path}") + print("Metadata:") + for k, v in metadata.items(): + print(f" {k}: {v}") + + +if __name__ == "__main__": + main() From 2a9776c2cdfa305a859a805aa7b6aa0c9abe51ff Mon Sep 17 00:00:00 2001 From: SY Wang Date: Tue, 21 Jul 2026 16:43:21 +0800 Subject: [PATCH 16/30] Libxc 7.1.1 -> 7.1.2 (#5612) --- tools/spack/cp2k_deps_p.yaml | 4 ++-- tools/spack/cp2k_deps_s-static.yaml | 4 ++-- tools/spack/cp2k_deps_s.yaml | 4 ++-- tools/toolchain/scripts/stage3/install_libxc.sh | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index 51fdc4d039..894db1cdb2 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -184,7 +184,7 @@ spack: repos: builtin: - commit: 9314cd0194cb79e73b44927e920130cd4379f012 # 2026-07-20 + commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 specs: # Build tools @@ -215,7 +215,7 @@ spack: - "libsmeagol@1.2" - "libvdwxc@0.5.0" - "libvori@220621" - - "libxc@7.1.1" + - "libxc@7.1.2" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index 9ef7f01b69..3f3ef30670 100644 --- a/tools/spack/cp2k_deps_s-static.yaml +++ b/tools/spack/cp2k_deps_s-static.yaml @@ -96,7 +96,7 @@ spack: repos: builtin: - commit: 9314cd0194cb79e73b44927e920130cd4379f012 # 2026-07-20 + commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 specs: # Build tools @@ -113,7 +113,7 @@ spack: - "libfci@0.1.0" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.1.1" + - "libxc@7.1.2" - "libxs@1.0.0" - "libxsmm@2.0.0" - "openblas@0.3.33" diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index 01c50d5ca5..f284738378 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -117,7 +117,7 @@ spack: repos: builtin: - commit: 9314cd0194cb79e73b44927e920130cd4379f012 # 2026-07-20 + commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 specs: # Build tools @@ -138,7 +138,7 @@ spack: # - "libgint@release_v1" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.1.1" + - "libxc@7.1.2" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/toolchain/scripts/stage3/install_libxc.sh b/tools/toolchain/scripts/stage3/install_libxc.sh index 4d151c2a4e..712612cce9 100755 --- a/tools/toolchain/scripts/stage3/install_libxc.sh +++ b/tools/toolchain/scripts/stage3/install_libxc.sh @@ -6,8 +6,8 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -libxc_ver="7.1.1" -libxc_sha256="0e913232757338f345830250bf344d8c60feca5b8ff6c0c6b2229c5189eea11f" +libxc_ver="7.1.2" +libxc_sha256="3915fac94416e4c415534223ea492ad2663f928acf27e98662c861b094a6c306" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh source "${SCRIPT_DIR}"/signal_trap.sh From 11454568b3b64c06fd1d9a04192d590a800ebec1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ole=20Sch=C3=BCtt?= Date: Tue, 21 Jul 2026 14:13:55 +0200 Subject: [PATCH 17/30] Fix conventions in mode_selective.F (#5614) --- src/mode_selective.F | 27 +++++++++++++++------------ tools/conventions/conventions.supp | 3 --- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/mode_selective.F b/src/mode_selective.F index ce371bdc26..9877810b97 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -452,8 +452,8 @@ CONTAINS INTEGER :: nrep CHARACTER(LEN=default_path_length) :: hes_filename - INTEGER :: hesunit, i, j, jj, k, natoms, ncoord, & - output_unit, stat + INTEGER :: hesunit, i, istat, j, jj, k, natoms, & + ncoord, output_unit, stat INTEGER, DIMENSION(:), POINTER :: tmplist REAL(KIND=dp) :: my_val, norm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp @@ -477,12 +477,14 @@ CONTAINS ALLOCATE (tmplist(ncoord)) ! should use the cp_fm_read_unformatted... + istat = 0 DO i = 1, ncoord READ (UNIT=hesunit, IOSTAT=stat) ms_vib%hes_bfgs(:, i) + istat = istat + stat END DO CALL close_file(hesunit) IF (output_unit > 0) THEN - IF (stat /= 0) THEN + IF (istat /= 0) THEN WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading HESSIAN **" ELSE WRITE (output_unit, FMT="(/,T2,A)") & @@ -600,16 +602,17 @@ CONTAINS statint = 0 READ (UNIT=hesunit) ms_vib%b_mat READ (UNIT=hesunit, IOSTAT=stat) ms_vib%s_mat - IF (calc_intens) READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) - IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & - "intensities are requested but not present in restart file **" + IF (stat /= 0 .AND. output_unit > 0) THEN + WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" + END IF + IF (calc_intens) THEN + READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) + IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & + "intensities are requested but not present in restart file **" + END IF CALL close_file(hesunit) - IF (output_unit > 0) THEN - IF (stat /= 0) THEN - WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" - ELSE - WRITE (output_unit, FMT="(/,T2,A)") "*** RESTART has been read successfully ***" - END IF + IF (stat == 0 .AND. statint == 0 .AND. output_unit > 0) THEN + WRITE (output_unit, FMT="(/,T2,A)") "*** MS_RESTART has been read successfully ***" END IF END IF CALL para_env%bcast(ms_vib%b_mat) diff --git a/tools/conventions/conventions.supp b/tools/conventions/conventions.supp index cc7033ad48..758c77d9a2 100644 --- a/tools/conventions/conventions.supp +++ b/tools/conventions/conventions.supp @@ -95,7 +95,6 @@ kpsym.F: Found GOTO statement in procedure "primlatt" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "remove" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "sppt2" https://cp2k.org/conv#c201 libcp2k.F: Found type eri2array without initializer https://cp2k.org/conv#c016 -libgrpp_integrals.F: Module "libgrpp" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 libint_wrapper.F: Found type cp_libint_t without initializer https://cp2k.org/conv#c016 libint_wrapper.F: Module "libint_f" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 library_tests.F: Found CALL RANDOM_NUMBER in procedure "copy_test" https://cp2k.org/conv#c104 @@ -153,7 +152,6 @@ message_passing.F: Module "pmpi_f08" USEd without ONLY clause or not PRIVATE htt message_passing.F: USE statement at (1) has no ONLY qualifier [-Wuse-without-only] message_passing.fypp: Type mismatch between actual argument at (1) and actual argument at (2) (COMPLEX(8)/COMPLEX(4)). mltfftsg_tools.F: Found WRITE statement with hardcoded unit in "ctrig" https://cp2k.org/conv#c012 -mode_selective.F: Found READ with unchecked STAT in "bfgs_guess" https://cp2k.org/conv#c001 mp_perf_test.F: Module "mpi_f08" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 negf_methods.F: Found CALL with NULL() as argument in procedure "converge_density" https://cp2k.org/conv#c007 negf_methods.F: Found CALL with NULL() as argument in procedure "guess_fermi_level" https://cp2k.org/conv#c007 @@ -171,7 +169,6 @@ ps_wavelet_kernel.F: Found WRITE statement with hardcoded unit in "indices" http ps_wavelet_scaling_function.F: Found WRITE statement with hardcoded unit in "ftest" https://cp2k.org/conv#c012 pwdft_environment_types.F: Module "sirius" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 pw_grids.F: Found WRITE statement with hardcoded unit in "pw_grid_sort" https://cp2k.org/conv#c012 -qcschema.F: Module "hdf5_wrapper" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 qs_active_space_methods.F: Found type eri_fcidump_checksum without initializer https://cp2k.org/conv#c016 qs_active_space_methods.F: Found type eri_fcidump_print without initializer https://cp2k.org/conv#c016 qs_charge_mixing.F: Module "mctc_env" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 From 467dd456101663359787e2f8533679e199b27fba Mon Sep 17 00:00:00 2001 From: Juerg Hutter Date: Wed, 22 Jul 2026 09:57:20 +0200 Subject: [PATCH 18/30] Native implementation for xTB spin polarisation (#5611) --- data/xTB_sp_param_030 | 82 ++ data/xTB_sp_param_060 | 96 ++ docs/methods/semiempiricals/xtb.md | 5 +- src/CMakeLists.txt | 1 + src/common/bibliography.F | 9 +- src/cp2k_debug.F | 14 +- src/cp_control_types.F | 16 +- src/cp_control_utils.F | 29 +- src/input_cp2k_tb.F | 21 + src/qs_diis.F | 3 + src/qs_energy_types.F | 3 +- src/qs_environment.F | 10 +- src/qs_initial_guess.F | 7 +- src/qs_kinetic.F | 2 - src/qs_ks_utils.F | 2 +- src/qs_linres_kernel.F | 6 +- src/qs_tddfpt2_fhxc_forces.F | 14 +- src/qs_tddfpt2_forces.F | 5 +- src/response_solver.F | 2 +- src/xtb_coulomb.F | 7 + src/xtb_ehess.F | 9 +- src/xtb_ehess_force.F | 13 + src/xtb_ks_matrix.F | 9 +- src/xtb_parameters.F | 107 +++ src/xtb_spinpol.F | 871 ++++++++++++++++++ src/xtb_types.F | 31 +- tests/QS/regtest-debug-2/TEST_FILES.toml | 15 +- tests/QS/regtest-debug-2/h2o_admm_gapw.inp | 2 +- tests/QS/regtest-debug-2/h2o_admm_x.inp | 2 +- tests/QS/regtest-debug-2/h2o_hfx.inp | 2 +- tests/QS/regtest-debug-2/h2o_hfx_admm.inp | 7 +- tests/QS/regtest-debug-2/h2o_lri.inp | 9 +- tests/QS/regtest-debug-2/h2o_pade_fd.inp | 7 +- tests/QS/regtest-debug-2/h2o_pbe_fd.inp | 7 +- tests/QS/regtest-debug-2/h2o_tpss_fd.inp | 10 +- tests/QS/regtest-debug-7/TEST_FILES.toml | 26 +- tests/QS/regtest-debug-7/ch2o_gapw_t1.inp | 7 +- tests/QS/regtest-debug-7/ch2o_gapw_t2.inp | 11 +- tests/QS/regtest-debug-7/ch2o_gapw_t3.inp | 15 +- tests/QS/regtest-debug-7/ch2o_gapw_t4.inp | 13 +- tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp | 13 +- tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp | 7 +- tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp | 13 +- tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp | 13 +- tests/QS/regtest-debug-7/ch2o_vdw_t1.inp | 5 +- tests/QS/regtest-debug-7/h2o_gapw_t5.inp | 11 +- tests/QS/regtest-debug-7/h2o_gapw_t6.inp | 11 +- tests/QS/regtest-debug-7/h2o_gapw_t7.inp | 13 +- tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp | 11 +- tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp | 9 +- tests/QS/regtest-polar/TEST_FILES.toml | 1 + tests/QS/regtest-polar/xTB_LRraman_spin.inp | 63 ++ tests/SE/regtest-2-1/TEST_FILES.toml | 2 +- tests/SE/regtest-2-2/TEST_FILES.toml | 2 +- tests/SE/regtest/TEST_FILES.toml | 6 +- tests/TEST_DIRS | 1 + tests/xTB/regtest-1/TEST_FILES.toml | 4 +- tests/xTB/regtest-debug/TEST_FILES.toml | 1 + tests/xTB/regtest-debug/ch2o_t11.inp | 65 ++ tests/xTB/regtest-spinpol/Fecp2_1.inp | 72 ++ tests/xTB/regtest-spinpol/Fecp2_5.inp | 75 ++ tests/xTB/regtest-spinpol/Fecp2_5_sp.inp | 82 ++ tests/xTB/regtest-spinpol/Fecp2_5_spext.inp | 79 ++ tests/xTB/regtest-spinpol/Ferrocene.inp | 64 ++ tests/xTB/regtest-spinpol/TEST_FILES.toml | 21 + tests/xTB/regtest-spinpol/ch2o.inp | 43 + tests/xTB/regtest-spinpol/ch2o_force.inp | 49 + tests/xTB/regtest-spinpol/ch2o_kp_force.inp | 54 ++ tests/xTB/regtest-spinpol/ch2o_kp_stress.inp | 54 ++ tests/xTB/regtest-spinpol/ch2o_polar.inp | 63 ++ tests/xTB/regtest-spinpol/ch2o_stress.inp | 51 + tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp | 67 ++ tests/xTB/regtest-stda-force/TEST_FILES.toml | 8 +- tests/xTB/regtest-stda-force/h2o_f12.inp | 1 - tests/xTB/regtest-stda-force/h2o_f13.inp | 1 - tests/xTB/regtest-stda-force/h2o_f14.inp | 1 - tests/xTB/regtest-stda-force/h2o_f15.inp | 2 +- tests/xTB/regtest-stda-force/h2o_f16.inp | 2 +- tests/xTB/regtest-stda-force/h2o_f17.inp | 2 +- tests/xTB/regtest-stda-force/h2o_f18.inp | 1 - tests/xTB/regtest-stda-force/h2o_f19.inp | 2 +- tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml | 4 +- 82 files changed, 2386 insertions(+), 170 deletions(-) create mode 100644 data/xTB_sp_param_030 create mode 100644 data/xTB_sp_param_060 create mode 100644 src/xtb_spinpol.F create mode 100644 tests/QS/regtest-polar/xTB_LRraman_spin.inp create mode 100644 tests/xTB/regtest-debug/ch2o_t11.inp create mode 100644 tests/xTB/regtest-spinpol/Fecp2_1.inp create mode 100644 tests/xTB/regtest-spinpol/Fecp2_5.inp create mode 100644 tests/xTB/regtest-spinpol/Fecp2_5_sp.inp create mode 100644 tests/xTB/regtest-spinpol/Fecp2_5_spext.inp create mode 100644 tests/xTB/regtest-spinpol/Ferrocene.inp create mode 100644 tests/xTB/regtest-spinpol/TEST_FILES.toml create mode 100644 tests/xTB/regtest-spinpol/ch2o.inp create mode 100644 tests/xTB/regtest-spinpol/ch2o_force.inp create mode 100644 tests/xTB/regtest-spinpol/ch2o_kp_force.inp create mode 100644 tests/xTB/regtest-spinpol/ch2o_kp_stress.inp create mode 100644 tests/xTB/regtest-spinpol/ch2o_polar.inp create mode 100644 tests/xTB/regtest-spinpol/ch2o_stress.inp create mode 100644 tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp diff --git a/data/xTB_sp_param_030 b/data/xTB_sp_param_030 new file mode 100644 index 0000000000..cdb39466f7 --- /dev/null +++ b/data/xTB_sp_param_030 @@ -0,0 +1,82 @@ +# Spin paramters for gfn1-xTB (units Eh) +# +#High-throughput screening of spin states for transition metal +#complexes with spin-polarized extended tight-binding methods +#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme +#J Comput Chem. 44:2120-2129 (2023) +# +# Sign change from suppl material needed! +# +# element Wss Wsp Wpp Wsd Wpd Wdd +1 -0.071550 -0.000000 -0.000000 -0.000000 -0.000000 -0.000000 +2 -0.614675 -0.033587 -0.125800 -0.000000 -0.000000 -0.000000 +3 -0.017775 -0.013937 -0.018050 -0.000000 -0.000000 -0.000000 +4 -0.022850 -0.018612 -0.017575 -0.000000 -0.000000 -0.000000 +5 -0.027325 -0.022037 -0.019600 -0.000000 -0.000000 -0.000000 +6 -0.030200 -0.025025 -0.022725 -0.000000 -0.000000 -0.000000 +7 -0.033000 -0.027475 -0.025475 -0.000000 -0.000000 -0.000000 +8 -0.035100 -0.029500 -0.027825 -0.000000 -0.000000 -0.000000 +9 -0.036900 -0.031200 -0.029900 -0.000000 -0.000000 -0.000000 +10 -0.055008 -0.012830 -0.022600 -0.011925 -0.016737 -0.080725 +11 -0.015100 -0.013337 -0.023025 -0.000000 -0.000000 -0.000000 +12 -0.016500 -0.013175 -0.017400 -0.000000 -0.000000 -0.000000 +13 -0.018250 -0.013837 -0.014000 -0.008175 -0.011637 -0.012875 +14 -0.019525 -0.015000 -0.014350 -0.008437 -0.011637 -0.014075 +15 -0.020550 -0.016112 -0.014900 -0.009300 -0.011975 -0.014825 +16 -0.021325 -0.017012 -0.015500 -0.009987 -0.012137 -0.014950 +17 -0.021825 -0.017712 -0.016075 -0.010987 -0.012612 -0.015075 +18 -0.342475 -0.077825 -0.120675 -0.015500 -0.023075 -0.051925 +19 -0.010650 -0.010900 -0.016375 -0.000000 -0.000000 -0.000000 +20 -0.011800 -0.010387 -0.013350 -0.005562 -0.003512 -0.010200 +21 -0.012725 -0.010912 -0.013850 -0.004787 -0.002412 -0.012525 +22 -0.013525 -0.011225 -0.014675 -0.004350 -0.001975 -0.013900 +23 -0.014075 -0.011512 -0.015275 -0.004037 -0.001725 -0.014900 +24 -0.015175 -0.012450 -0.021225 -0.004150 -0.001662 -0.013875 +25 -0.015000 -0.011787 -0.016725 -0.003550 -0.001325 -0.016525 +26 -0.015400 -0.011925 -0.017850 -0.003300 -0.001162 -0.017125 +27 -0.015825 -0.012037 -0.018700 -0.003137 -0.001050 -0.017750 +28 -0.016150 -0.012175 -0.019700 -0.002987 -0.000950 -0.018300 +29 -0.017150 -0.013175 -0.030375 -0.002775 -0.000650 -0.017475 +30 -0.016850 -0.012312 -0.021450 -0.000000 -0.000000 -0.000000 +31 -0.017225 -0.012787 -0.013400 -0.008525 -0.013000 -0.015775 +32 -0.017550 -0.013375 -0.013575 -0.008112 -0.012825 -0.017525 +33 -0.017750 -0.013762 -0.013600 -0.007987 -0.012387 -0.017550 +34 -0.017975 -0.014087 -0.013625 -0.008162 -0.011962 -0.017200 +35 -0.018100 -0.014375 -0.013725 -0.008275 -0.011762 -0.016675 +36 -0.299025 -0.066587 -0.101875 -0.012575 -0.021287 -0.048300 +37 -0.009550 -0.009600 -0.016725 -0.000000 -0.000000 -0.000000 +38 -0.010650 -0.009237 -0.012525 -0.000000 -0.000000 -0.000000 +39 -0.011425 -0.009487 -0.012300 -0.006725 -0.003987 -0.009725 +40 -0.011950 -0.009612 -0.013525 -0.006150 -0.003075 -0.010725 +41 -0.012575 -0.010262 -0.019075 -0.006062 -0.002887 -0.010475 +42 -0.012925 -0.010500 -0.022225 -0.005562 -0.002362 -0.010925 +43 -0.013150 -0.010662 -0.024725 -0.005112 -0.002025 -0.011300 +44 -0.013375 -0.010750 -0.027500 -0.004750 -0.001662 -0.011625 +45 -0.013525 -0.010912 -0.032025 -0.004400 -0.001425 -0.011875 +46 -0.018975 -0.023937 -0.180200 -0.002087 -0.001487 -0.011325 +47 -0.013925 -0.011100 -0.039800 -0.003887 -0.001012 -0.012400 +48 -0.013850 -0.010500 -0.019650 -0.000000 -0.000000 -0.000000 +49 -0.014125 -0.010550 -0.011575 -0.005062 -0.009375 -0.010100 +50 -0.014300 -0.010912 -0.011675 -0.004600 -0.009125 -0.011875 +51 -0.014525 -0.011125 -0.011650 -0.004375 -0.008725 -0.012525 +52 -0.014525 -0.011237 -0.011550 -0.004137 -0.008162 -0.012250 +53 -0.014575 -0.011337 -0.011450 -0.004450 -0.008312 -0.012825 +54 -0.255850 -0.055587 -0.085625 -0.004662 -0.013337 -0.037350 +55 -0.008200 -0.008575 -0.015300 -0.000000 -0.000000 -0.000000 +56 -0.009275 -0.008200 -0.011250 -0.000000 -0.000000 -0.000000 +57 -0.009925 -0.008412 -0.011400 -0.005925 -0.003312 -0.009025 +72 -0.012175 -0.009625 -0.012600 -0.007637 -0.004187 -0.010425 +73 -0.012325 -0.009575 -0.013375 -0.007137 -0.003475 -0.010925 +74 -0.012500 -0.009562 -0.014450 -0.006725 -0.002950 -0.011225 +75 -0.012600 -0.009662 -0.014800 -0.006275 -0.002600 -0.011450 +76 -0.012600 -0.009200 -0.020600 -0.005950 -0.002075 -0.011550 +77 -0.012725 -0.009275 -0.021000 -0.005700 -0.001912 -0.011650 +78 -0.013075 -0.010212 -0.033575 -0.005550 -0.001812 -0.011150 +79 -0.013150 -0.009962 -0.053000 -0.005287 -0.001462 -0.011175 +80 -0.013025 -0.009187 -0.029250 -0.000000 -0.000000 -0.000000 +81 -0.013275 -0.009112 -0.010725 -0.000000 -0.000000 -0.000000 +82 -0.013475 -0.009350 -0.010975 -0.000000 -0.000000 -0.000000 +83 -0.013625 -0.009537 -0.010975 -0.000000 -0.000000 -0.000000 +84 -0.013725 -0.009625 -0.010850 -0.000000 -0.000000 -0.000000 +85 -0.013775 -0.009737 -0.010725 -0.002612 -0.007362 -0.011925 +86 -0.254400 -0.050400 -0.080625 -0.001087 -0.011050 -0.035175 diff --git a/data/xTB_sp_param_060 b/data/xTB_sp_param_060 new file mode 100644 index 0000000000..7356b7b75f --- /dev/null +++ b/data/xTB_sp_param_060 @@ -0,0 +1,96 @@ +# Spin paramters for gfn1-xTB (units Eh) +# +#High-throughput screening of spin states for transition metal +#complexes with spin-polarized extended tight-binding methods +#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme +#J Comput Chem. 44:2120-2129 (2023) +# +# Sign change from suppl material needed! +# +# element Wss Wsp Wpp Wsd Wpd Wdd + 1 -0.0716250 0.0000000 0.0000000 0.0000000 0.0000000 0.0000000 + 2 -0.0865500 -0.0386630 -0.0674250 0.0000000 0.0000000 0.0000000 + 3 -0.0178000 -0.0139500 -0.0180500 0.0000000 0.0000000 0.0000000 + 4 -0.0229750 -0.0186250 -0.0175750 0.0000000 0.0000000 0.0000000 + 5 -0.0272500 -0.0219370 -0.0195750 0.0000000 0.0000000 0.0000000 + 6 -0.0305000 -0.0250250 -0.0226750 0.0000000 0.0000000 0.0000000 + 7 -0.0330750 -0.0275000 -0.0254500 0.0000000 0.0000000 0.0000000 + 8 -0.0350750 -0.0295380 -0.0278500 0.0000000 0.0000000 0.0000000 + 9 -0.0369000 -0.0311870 -0.0299250 0.0000000 0.0000000 0.0000000 + 10 -0.0383000 -0.0326250 -0.0317250 -0.0141250 -0.0152500 -0.0413500 + 11 -0.0150750 -0.0133370 -0.0229250 0.0000000 0.0000000 0.0000000 + 12 -0.0165000 -0.0130750 -0.0175000 -0.0093750 -0.0179630 -0.0223500 + 13 -0.0182500 -0.0138380 -0.0139750 -0.0082250 -0.0117000 -0.0129000 + 14 -0.0195250 -0.0150000 -0.0143750 -0.0084500 -0.0116120 -0.0140000 + 15 -0.0205750 -0.0161250 -0.0149000 -0.0093000 -0.0119870 -0.0148250 + 16 -0.0213250 -0.0170130 -0.0155000 -0.0100370 -0.0121750 -0.0149500 + 17 -0.0217500 -0.0177130 -0.0160500 -0.0109750 -0.0126620 -0.0150750 + 18 -0.0221500 -0.0183630 -0.0165500 -0.0118870 -0.0131130 -0.0153000 + 19 -0.0106500 -0.0109000 -0.0164750 0.0000000 0.0000000 0.0000000 + 20 -0.0118000 -0.0104500 -0.0134500 -0.0055000 -0.0035130 -0.0101750 + 21 -0.0127250 -0.0108620 -0.0138500 -0.0047880 -0.0024130 -0.0125250 + 22 -0.0134250 -0.0112380 -0.0146500 -0.0043380 -0.0019750 -0.0138750 + 23 -0.0140750 -0.0114630 -0.0152750 -0.0040500 -0.0017250 -0.0149250 + 24 -0.0144750 -0.0116120 -0.0160000 -0.0037250 -0.0014630 -0.0157750 + 25 -0.0149000 -0.0118000 -0.0167250 -0.0034870 -0.0013120 -0.0165000 + 26 -0.0154000 -0.0120250 -0.0177500 -0.0032880 -0.0011630 -0.0171250 + 27 -0.0157000 -0.0120250 -0.0187000 -0.0031500 -0.0010250 -0.0177500 + 28 -0.0161500 -0.0122000 -0.0197000 -0.0030370 -0.0009130 -0.0183000 + 29 -0.0166500 -0.0123500 -0.0203000 -0.0028250 -0.0008620 -0.0188250 + 30 -0.0168500 -0.0123250 -0.0214500 0.0000000 0.0000000 0.0000000 + 31 -0.0172250 -0.0128120 -0.0134000 -0.0085250 -0.0130000 -0.0157750 + 32 -0.0174500 -0.0133500 -0.0135500 -0.0081120 -0.0128130 -0.0175250 + 33 -0.0178750 -0.0137630 -0.0135750 -0.0080500 -0.0123250 -0.0176500 + 34 -0.0180000 -0.0141250 -0.0136250 -0.0081500 -0.0120130 -0.0172000 + 35 -0.0181000 -0.0143750 -0.0136750 -0.0082750 -0.0117500 -0.0167750 + 36 -0.0181250 -0.0145500 -0.0137000 -0.0086880 -0.0118000 -0.0164250 + 37 -0.0095500 -0.0096000 -0.0167250 0.0000000 0.0000000 0.0000000 + 38 -0.0105750 -0.0092870 -0.0125500 -0.0074000 -0.0059000 -0.0079500 + 39 -0.0115000 -0.0098250 -0.0136000 -0.0072880 -0.0046250 -0.0090000 + 40 -0.0121500 -0.0099880 -0.0162250 -0.0066250 -0.0036250 -0.0098750 + 41 -0.0125750 -0.0102620 -0.0191750 -0.0060630 -0.0029250 -0.0104750 + 42 -0.0129000 -0.0105000 -0.0222250 -0.0055750 -0.0024250 -0.0109000 + 43 -0.0131250 -0.0106250 -0.0247250 -0.0051250 -0.0020120 -0.0113000 + 44 -0.0133500 -0.0107620 -0.0276000 -0.0047370 -0.0016750 -0.0116000 + 45 -0.0135500 -0.0108380 -0.0320500 -0.0043750 -0.0014250 -0.0118750 + 46 -0.0136500 -0.0109440 -0.0287000 -0.0041250 -0.0012880 -0.0121250 + 47 -0.0139250 -0.0110500 -0.0241750 -0.0038870 -0.0009630 -0.0124000 + 48 -0.0138500 -0.0105000 -0.0196500 0.0000000 0.0000000 0.0000000 + 49 -0.0142250 -0.0105500 -0.0115750 -0.0050370 -0.0093750 -0.0100000 + 50 -0.0143000 -0.0108750 -0.0116750 -0.0046880 -0.0090750 -0.0118750 + 51 -0.0145250 -0.0111250 -0.0116250 -0.0043750 -0.0087130 -0.0124250 + 52 -0.0145250 -0.0112500 -0.0115750 -0.0041870 -0.0081750 -0.0121750 + 53 -0.0146500 -0.0113870 -0.0114750 -0.0044620 -0.0083620 -0.0128250 + 54 -0.0146500 -0.0114250 -0.0114500 -0.0048750 -0.0085750 -0.0132000 + 55 -0.0082000 -0.0085880 -0.0153000 0.0000000 0.0000000 0.0000000 + 56 -0.0092500 -0.0083000 -0.0113750 -0.0063870 -0.0042250 -0.0079250 + 57 -0.0099000 -0.0084250 -0.0114000 -0.0059370 -0.0033750 -0.0090250 + 58 -0.0881750 -0.0066380 -0.0019250 -0.0017000 -0.0017000 -0.0234250 + 59 -0.0890750 -0.0065000 -0.0009500 -0.0015370 -0.0017370 -0.0237000 + 60 -0.0901000 -0.0063750 -0.0000750 -0.0014630 -0.0016250 -0.0230250 + 61 -0.0908000 -0.0064880 0.0004500 -0.0013000 -0.0016500 -0.0226250 + 62 -0.0918250 -0.0065380 0.0014000 -0.0012750 -0.0017250 -0.0222250 + 63 -0.0922250 -0.0065380 0.0017250 -0.0012000 -0.0018000 -0.0218250 + 64 -0.0928812 -0.0065798 0.0024101 -0.0011021 -0.0016846 -0.0209135 + 65 -0.0936096 -0.0066189 0.0030779 -0.0010125 -0.0016808 -0.0201625 + 66 -0.0943380 -0.0066581 0.0037457 -0.0009229 -0.0016769 -0.0194115 + 67 -0.0951750 -0.0067500 0.0042250 -0.0008380 -0.0016250 -0.0190000 + 68 -0.0956500 -0.0067250 0.0040000 -0.0007370 -0.0007630 -0.0176000 + 69 -0.0963500 -0.0067370 0.0044000 -0.0006750 -0.0007065 -0.0160000 + 70 -0.0958500 -0.0066500 0.0024000 -0.0007500 -0.0008000 -0.0175500 + 71 -0.1086250 -0.0079000 0.0063250 -0.0047000 -0.0007120 -0.0269000 + 72 -0.0121750 -0.0096750 -0.0126250 -0.0076250 -0.0041130 -0.0104250 + 73 -0.0123000 -0.0095750 -0.0134000 -0.0071380 -0.0034630 -0.0109250 + 74 -0.0125000 -0.0094620 -0.0144500 -0.0066880 -0.0029130 -0.0112500 + 75 -0.0126000 -0.0093310 -0.0148000 -0.0063000 -0.0026130 -0.0114500 + 76 -0.0127000 -0.0092000 -0.0205750 -0.0059380 -0.0021120 -0.0115500 + 77 -0.0127500 -0.0092750 -0.0209250 -0.0056880 -0.0019120 -0.0116000 + 78 -0.0127500 -0.0092250 -0.0222500 -0.0054370 -0.0017870 -0.0117000 + 79 -0.0129000 -0.0089380 -0.0257625 -0.0052500 -0.0015000 -0.0117750 + 80 -0.0129250 -0.0091870 -0.0292750 0.0000000 0.0000000 0.0000000 + 81 -0.0133500 -0.0091120 -0.0107250 0.0000000 0.0000000 0.0000000 + 82 -0.0135750 -0.0094250 -0.0110000 0.0000000 0.0000000 0.0000000 + 83 -0.0136750 -0.0095380 -0.0109500 0.0000000 0.0000000 0.0000000 + 84 -0.0137500 -0.0096380 -0.0108500 0.0000000 0.0000000 0.0000000 + 85 -0.0137750 -0.0096750 -0.0107250 -0.0026000 -0.0073630 -0.0119000 + 86 -0.0139000 -0.0097380 -0.0106500 -0.0028750 -0.0078120 -0.0130000 diff --git a/docs/methods/semiempiricals/xtb.md b/docs/methods/semiempiricals/xtb.md index d70feed8b4..1f2763f148 100644 --- a/docs/methods/semiempiricals/xtb.md +++ b/docs/methods/semiempiricals/xtb.md @@ -287,9 +287,8 @@ GFN2-xTB method. Please note that k-points are fully supported for tblite in CP2 In case of open-shell calculations, a spin-polarization term can be enabled with the [LSD](#CP2K_INPUT.FORCE_EVAL.DFT.UKS) keyword in CP2K. In this case, tblite automatically allows the -usage of spGFN2-xTB for calculations as described in -[Neugebauer2023](https://onlinelibrary.wiley.com/doi/full/10.1002/jcc.27185). An example for triplet -oxygen is shown here. +usage of spGFN2-xTB for calculations as described in [Neugebauer2023](#Neugebauer2023). An example +for triplet oxygen is shown here. ``` &FORCE_EVAL diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a016d826a6..c21217a7ac 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -884,6 +884,7 @@ list( xray_diffraction.F xtb_qresp.F xtb_coulomb.F + xtb_spinpol.F xtb_eeq.F xtb_ehess.F xtb_ehess_force.F diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 38ca082835..2f13f2f27d 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -97,7 +97,7 @@ MODULE bibliography FuHo1983, MethfesselPaxton1989, Marzari1999, dosSantos2023, Mermin1965, & KuhneHeskeProdan2020, Schreder2021, Schreder2024_1, Schreder2024_2, & Shiga2022, Lindh1995, Chai2024a, Rullan2026, Sundararaman2017, Andreussi2019, & - Chai2025a + Chai2025a, Neugebauer2023 CONTAINS @@ -796,6 +796,13 @@ CONTAINS source="J. Chem. Theory Comput.", volume="15", pages="1652-1671", & year=2019, doi="10.1021/acs.jctc.8b01176") + CALL add_reference(key=Neugebauer2023, & + authors=s2a("H. Neugebauer", "B. Baedorf", "S. Ehlert", "A. Hansen", "S. Grimme"), & + title="High-throughput screening of spin states for transition metal complexes "// & + "with spin-polarized extended tight-binding methods", & + source="J. Comput. Chem.", volume="44", pages="2120-2129", & + year=2023, doi="10.1002/jcc.27185") + CALL add_reference(key=Katbashev2025, & authors=s2a("A. Katbashev", "M. Stahn", "T. Rose", "V. Alizadeh", & "M. Friede", "C. Plett", "P. Steinbach", "S. Ehlert"), & diff --git a/src/cp2k_debug.F b/src/cp2k_debug.F index c426ba1006..73184d0fb2 100644 --- a/src/cp2k_debug.F +++ b/src/cp2k_debug.F @@ -98,7 +98,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(3) :: dipole_moment, dipole_numer, err, & my_maxerr, poldir REAL(KIND=dp), DIMENSION(3, 2) :: dipn - REAL(KIND=dp), DIMENSION(3, 3) :: polar_analytic, polar_numeric + REAL(KIND=dp), DIMENSION(3, 3) :: polar_analytic, polar_numeric, polerr REAL(KIND=dp), DIMENSION(9) :: pvals REAL(KIND=dp), DIMENSION(:, :), POINTER :: analyt_forces, numer_forces TYPE(cell_type), POINTER :: cell @@ -569,6 +569,7 @@ CONTAINS polar_numeric(1:3, k) = 0.5_dp*(dipn(1:3, 2) - dipn(1:3, 1))/de END DO IF (iw > 0) THEN + polerr = 0.0_dp WRITE (UNIT=iw, FMT="(/,(T2,A))") & "DEBUG|========================= POLARIZABILITY ================================", & "DEBUG| Coordinates P(numerical) P(analytical) Difference Error [%]" @@ -579,6 +580,7 @@ CONTAINS derr = 100._dp*dd/polar_analytic(k, j) WRITE (UNIT=iw, FMT="(T2,A,T12,A1,A1,T21,F16.8,T38,F16.8,T56,G12.3,T72,F9.3)") & "DEBUG|", ACHAR(119 + k), ACHAR(119 + j), polar_numeric(k, j), polar_analytic(k, j), dd, derr + polerr(k, j) = derr ELSE WRITE (UNIT=iw, FMT="(T2,A,T12,A1,A1,T21,F16.8,T38,F16.8,T56,G12.3)") & "DEBUG|", ACHAR(119 + k), ACHAR(119 + j), polar_numeric(k, j), polar_analytic(k, j), dd @@ -588,6 +590,16 @@ CONTAINS WRITE (UNIT=iw, FMT="((T2,A))") & "DEBUG|=========================================================================" WRITE (UNIT=iw, FMT="(T2,A,T61,E20.12)") ' POLAR : CheckSum =', SUM(polar_analytic) + IF (ANY(ABS(polerr(1:3, 1:3)) > maxerr)) THEN + message = "A mismatch between analytical and numerical polarizabilities "// & + "has been detected. Check the implementation of the "// & + "analytical polarizabilitie calculation" + IF (stop_on_mismatch) THEN + CPABORT(message) + ELSE + CPWARN(message) + END IF + END IF END IF ELSE CALL cp_warn(__LOCATION__, "Debug of polarizabilities only for Quickstep code available") diff --git a/src/cp_control_types.F b/src/cp_control_types.F index 4470a26447..ff28629fb2 100644 --- a/src/cp_control_types.F +++ b/src/cp_control_types.F @@ -278,6 +278,7 @@ MODULE cp_control_types INTEGER :: vdw_type = -1 CHARACTER(LEN=default_path_length) :: parameter_file_path = "" CHARACTER(LEN=default_path_length) :: parameter_file_name = "" + CHARACTER(LEN=default_path_length) :: spinpol_param_file_name = "" ! CHARACTER(LEN=default_path_length) :: dispersion_parameter_file = "" REAL(KIND=dp) :: epscn = 0.0_dp @@ -296,6 +297,7 @@ MODULE cp_control_types ! LOGICAL :: xb_interaction = .FALSE. LOGICAL :: do_nonbonded = .FALSE. + LOGICAL :: do_spinpol = .FALSE. LOGICAL :: coulomb_interaction = .FALSE. LOGICAL :: coulomb_lr = .FALSE. LOGICAL :: tb3_interaction = .FALSE. @@ -310,7 +312,11 @@ MODULE cp_control_types DIMENSION(:, :), POINTER :: kab_param => NULL() INTEGER, DIMENSION(:, :), POINTER :: kab_types => NULL() INTEGER :: kab_nval = 0 - REAL, DIMENSION(:), POINTER :: kab_vals => NULL() + REAL(KIND=dp), DIMENSION(:), POINTER :: kab_vals => NULL() + ! + INTEGER, DIMENSION(:), POINTER :: spinpol_type => NULL() + REAL(KIND=dp), DIMENSION(:, :), & + POINTER :: spinpol_vals => NULL() ! TYPE(pair_potential_p_type), POINTER :: nonbonded => NULL() REAL(KIND=dp) :: eps_pair = 0.0_dp @@ -1303,6 +1309,8 @@ CONTAINS NULLIFY (xtb_control%kab_types) NULLIFY (xtb_control%nonbonded) NULLIFY (xtb_control%rcpair) + NULLIFY (xtb_control%spinpol_type) + NULLIFY (xtb_control%spinpol_vals) END SUBROUTINE xtb_control_create @@ -1329,6 +1337,12 @@ CONTAINS IF (ASSOCIATED(xtb_control%nonbonded)) THEN CALL pair_potential_p_release(xtb_control%nonbonded) END IF + IF (ASSOCIATED(xtb_control%spinpol_type)) THEN + DEALLOCATE (xtb_control%spinpol_type) + END IF + IF (ASSOCIATED(xtb_control%spinpol_vals)) THEN + DEALLOCATE (xtb_control%spinpol_vals) + END IF DEALLOCATE (xtb_control) END IF END SUBROUTINE xtb_control_release diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index abe607899e..567a1eda4f 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -985,11 +985,12 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'read_qs_section' + CHARACTER(LEN=2) :: element_symbol CHARACTER(LEN=default_string_length) :: cval CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: clist INTEGER :: handle, itmp, j, jj, k, n_rep, n_var, & - ngauss, ngp, nrep + ngauss, ngp, nrep, znum INTEGER, DIMENSION(:), POINTER :: tmplist LOGICAL :: dftb_scc_mixer_explicit, dftb_tblite_mixer_explicit, explicit, & tblite_reference_cli, tblite_reference_cli_section, tblite_section_active, was_present, & @@ -1579,6 +1580,9 @@ CONTAINS ELSE qs_control%xtb_control%do_ewald = (qs_control%periodicity /= 0) END IF + ! Spin Polarisation + CALL section_vals_val_get(xtb_section, "SPIN_POLARISATION", & + l_val=qs_control%xtb_control%do_spinpol) ! vdW CALL section_vals_val_get(xtb_section, "VDW_POTENTIAL", explicit=explicit) IF (explicit) THEN @@ -1630,6 +1634,9 @@ CONTAINS CPABORT("GFN type") END SELECT END IF + ! + CALL section_vals_val_get(xtb_parameter, "SPINPOL_PARAM_FILE_NAME", & + c_val=qs_control%xtb_control%spinpol_param_file_name) ! D3 Dispersion CALL section_vals_val_get(xtb_parameter, "DISPERSION_RADIUS", & r_val=qs_control%xtb_control%rcdisp) @@ -1853,6 +1860,26 @@ CONTAINS END DO END IF + ! Spin Polarisation + CALL section_vals_val_get(xtb_parameter, "SPIN_POL_PARAM", n_rep_val=n_rep) + IF (n_rep > 0) THEN + ALLOCATE (qs_control%xtb_control%spinpol_type(n_rep)) + ALLOCATE (qs_control%xtb_control%spinpol_vals(6, n_rep)) + DO j = 1, n_rep + CALL section_vals_val_get(xtb_parameter, "SPIN_POL_PARAM", i_rep_val=j, c_vals=clist) + READ (clist(1), '(A)') cval + element_symbol = ADJUSTL(TRIM(cval)) + CALL get_ptable_info(element_symbol, znum) + qs_control%xtb_control%spinpol_type(j) = znum + READ (clist(2), '(F20.8)') qs_control%xtb_control%spinpol_vals(1, j) + READ (clist(3), '(F20.8)') qs_control%xtb_control%spinpol_vals(2, j) + READ (clist(4), '(F20.8)') qs_control%xtb_control%spinpol_vals(3, j) + READ (clist(5), '(F20.8)') qs_control%xtb_control%spinpol_vals(4, j) + READ (clist(6), '(F20.8)') qs_control%xtb_control%spinpol_vals(5, j) + READ (clist(7), '(F20.8)') qs_control%xtb_control%spinpol_vals(6, j) + END DO + END IF + IF (qs_control%xtb_control%gfn_type == 0) THEN CALL section_vals_val_get(xtb_parameter, "SRB_PARAMETER", r_vals=scal) qs_control%xtb_control%ksrb = scal(1) diff --git a/src/input_cp2k_tb.F b/src/input_cp2k_tb.F index ba3342df1b..8c5443b8a5 100644 --- a/src/input_cp2k_tb.F +++ b/src/input_cp2k_tb.F @@ -243,6 +243,12 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="SPIN_POLARISATION", & + description="Use the spin polarisation Hamiltonian for gfn1/2", & + usage="SPIN_POLARISATION T", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="COULOMB_INTERACTION", & description="Use Coulomb interaction terms (electrostatics + TB3); for debug only", & usage="COULOMB_INTERACTION T", default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) @@ -438,6 +444,14 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="SPINPOL_PARAM_FILE_NAME", & + description="Specify file that contains parameters for "// & + "xTB spin polarisation Hamiltonian", & + usage="SPINPOL_PARAM_FILE_NAME filename", & + n_var=1, type_of_var=char_t, default_c_val="xTB_sp_param_060") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="DISPERSION_PARAMETER_FILE", & description="Specify file that contains the atomic dispersion "// & "parameters for the D3 method", & @@ -525,6 +539,13 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="SPIN_POL_PARAM", & + description="Specifies the spin polarisation parameters for kind A.", & + usage="SPIN_POL_PARAM atomtype Wss Wsp Wpp Wsd Wpd Wdd", repeats=.TRUE., & + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="XB_RADIUS", & description="Specifies the radius [Bohr] of the XB pair interaction in xTB.", & usage="XB_RADIUS 20.0 ", repeats=.FALSE., & diff --git a/src/qs_diis.F b/src/qs_diis.F index 5b89b5f419..cbc8b1596b 100644 --- a/src/qs_diis.F +++ b/src/qs_diis.F @@ -571,6 +571,9 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env CALL timeset(routineN, handle) + IF (ls_scf_env%do_pao) THEN + CPABORT("LS_SCF%LS_DIIS not compatible with PAO") + END IF nspin = ls_scf_env%nspins diis_step = .FALSE. my_nmixing = 2 diff --git a/src/qs_energy_types.F b/src/qs_energy_types.F index bb58784a8d..f527355b98 100644 --- a/src/qs_energy_types.F +++ b/src/qs_energy_types.F @@ -80,7 +80,8 @@ MODULE qs_energy_types surf_dipole = 0.0_dp, & embed_corr = 0.0_dp, & ! correction for embedding potential xtb_xb_inter = 0.0_dp, & ! correction for halogen bonding within GFN1-xTB - xtb_nonbonded = 0.0_dp ! correction for nonbonded interactions within GFN1-xTB + xtb_nonbonded = 0.0_dp, & ! correction for nonbonded interactions within GFN1-xTB + xtb_spinpol = 0.0_dp ! spin-polarised Hamiltonian energy within GFN1/2-xTB REAL(KIND=dp), DIMENSION(:), POINTER :: ddapc_restraint => NULL() END TYPE qs_energy_type diff --git a/src/qs_environment.F b/src/qs_environment.F index 08194e09b6..1743d76cea 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -218,7 +218,9 @@ MODULE qs_environment USE transport, ONLY: transport_env_create USE xtb_parameters, ONLY: init_xtb_basis,& xtb_parameters_init,& - xtb_parameters_set + xtb_parameters_set,& + xtb_spinpol_ext,& + xtb_spinpol_init USE xtb_potentials, ONLY: xtb_pp_radius USE xtb_types, ONLY: allocate_xtb_atom_param,& set_xtb_atom_param @@ -1238,6 +1240,12 @@ CONTAINS CALL xtb_parameters_init(qs_kind%xtb_parameter, gfn_type, element_symbol, & xtb_control%parameter_file_path, xtb_control%parameter_file_name, & para_env) + IF (xtb_control%do_spinpol) THEN + CALL xtb_spinpol_init(qs_kind%xtb_parameter, gfn_type, element_symbol, & + xtb_control%parameter_file_path, xtb_control%spinpol_param_file_name, & + para_env) + CALL xtb_spinpol_ext(qs_kind%xtb_parameter, gfn_type, xtb_control) + END IF ! set dependent parameters CALL xtb_parameters_set(qs_kind%xtb_parameter) ! Generate basis set diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index 0df0b262a5..123380fab2 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -1259,7 +1259,6 @@ CONTAINS pdiag(:) = 0.0_dp ALLOCATE (sdiag(nao)) - sdiag(:) = 0.0_dp IF (has_unit_metric) THEN sdiag(:) = 1.0_dp @@ -1341,13 +1340,14 @@ CONTAINS isgfa = first_sgf(atom_a) IF (z == 1 .AND. nsgf == 2) THEN ! Hydrogen 2s basis - pdiag(isgfa) = 1.0_dp + pdiag(isgfa) = 1.0_dp/REAL(nspin, dp) pdiag(isgfa + 1) = 0.0_dp ELSE DO isgf = 1, nsgf na = naox(isgf) la = laox(isgf) occ = REAL(occupation(la + 1), dp)/REAL(2*la + 1, dp) + occ = occ/REAL(nspin, dp) pdiag(isgfa + isgf - 1) = occ END DO END IF @@ -1456,8 +1456,11 @@ CONTAINS END DO DO ispin = 1, nspin IF (nelectron_spin(ispin) /= 0) THEN + rscale = SUM(pdiag)/REAL(nelectron_spin(ispin), dp) matrix_p => pmat(ispin)%matrix + pdiag = pdiag/rscale CALL dbcsr_set_diag(matrix_p, pdiag) + pdiag = pdiag*rscale END IF END DO ELSE diff --git a/src/qs_kinetic.F b/src/qs_kinetic.F index e9926351ad..3ba3a01c62 100644 --- a/src/qs_kinetic.F +++ b/src/qs_kinetic.F @@ -409,8 +409,6 @@ CONTAINS row=irow, col=icol, block=p_block, found=found) CPASSERT(found) ELSE -!deb CALL dbcsr_get_block_p(matrix=matrix_p, row=irow, col=icol, & -!deb block=p_block, found=found) CALL dbcsr_get_block_p(matrix=matp, row=irow, col=icol, & block=p_block, found=found) CPASSERT(found) diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index aa83ab16a1..00c65cf2cd 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -1088,7 +1088,7 @@ CONTAINS "Exchange-correlation energy: ", energy%exc + energy%exc_aux_fit END IF ELSE -!ZMP to print some variables at each step + !ZMP to print some variables at each step IF (dft_control%apply_external_density) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T61,F20.10))") & "DOING ZMP CALCULATION FROM EXTERNAL DENSITY " diff --git a/src/qs_linres_kernel.F b/src/qs_linres_kernel.F index a8d15ea670..82abe2463a 100644 --- a/src/qs_linres_kernel.F +++ b/src/qs_linres_kernel.F @@ -572,7 +572,7 @@ CONTAINS REAL(dp), ALLOCATABLE, DIMENSION(:) :: mcharge, mcharge1 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: aocg, aocg1, charges, charges1 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: rho_ao + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: pmat, rho_ao TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_p, matrix_p1, matrix_s TYPE(dft_control_type), POINTER :: dft_control TYPE(linres_control_type), POINTER :: linres_control @@ -630,6 +630,7 @@ CONTAINS aocg1 = 0.0_dp CALL ao_charges(matrix_p, matrix_s, aocg, para_env) CALL ao_charges(matrix_p1, matrix_s, aocg1, para_env) + IF (nspins == 2) aocg1 = 0.5_dp*aocg1 DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=na) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) @@ -650,7 +651,8 @@ CONTAINS mcharge1(iatom) = SUM(charges1(iatom, :)) END DO ! Coulomb Kernel - CALL xtb_coulomb_hessian(qs_env, p_env%kpp1, charges1, mcharge1, mcharge) + pmat => matrix_p1(:, 1) + CALL xtb_coulomb_hessian(qs_env, p_env%kpp1, charges1, mcharge1, mcharge, pmat) ! DEALLOCATE (charges, mcharge, charges1, mcharge1) END IF diff --git a/src/qs_tddfpt2_fhxc_forces.F b/src/qs_tddfpt2_fhxc_forces.F index 2bc0d14fc9..ca30d1ef23 100644 --- a/src/qs_tddfpt2_fhxc_forces.F +++ b/src/qs_tddfpt2_fhxc_forces.F @@ -1562,7 +1562,7 @@ CONTAINS hfx, rbeta, spinfac, xfac REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tcharge, tv REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: gtcharge - REAL(KIND=dp), DIMENSION(3) :: fij, fodeb, rij + REAL(KIND=dp), DIMENSION(3) :: fij, focoul, fodeb, foexch, rij REAL(KIND=dp), DIMENSION(:, :), POINTER :: gab, pblock TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell @@ -1654,6 +1654,9 @@ CONTAINS cpmos => ex_env%cpmos + focoul = 0.0_dp + foexch = 0.0_dp + DO ispin = 1, nspins ct => work%ctransformed(ispin) CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf) @@ -1781,7 +1784,7 @@ CONTAINS IF (debug_forces) THEN fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3) CALL para_env%sum(fodeb) - IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Coul[X] ", fodeb + focoul(1:3) = focoul(1:3) + fodeb(1:3) END IF norb = nactive(ispin) ! forces from Lowdin charge derivative @@ -1990,7 +1993,7 @@ CONTAINS IF (debug_forces) THEN fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3) CALL para_env%sum(fodeb) - IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Exch[X] ", fodeb + foexch(1:3) = foexch(1:3) + fodeb(1:3) END IF END IF ! @@ -1999,6 +2002,11 @@ CONTAINS DEALLOCATE (tv) END DO + IF (debug_forces) THEN + IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Coul[X] ", focoul + IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Exch[X] ", foexch + END IF + CALL cp_fm_release(xtransformed) DEALLOCATE (tcharge, gtcharge) DEALLOCATE (first_sgf, last_sgf) diff --git a/src/qs_tddfpt2_forces.F b/src/qs_tddfpt2_forces.F index af37574cee..dc5dff3a35 100644 --- a/src/qs_tddfpt2_forces.F +++ b/src/qs_tddfpt2_forces.F @@ -1415,6 +1415,7 @@ CONTAINS s_matrix => matrix_s(1, 1)%matrix CALL ao_charges(p_matrix, s_matrix, aocg, para_env) CALL ao_charges(matrix_pe, s_matrix, aocg1, para_env) + IF (nspins == 2) aocg1 = 0.5_dp*aocg1 DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=na) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) @@ -1435,13 +1436,13 @@ CONTAINS mcharge1(iatom) = SUM(charges1(iatom, :)) END DO ! Coulomb Kernel - CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge) + CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge, & + matrix_pe) ! DEALLOCATE (charges, mcharge, charges1, mcharge1) END IF focc = 2.0_dp - IF (nspins == 2) focc = 1.0_dp DO ispin = 1, nspins mos => gs_mos(ispin)%mos_occ CALL cp_fm_get_info(mos, ncol_global=norb) diff --git a/src/response_solver.F b/src/response_solver.F index 8409bc3eaa..34bbcf3164 100644 --- a/src/response_solver.F +++ b/src/response_solver.F @@ -2771,7 +2771,7 @@ CONTAINS mcharge1(iatom) = SUM(charges1(iatom, :)) END DO ! Coulomb Kernel - CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge) + CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge, mpa) CALL calc_xtb_ehess_force(qs_env, p_matrix, mpa, charges, mcharge, charges1, & mcharge1, debug_forces) ! diff --git a/src/xtb_coulomb.F b/src/xtb_coulomb.F index a95fdcede7..16de64133a 100644 --- a/src/xtb_coulomb.F +++ b/src/xtb_coulomb.F @@ -73,6 +73,7 @@ MODULE xtb_coulomb sap_int_type USE virial_methods, ONLY: virial_pair_force USE virial_types, ONLY: virial_type + USE xtb_spinpol, ONLY: build_xtb_spinpol USE xtb_types, ONLY: get_xtb_atom_param,& xtb_atom_type #include "./base/base_uses.f90" @@ -644,6 +645,12 @@ CONTAINS DEALLOCATE (zeffk, xgamma) END IF + IF (xtb_control%do_spinpol) THEN + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) + CALL build_xtb_spinpol(qs_env, ks_matrix, matrix_p, energy, & + sap_int, calculate_forces, just_energy) + END IF + ! QMMM IF (qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CALL build_tb_coulomb_qmqm(qs_env, ks_matrix, rho, mcharge, energy, & diff --git a/src/xtb_ehess.F b/src/xtb_ehess.F index a7c1f17cdf..8eb7a0a5af 100644 --- a/src/xtb_ehess.F +++ b/src/xtb_ehess.F @@ -51,6 +51,7 @@ MODULE xtb_ehess neighbor_list_set_p_type USE virial_types, ONLY: virial_type USE xtb_coulomb, ONLY: gamma_rab_sr + USE xtb_spinpol, ONLY: xtb_spinpol_hessian USE xtb_types, ONLY: get_xtb_atom_param,& xtb_atom_type #include "./base/base_uses.f90" @@ -72,13 +73,15 @@ CONTAINS !> \param charges1 ... !> \param mcharge1 ... !> \param mcharge ... +!> \param matrix_p1 ... ! ************************************************************************************************** - SUBROUTINE xtb_coulomb_hessian(qs_env, ks_matrix, charges1, mcharge1, mcharge) + SUBROUTINE xtb_coulomb_hessian(qs_env, ks_matrix, charges1, mcharge1, mcharge, matrix_p1) TYPE(qs_environment_type), POINTER :: qs_env TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: ks_matrix REAL(dp), DIMENSION(:, :) :: charges1 REAL(dp), DIMENSION(:) :: mcharge1, mcharge + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_p1 CHARACTER(len=*), PARAMETER :: routineN = 'xtb_coulomb_hessian' @@ -284,6 +287,10 @@ CONTAINS DEALLOCATE (xgamma) END IF + IF (xtb_control%do_spinpol) THEN + CALL xtb_spinpol_hessian(qs_env, ks_matrix, matrix_p1) + END IF + IF (qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CPABORT("QMMM not available in xTB response calculations") END IF diff --git a/src/xtb_ehess_force.F b/src/xtb_ehess_force.F index 84e17a8887..c9926ca9f0 100644 --- a/src/xtb_ehess_force.F +++ b/src/xtb_ehess_force.F @@ -54,6 +54,7 @@ MODULE xtb_ehess_force USE virial_types, ONLY: virial_type USE xtb_coulomb, ONLY: dgamma_rab_sr,& gamma_rab_sr + USE xtb_spinpol, ONLY: xtb_spinpol_hforce USE xtb_types, ONLY: get_xtb_atom_param,& xtb_atom_type #include "./base/base_uses.f90" @@ -436,6 +437,18 @@ CONTAINS alpha_scalar=1.0_dp, beta_scalar=-1.0_dp) END IF + IF (xtb_control%do_spinpol) THEN + IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1) + ! + CALL xtb_spinpol_hforce(qs_env, matrix_p0, matrix_p1) + ! + IF (debug_forces) THEN + fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3) + CALL para_env%sum(fodeb) + IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pz*Hspin[P] ", fodeb + END IF + END IF + ! QMMM IF (qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CPABORT("Not Available") diff --git a/src/xtb_ks_matrix.F b/src/xtb_ks_matrix.F index b9725df4fe..cf71f9b96c 100644 --- a/src/xtb_ks_matrix.F +++ b/src/xtb_ks_matrix.F @@ -431,8 +431,9 @@ CONTAINS energy%qmmm_el = energy%qmmm_el + pc_ener END IF - energy%total = energy%core + energy%hartree + energy%efield + energy%qmmm_el + & - energy%repulsive + energy%dispersion + energy%dftb3 + energy%kTS + energy%total = energy%core + energy%repulsive + & + energy%hartree + energy%xtb_spinpol + energy%efield + & + energy%qmmm_el + energy%dispersion + energy%dftb3 + energy%kTS iounit = cp_print_key_unit_nr(logger, scf_section, "PRINT%DETAILED_ENERGY", & extension=".scfLog") @@ -442,6 +443,10 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge fluctuation energy: ", energy%hartree, & "London dispersion energy: ", energy%dispersion + IF (dft_control%qs_control%xtb_control%do_spinpol) THEN + WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & + "Spin polarisation correction: ", energy%xtb_spinpol + END IF IF (dft_control%qs_control%xtb_control%xb_interaction) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Correction for halogen bonding: ", energy%xtb_xb_inter diff --git a/src/xtb_parameters.F b/src/xtb_parameters.F index 67bb511bd2..5d0f343518 100644 --- a/src/xtb_parameters.F +++ b/src/xtb_parameters.F @@ -165,6 +165,7 @@ MODULE xtb_parameters ! *** Public data types *** PUBLIC :: xtb_parameters_init, xtb_parameters_set, init_xtb_basis, xtb_set_kab + PUBLIC :: xtb_spinpol_init, xtb_spinpol_ext PUBLIC :: metal, early3d, pp_gfn0 CONTAINS @@ -468,6 +469,112 @@ CONTAINS END SUBROUTINE xtb1_parameters_init +! ************************************************************************************************** +!> \brief ... +!> \param param ... +!> \param gfn_type ... +!> \param element_symbol ... +!> \param parameter_file_path ... +!> \param spinpol_param_file_name ... +!> \param para_env ... +! ************************************************************************************************** + SUBROUTINE xtb_spinpol_init(param, gfn_type, element_symbol, parameter_file_path, spinpol_param_file_name, & + para_env) + + TYPE(xtb_atom_type), POINTER :: param + INTEGER, INTENT(IN) :: gfn_type + CHARACTER(LEN=2), INTENT(IN) :: element_symbol + CHARACTER(LEN=*), INTENT(IN) :: parameter_file_path, & + spinpol_param_file_name + TYPE(mp_para_env_type), POINTER :: para_env + + CHARACTER(len=default_string_length) :: filename + INTEGER :: zin, znum + LOGICAL :: at_end + TYPE(cp_parser_type) :: parser + + SELECT CASE (gfn_type) + CASE (0) + CPABORT("gfn_type = 0: No spin polarisation possible!") + CASE (1) + ! OK + CASE (2) + CPABORT("gfn_type = 2 not yet supported") + CASE DEFAULT + CPABORT("Wrong gfn_type") + END SELECT + + filename = ADJUSTL(TRIM(parameter_file_path))//ADJUSTL(TRIM(spinpol_param_file_name)) + CALL parser_create(parser, filename, apply_preprocessing=.FALSE., para_env=para_env) + znum = 0 + param%wall = 0.0_dp + CALL get_ptable_info(element_symbol, znum) + DO + at_end = .FALSE. + CALL parser_get_next_line(parser, 1, at_end) + IF (at_end) EXIT + CALL parser_get_object(parser, zin) + IF (zin == znum) THEN + CALL parser_get_object(parser, param%wall(1, 1)) + CALL parser_get_object(parser, param%wall(1, 2)) + CALL parser_get_object(parser, param%wall(2, 2)) + CALL parser_get_object(parser, param%wall(1, 3)) + CALL parser_get_object(parser, param%wall(2, 3)) + CALL parser_get_object(parser, param%wall(3, 3)) + param%wall(2, 1) = param%wall(1, 2) + param%wall(3, 1) = param%wall(1, 3) + param%wall(3, 2) = param%wall(2, 3) + END IF + END DO + CALL parser_release(parser) + + END SUBROUTINE xtb_spinpol_init + +! ************************************************************************************************** +!> \brief ... +!> \param param ... +!> \param gfn_type ... +!> \param xtb_control ... +! ************************************************************************************************** + SUBROUTINE xtb_spinpol_ext(param, gfn_type, xtb_control) + TYPE(xtb_atom_type), POINTER :: param + INTEGER, INTENT(IN) :: gfn_type + TYPE(xtb_control_type), INTENT(IN), POINTER :: xtb_control + + INTEGER :: i + + SELECT CASE (gfn_type) + CASE (0) + CPABORT("gfn_type = 0: No spin polarisation possible!") + CASE (1) + ! OK + CASE (2) + CPABORT("gfn_type = 2 not yet supported") + CASE DEFAULT + CPABORT("Wrong gfn_type") + END SELECT + + IF (param%defined) THEN + IF (ASSOCIATED(xtb_control%spinpol_type)) THEN + DO i = 1, SIZE(xtb_control%spinpol_type) + IF (xtb_control%spinpol_type(i) == param%z) THEN + param%wall(1, 1) = xtb_control%spinpol_vals(1, i) + param%wall(1, 2) = xtb_control%spinpol_vals(2, i) + param%wall(2, 2) = xtb_control%spinpol_vals(3, i) + param%wall(1, 3) = xtb_control%spinpol_vals(4, i) + param%wall(2, 3) = xtb_control%spinpol_vals(5, i) + param%wall(3, 3) = xtb_control%spinpol_vals(6, i) + param%wall(2, 1) = param%wall(1, 2) + param%wall(3, 1) = param%wall(1, 3) + param%wall(3, 2) = param%wall(2, 3) + EXIT + END IF + END DO + END IF + END IF + + END SUBROUTINE xtb_spinpol_ext + ! ************************************************************************************************** !> \brief Read atom parameters for xTB Hamiltonian from input file !> \param param ... diff --git a/src/xtb_spinpol.F b/src/xtb_spinpol.F new file mode 100644 index 0000000000..3d0afdec70 --- /dev/null +++ b/src/xtb_spinpol.F @@ -0,0 +1,871 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Calculation of Spin Polarisation contributions in xTB +!> \author JGH +! ************************************************************************************************** +MODULE xtb_spinpol + USE atomic_kind_types, ONLY: atomic_kind_type,& + get_atomic_kind,& + get_atomic_kind_set + USE atprop_types, ONLY: atprop_type + USE bibliography, ONLY: Neugebauer2023,& + cite_reference + USE cell_types, ONLY: cell_type + USE cp_control_types, ONLY: dft_control_type + USE cp_dbcsr_api, ONLY: dbcsr_get_block_p,& + dbcsr_iterator_blocks_left,& + dbcsr_iterator_next_block,& + dbcsr_iterator_start,& + dbcsr_iterator_stop,& + dbcsr_iterator_type,& + dbcsr_p_type,& + dbcsr_type + USE kinds, ONLY: dp + USE kpoint_types, ONLY: get_kpoint_info,& + kpoint_type + USE message_passing, ONLY: mp_para_env_type + USE mulliken, ONLY: ao_charges + USE particle_types, ONLY: particle_type + USE qs_energy_types, ONLY: qs_energy_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type + USE qs_force_types, ONLY: qs_force_type + USE qs_kind_types, ONLY: get_qs_kind,& + get_qs_kind_set,& + qs_kind_type + USE qs_neighbor_list_types, ONLY: get_iterator_info,& + neighbor_list_iterate,& + neighbor_list_iterator_create,& + neighbor_list_iterator_p_type,& + neighbor_list_iterator_release,& + neighbor_list_set_p_type + USE sap_kind_types, ONLY: sap_int_type + USE virial_methods, ONLY: virial_pair_force + USE virial_types, ONLY: virial_type + USE xtb_types, ONLY: get_xtb_atom_param,& + xtb_atom_type +#include "./base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xtb_spinpol' + + PUBLIC :: build_xtb_spinpol, xtb_spinpol_hessian, xtb_spinpol_hforce + +CONTAINS + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param ks_matrix ... +!> \param matrix_p ... +!> \param energy ... +!> \param sap_int ... +!> \param calculate_forces ... +!> \param just_energy ... +! ************************************************************************************************** + SUBROUTINE build_xtb_spinpol(qs_env, ks_matrix, matrix_p, energy, & + sap_int, calculate_forces, just_energy) + + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix, matrix_p + TYPE(qs_energy_type), POINTER :: energy + TYPE(sap_int_type), DIMENSION(:), POINTER :: sap_int + LOGICAL, INTENT(in) :: calculate_forces, just_energy + + CHARACTER(len=*), PARAMETER :: routineN = 'build_xtb_spinpol' + + INTEGER :: atom_a, atom_i, atom_j, handle, i, ia, iac, iatom, ib, ic, icol, ikind, iknd, & + irow, jatom, jkind, jknd, la, lb, na, natom, natorb, nb, nimg, nkind, nsgf, nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of + INTEGER, DIMENSION(25) :: lao + INTEGER, DIMENSION(3) :: cellind + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index + LOGICAL :: defined, found, use_virial + REAL(KIND=dp) :: dr, espin, fi, fval + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: docg + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: aocg, bocg, pam, pbm, wab + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: wabk + REAL(KIND=dp), DIMENSION(3) :: fij, rij + REAL(KIND=dp), DIMENSION(3, 3) :: wall + REAL(KIND=dp), DIMENSION(:, :), POINTER :: aksb, bksb, dsblock, pamat, pbmat, sblock + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsint + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(atprop_type), POINTER :: atprop + TYPE(cell_type), POINTER :: cell + TYPE(dbcsr_iterator_type) :: iter + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: p_matrix + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_p_kp, matrix_s, matrix_s_kp + TYPE(dbcsr_type), POINTER :: s_matrix + TYPE(dft_control_type), POINTER :: dft_control + TYPE(kpoint_type), POINTER :: kpoints + TYPE(mp_para_env_type), POINTER :: para_env + TYPE(neighbor_list_iterator_p_type), & + DIMENSION(:), POINTER :: nl_iterator + TYPE(neighbor_list_set_p_type), DIMENSION(:), & + POINTER :: n_list + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_force_type), DIMENSION(:), POINTER :: force + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + TYPE(virial_type), POINTER :: virial + TYPE(xtb_atom_type), POINTER :: xtb_kind + + CALL timeset(routineN, handle) + + energy%xtb_spinpol = 0.0_dp + + CALL get_qs_env(qs_env, dft_control=dft_control) + nspins = dft_control%nspins + nimg = dft_control%nimages + + IF (nspins == 2) THEN + + CALL cite_reference(Neugebauer2023) + + CALL get_qs_env(qs_env, & + qs_kind_set=qs_kind_set, & + particle_set=particle_set, & + atomic_kind_set=atomic_kind_set, & + cell=cell, & + virial=virial, & + atprop=atprop) + + CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & + kind_of=kind_of, & + atom_of_kind=atom_of_kind) + + use_virial = .FALSE. + IF (calculate_forces) THEN + use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) + END IF + + CALL get_qs_env(qs_env, nkind=nkind, natom=natom) + CALL get_qs_kind_set(qs_kind_set, maxsgf=nsgf) + CALL get_qs_env(qs_env, matrix_s_kp=matrix_s, para_env=para_env) + + ! expand parameters + ALLOCATE (wabk(nsgf, nsgf, nkind)) + wabk = 0.0_dp + DO ikind = 1, nkind + CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) + CALL get_xtb_atom_param(xtb_kind, natorb=natorb, lao=lao, wall=wall) + DO ia = 1, natorb + la = lao(ia) + 1 + DO ib = 1, natorb + lb = lao(ib) + 1 + wabk(ia, ib, ikind) = wall(la, lb) + END DO + END DO + END DO + + ! Calculate charges + ALLOCATE (aocg(nsgf, natom), bocg(nsgf, natom)) + aocg = 0.0_dp + bocg = 0.0_dp + IF (nimg > 1) THEN + matrix_s_kp => matrix_s(:, :) + matrix_p_kp => matrix_p(1:1, :) + CALL ao_charges(matrix_p_kp, matrix_s_kp, aocg, para_env) + matrix_p_kp => matrix_p(2:2, :) + CALL ao_charges(matrix_p_kp, matrix_s_kp, bocg, para_env) + ELSE + s_matrix => matrix_s(1, 1)%matrix + p_matrix => matrix_p(1:1, 1) + CALL ao_charges(p_matrix, s_matrix, aocg, para_env) + p_matrix => matrix_p(2:2, 1) + CALL ao_charges(p_matrix, s_matrix, bocg, para_env) + END IF + + ! calculate energy + DO ikind = 1, nkind + CALL get_atomic_kind(atomic_kind_set(ikind), natom=na) + CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) + CALL get_xtb_atom_param(xtb_kind, defined=defined, natorb=natorb) + IF (.NOT. defined .OR. natorb < 1) CYCLE + ALLOCATE (docg(natorb), wab(natorb, natorb)) + wab(1:natorb, 1:natorb) = wabk(1:natorb, 1:natorb, ikind) + DO iatom = 1, na + atom_a = atomic_kind_set(ikind)%atom_list(iatom) + docg = 0.0_dp + docg(1:natorb) = aocg(1:natorb, atom_a) - bocg(1:natorb, atom_a) + espin = 0.5_dp*DOT_PRODUCT(docg, MATMUL(wab, docg)) + energy%xtb_spinpol = energy%xtb_spinpol + espin + IF (atprop%energy) THEN + atprop%atecoul(iatom) = atprop%atecoul(iatom) + espin + END IF + END DO + DEALLOCATE (docg, wab) + END DO + + ! Forces and Virial + IF (calculate_forces) THEN + CALL get_qs_env(qs_env=qs_env, force=force) + NULLIFY (cell_to_index) + IF (nimg > 1) THEN + NULLIFY (kpoints) + CALL get_qs_env(qs_env=qs_env, kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) + END IF + IF (nimg == 1) THEN + ! no k-points; all matrices have been transformed to periodic bsf + CALL dbcsr_iterator_start(iter, matrix_s(1, 1)%matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) + ikind = kind_of(irow) + atom_i = atom_of_kind(irow) + jkind = kind_of(icol) + atom_j = atom_of_kind(icol) + + CALL dbcsr_get_block_p(matrix=matrix_p(1, 1)%matrix, & + row=irow, col=icol, block=pamat, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=matrix_p(2, 1)%matrix, & + row=irow, col=icol, block=pbmat, found=found) + CPASSERT(found) + + na = SIZE(pamat, 1) + nb = SIZE(pamat, 2) + + DO i = 1, 3 + CALL dbcsr_get_block_p(matrix=matrix_s(1 + i, 1)%matrix, & + row=irow, col=icol, block=dsblock, found=found) + CPASSERT(found) + + CALL fupdate(fi, pamat, pbmat, dsblock, na, nb, & + wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & + aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) + + force(ikind)%rho_elec(i, atom_i) = force(ikind)%rho_elec(i, atom_i) + fi + force(jkind)%rho_elec(i, atom_j) = force(jkind)%rho_elec(i, atom_j) - fi + END DO + + END DO + CALL dbcsr_iterator_stop(iter) + ! use dsint list + IF (use_virial .AND. 0 == 0) THEN + CPASSERT(ASSOCIATED(sap_int)) + DO ikind = 1, nkind + DO jkind = 1, nkind + iac = ikind + nkind*(jkind - 1) + IF (.NOT. ASSOCIATED(sap_int(iac)%alist)) CYCLE + DO ia = 1, sap_int(iac)%nalist + IF (.NOT. ASSOCIATED(sap_int(iac)%alist(ia)%clist)) CYCLE + iatom = sap_int(iac)%alist(ia)%aatom + DO ic = 1, sap_int(iac)%alist(ia)%nclist + jatom = sap_int(iac)%alist(ia)%clist(ic)%catom + rij = sap_int(iac)%alist(ia)%clist(ic)%rac + dr = SQRT(SUM(rij(:)**2)) + IF (dr > 1.e-6_dp) THEN + dsint => sap_int(iac)%alist(ia)%clist(ic)%acint + icol = MAX(iatom, jatom) + irow = MIN(iatom, jatom) + CALL dbcsr_get_block_p(matrix=matrix_p(1, 1)%matrix, & + row=irow, col=icol, block=pamat, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=matrix_p(2, 1)%matrix, & + row=irow, col=icol, block=pbmat, found=found) + CPASSERT(found) + IF (irow == iatom) THEN + na = SIZE(pamat, 1) + nb = SIZE(pamat, 2) + ALLOCATE (pam(na, nb), pbm(na, nb)) + pam(1:na, 1:nb) = pamat(1:na, 1:nb) + pbm(1:na, 1:nb) = pbmat(1:na, 1:nb) + ELSE + na = SIZE(pamat, 2) + nb = SIZE(pamat, 1) + ALLOCATE (pam(na, nb), pbm(na, nb)) + pam(1:na, 1:nb) = TRANSPOSE(pamat(1:nb, 1:na)) + pbm(1:na, 1:nb) = TRANSPOSE(pbmat(1:nb, 1:na)) + END IF + + DO i = 1, 3 + CALL fupdate(fi, pam, pbm, dsint(:, :, i), na, nb, & + wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & + aocg(1:na, iatom), aocg(1:nb, jatom), & + bocg(1:na, iatom), bocg(1:nb, jatom)) + fij(i) = fi + END DO + fi = 1.0_dp + IF (iatom == jatom) fi = 0.5_dp + CALL virial_pair_force(virial%pv_virial, fi, fij, rij) + DEALLOCATE (pam, pbm) + + END IF + END DO + END DO + END DO + END DO + END IF + ELSE + NULLIFY (n_list) + CALL get_qs_env(qs_env=qs_env, sab_orb=n_list) + CALL neighbor_list_iterator_create(nl_iterator, n_list) + DO WHILE (neighbor_list_iterate(nl_iterator) == 0) + CALL get_iterator_info(nl_iterator, ikind=ikind, jkind=jkind, & + iatom=iatom, jatom=jatom, r=rij, cell=cellind) + + dr = SQRT(SUM(rij**2)) + IF (iatom == jatom .AND. dr < 1.0e-6_dp) CYCLE + + icol = MAX(iatom, jatom) + irow = MIN(iatom, jatom) + + ic = cell_to_index(cellind(1), cellind(2), cellind(3)) + CPASSERT(ic > 0) + + IF (irow == iatom) THEN + iknd = ikind + jknd = jkind + atom_i = atom_of_kind(iatom) + atom_j = atom_of_kind(jatom) + rij = rij + ELSE + iknd = jkind + jknd = ikind + atom_i = atom_of_kind(jatom) + atom_j = atom_of_kind(iatom) + rij = -rij + END IF + ! + CALL dbcsr_get_block_p(matrix=matrix_p(1, ic)%matrix, & + row=irow, col=icol, block=pamat, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=matrix_p(2, ic)%matrix, & + row=irow, col=icol, block=pbmat, found=found) + CPASSERT(found) + + na = SIZE(pamat, 1) + nb = SIZE(pamat, 2) + + fij = 0.0_dp + DO i = 1, 3 + CALL dbcsr_get_block_p(matrix=matrix_s(1 + i, ic)%matrix, & + row=irow, col=icol, block=dsblock, found=found) + CPASSERT(found) + + CALL fupdate(fi, pamat, pbmat, dsblock, na, nb, & + wabk(1:na, 1:na, iknd), wabk(1:nb, 1:nb, jknd), & + aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) + + force(iknd)%rho_elec(i, atom_i) = force(iknd)%rho_elec(i, atom_i) + fi + force(jknd)%rho_elec(i, atom_j) = force(jknd)%rho_elec(i, atom_j) - fi + fij(i) = fi + END DO + IF (use_virial) THEN + fi = 1.0_dp + IF (iatom == jatom) fi = 0.5_dp + CALL virial_pair_force(virial%pv_virial, fi, fij, rij) + END IF + + END DO + CALL neighbor_list_iterator_release(nl_iterator) + + END IF + END IF + + ! KS matrix + IF (.NOT. just_energy) THEN + IF (nimg > 1) THEN + CALL get_qs_env(qs_env=qs_env, kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) + END IF + IF (nimg == 1) THEN + ! no k-points; all matrices have been transformed to periodic bsf + CALL dbcsr_iterator_start(iter, matrix_s(1, 1)%matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) + CALL dbcsr_get_block_p(matrix=ks_matrix(1, 1)%matrix, & + row=irow, col=icol, block=aksb, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=ks_matrix(2, 1)%matrix, & + row=irow, col=icol, block=bksb, found=found) + CPASSERT(found) + na = SIZE(aksb, 1) + nb = SIZE(aksb, 2) + ikind = kind_of(irow) + jkind = kind_of(icol) + fval = 0.5_dp + CALL ksupdate(aksb, bksb, sblock, na, nb, fval, & + wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & + aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) + END DO + CALL dbcsr_iterator_stop(iter) + ELSE + CALL get_qs_env(qs_env=qs_env, sab_orb=n_list) + CALL neighbor_list_iterator_create(nl_iterator, n_list) + DO WHILE (neighbor_list_iterate(nl_iterator) == 0) + CALL get_iterator_info(nl_iterator, ikind=ikind, jkind=jkind, & + iatom=iatom, jatom=jatom, r=rij, cell=cellind) + + icol = MAX(iatom, jatom) + irow = MIN(iatom, jatom) + + ic = cell_to_index(cellind(1), cellind(2), cellind(3)) + CPASSERT(ic > 0) + + ikind = kind_of(irow) + jkind = kind_of(icol) + + CALL dbcsr_get_block_p(matrix=matrix_s(1, ic)%matrix, & + row=irow, col=icol, block=sblock, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=ks_matrix(1, ic)%matrix, & + row=irow, col=icol, block=aksb, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=ks_matrix(2, ic)%matrix, & + row=irow, col=icol, block=bksb, found=found) + CPASSERT(found) + + na = SIZE(aksb, 1) + nb = SIZE(aksb, 2) + fval = 0.5_dp + CALL ksupdate(aksb, bksb, sblock, na, nb, fval, & + wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & + aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) + END DO + CALL neighbor_list_iterator_release(nl_iterator) + END IF + + END IF + + DEALLOCATE (wabk) + DEALLOCATE (aocg, bocg) + END IF + + CALL timestop(handle) + + END SUBROUTINE build_xtb_spinpol + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param ks_matrix ... +!> \param matrix_p1 ... +! ************************************************************************************************** + SUBROUTINE xtb_spinpol_hessian(qs_env, ks_matrix, matrix_p1) + + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: ks_matrix, matrix_p1 + + CHARACTER(len=*), PARAMETER :: routineN = 'xtb_spinpol_hessian' + + INTEGER :: handle, ia, ib, icol, ikind, irow, & + jkind, la, lb, na, natom, natorb, nb, & + nimg, nkind, nsgf, nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of + INTEGER, DIMENSION(25) :: lao + LOGICAL :: found + REAL(KIND=dp) :: fval + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: aocg1, bocg1 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: wabk + REAL(KIND=dp), DIMENSION(3, 3) :: wall + REAL(KIND=dp), DIMENSION(:, :), POINTER :: aksb, bksb, sblock + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(dbcsr_iterator_type) :: iter + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: p_matrix + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_s + TYPE(dbcsr_type), POINTER :: s_matrix + TYPE(dft_control_type), POINTER :: dft_control + TYPE(mp_para_env_type), POINTER :: para_env + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + TYPE(xtb_atom_type), POINTER :: xtb_kind + + CALL timeset(routineN, handle) + + CALL get_qs_env(qs_env, dft_control=dft_control) + nspins = dft_control%nspins + nimg = dft_control%nimages + + IF (nimg /= 1) THEN + CPABORT("No kpoints allowed in xTB response calculation") + END IF + + IF (nspins == 2) THEN + + CALL get_qs_env(qs_env, & + qs_kind_set=qs_kind_set, & + atomic_kind_set=atomic_kind_set) + + CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of) + + CALL get_qs_env(qs_env, nkind=nkind, natom=natom) + CALL get_qs_kind_set(qs_kind_set, maxsgf=nsgf) + CALL get_qs_env(qs_env, matrix_s_kp=matrix_s, para_env=para_env) + + ! expand parameters + ALLOCATE (wabk(nsgf, nsgf, nkind)) + wabk = 0.0_dp + DO ikind = 1, nkind + CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) + CALL get_xtb_atom_param(xtb_kind, natorb=natorb, lao=lao, wall=wall) + DO ia = 1, natorb + la = lao(ia) + 1 + DO ib = 1, natorb + lb = lao(ib) + 1 + wabk(ia, ib, ikind) = wall(la, lb) + END DO + END DO + END DO + + ! Calculate response charges + ALLOCATE (aocg1(nsgf, natom), bocg1(nsgf, natom)) + aocg1 = 0.0_dp + bocg1 = 0.0_dp + s_matrix => matrix_s(1, 1)%matrix + p_matrix => matrix_p1(1:1) + CALL ao_charges(p_matrix, s_matrix, aocg1, para_env) + p_matrix => matrix_p1(2:2) + CALL ao_charges(p_matrix, s_matrix, bocg1, para_env) + aocg1 = 0.5_dp*aocg1 + bocg1 = 0.5_dp*bocg1 + + CALL dbcsr_iterator_start(iter, s_matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) + CALL dbcsr_get_block_p(matrix=ks_matrix(1)%matrix, & + row=irow, col=icol, block=aksb, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=ks_matrix(2)%matrix, & + row=irow, col=icol, block=bksb, found=found) + CPASSERT(found) + na = SIZE(aksb, 1) + nb = SIZE(aksb, 2) + ikind = kind_of(irow) + jkind = kind_of(icol) + fval = 1.00_dp + CALL ksupdate(aksb, bksb, sblock, na, nb, fval, & + wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & + aocg1(1:na, irow), aocg1(1:nb, icol), & + bocg1(1:na, irow), bocg1(1:nb, icol)) + END DO + CALL dbcsr_iterator_stop(iter) + + DEALLOCATE (wabk) + DEALLOCATE (aocg1, bocg1) + END IF + + CALL timestop(handle) + + END SUBROUTINE xtb_spinpol_hessian + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param matrix_p0 ... +!> \param matrix_p1 ... +! ************************************************************************************************** + SUBROUTINE xtb_spinpol_hforce(qs_env, matrix_p0, matrix_p1) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_p0, matrix_p1 + + CHARACTER(len=*), PARAMETER :: routineN = 'xtb_spinpol_hforce' + + INTEGER :: atom_i, atom_j, handle, i, ia, ib, icol, & + ikind, irow, jkind, la, lb, na, natom, & + natorb, nb, nimg, nkind, nsgf, nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of + INTEGER, DIMENSION(25) :: lao + LOGICAL :: found + REAL(KIND=dp) :: fi + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: aocg, aocg1, bocg, bocg1 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: wabk + REAL(KIND=dp), DIMENSION(3, 3) :: wall + REAL(KIND=dp), DIMENSION(:, :), POINTER :: dsblock, p0amat, p0bmat, p1amat, p1bmat, & + sblock + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(dbcsr_iterator_type) :: iter + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, p_matrix + TYPE(dbcsr_type), POINTER :: s_matrix + TYPE(dft_control_type), POINTER :: dft_control + TYPE(mp_para_env_type), POINTER :: para_env + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_force_type), DIMENSION(:), POINTER :: force + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + TYPE(xtb_atom_type), POINTER :: xtb_kind + + CALL timeset(routineN, handle) + + CALL get_qs_env(qs_env, dft_control=dft_control) + nspins = dft_control%nspins + nimg = dft_control%nimages + IF (nimg /= 1) THEN + CPABORT("xTB response forces for spin polarisation Hamiltonian not available") + END IF + + IF (nspins == 2) THEN + + CALL get_qs_env(qs_env, & + qs_kind_set=qs_kind_set, & + particle_set=particle_set, & + atomic_kind_set=atomic_kind_set) + + CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & + kind_of=kind_of, & + atom_of_kind=atom_of_kind) + + CALL get_qs_env(qs_env, nkind=nkind, natom=natom) + CALL get_qs_kind_set(qs_kind_set, maxsgf=nsgf) + + CALL get_qs_env(qs_env, matrix_s=matrix_s, para_env=para_env) + + ! expand parameters + ALLOCATE (wabk(nsgf, nsgf, nkind)) + wabk = 0.0_dp + DO ikind = 1, nkind + CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) + CALL get_xtb_atom_param(xtb_kind, natorb=natorb, lao=lao, wall=wall) + DO ia = 1, natorb + la = lao(ia) + 1 + DO ib = 1, natorb + lb = lao(ib) + 1 + wabk(ia, ib, ikind) = wall(la, lb) + END DO + END DO + END DO + + ! Calculate charges + s_matrix => matrix_s(1)%matrix + ALLOCATE (aocg(nsgf, natom), bocg(nsgf, natom)) + aocg = 0.0_dp + bocg = 0.0_dp + p_matrix => matrix_p0(1:1) + CALL ao_charges(p_matrix, s_matrix, aocg, para_env) + p_matrix => matrix_p0(2:2) + CALL ao_charges(p_matrix, s_matrix, bocg, para_env) + ! Calculate response charges + ALLOCATE (aocg1(nsgf, natom), bocg1(nsgf, natom)) + aocg1 = 0.0_dp + bocg1 = 0.0_dp + p_matrix => matrix_p1(1:1) + CALL ao_charges(p_matrix, s_matrix, aocg1, para_env) + p_matrix => matrix_p1(2:2) + CALL ao_charges(p_matrix, s_matrix, bocg1, para_env) + aocg1 = 0.5_dp*aocg1 + bocg1 = 0.5_dp*bocg1 + + ! calculate forces + CALL get_qs_env(qs_env=qs_env, force=force) + ! no k-points; all matrices have been transformed to periodic bsf + CALL dbcsr_iterator_start(iter, s_matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) + ikind = kind_of(irow) + atom_i = atom_of_kind(irow) + jkind = kind_of(icol) + atom_j = atom_of_kind(icol) + + CALL dbcsr_get_block_p(matrix=matrix_p0(1)%matrix, & + row=irow, col=icol, block=p0amat, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=matrix_p0(2)%matrix, & + row=irow, col=icol, block=p0bmat, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=matrix_p1(1)%matrix, & + row=irow, col=icol, block=p1amat, found=found) + CPASSERT(found) + CALL dbcsr_get_block_p(matrix=matrix_p1(2)%matrix, & + row=irow, col=icol, block=p1bmat, found=found) + CPASSERT(found) + + na = SIZE(p0amat, 1) + nb = SIZE(p0amat, 2) + + DO i = 1, 3 + CALL dbcsr_get_block_p(matrix=matrix_s(1 + i)%matrix, & + row=irow, col=icol, block=dsblock, found=found) + CPASSERT(found) + + fi = 0.0_dp + CALL f2update(fi, p0amat, p0bmat, p1amat, p1bmat, dsblock, na, nb, & + wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & + aocg(1:na, irow), aocg(1:nb, icol), & + bocg(1:na, irow), bocg(1:nb, icol), & + aocg1(1:na, irow), aocg1(1:nb, icol), & + bocg1(1:na, irow), bocg1(1:nb, icol)) + + force(ikind)%rho_elec(i, atom_i) = force(ikind)%rho_elec(i, atom_i) + fi + force(jkind)%rho_elec(i, atom_j) = force(jkind)%rho_elec(i, atom_j) - fi + END DO + + END DO + CALL dbcsr_iterator_stop(iter) + + END IF + + CALL timestop(handle) + + END SUBROUTINE xtb_spinpol_hforce + +! ************************************************************************************************** +!> \brief ... +!> \param aksb ... +!> \param bksb ... +!> \param sb ... +!> \param na ... +!> \param nb ... +!> \param fval ... +!> \param wabi ... +!> \param wabj ... +!> \param qai ... +!> \param qaj ... +!> \param qbi ... +!> \param qbj ... +! ************************************************************************************************** + SUBROUTINE ksupdate(aksb, bksb, sb, na, nb, fval, & + wabi, wabj, qai, qaj, qbi, qbj) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: aksb, bksb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sb + INTEGER, INTENT(IN) :: na, nb + REAL(KIND=dp), INTENT(IN) :: fval + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: wabi, wabj + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: qai, qaj, qbi, qbj + + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(na) :: dqa, wa + REAL(KIND=dp), DIMENSION(na, nb) :: wqab + REAL(KIND=dp), DIMENSION(nb) :: dqb, wb + + dqa = qai - qbi + dqb = qaj - qbj + wa = MATMUL(wabi, dqa) + wb = MATMUL(wabj, dqb) + DO ib = 1, nb + DO ia = 1, na + wqab(ia, ib) = fval*sb(ia, ib)*(wa(ia) + wb(ib)) + END DO + END DO + + aksb = aksb + wqab + bksb = bksb - wqab + + END SUBROUTINE ksupdate + +! ************************************************************************************************** +!> \brief ... +!> \param fij ... +!> \param pa ... +!> \param pb ... +!> \param ds ... +!> \param na ... +!> \param nb ... +!> \param wabi ... +!> \param wabj ... +!> \param qai ... +!> \param qaj ... +!> \param qbi ... +!> \param qbj ... +! ************************************************************************************************** + SUBROUTINE fupdate(fij, pa, pb, ds, na, nb, & + wabi, wabj, qai, qaj, qbi, qbj) + + REAL(KIND=dp), INTENT(OUT) :: fij + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: pa, pb, ds + INTEGER, INTENT(IN) :: na, nb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: wabi, wabj + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: qai, qaj, qbi, qbj + + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(na) :: dpsa, dqa, wa + REAL(KIND=dp), DIMENSION(na, nb) :: dpab + REAL(KIND=dp), DIMENSION(nb) :: dpsb, dqb, wb + + dqa = qai - qbi + dqb = qaj - qbj + wa = MATMUL(wabi, dqa) + wb = MATMUL(wabj, dqb) + dpab = pa - pb + dpsa = 0.0_dp + dpsb = 0.0_dp + DO ib = 1, nb + DO ia = 1, na + dpsa(ia) = dpsa(ia) + dpab(ia, ib)*ds(ia, ib) + dpsb(ib) = dpsb(ib) + dpab(ia, ib)*ds(ia, ib) + END DO + END DO + + fij = SUM(wa*dpsa) + SUM(wb*dpsb) + + END SUBROUTINE fupdate + +! ************************************************************************************************** +!> \brief ... +!> \param fij ... +!> \param p0a ... +!> \param p0b ... +!> \param p1a ... +!> \param p1b ... +!> \param ds ... +!> \param na ... +!> \param nb ... +!> \param wabi ... +!> \param wabj ... +!> \param qai ... +!> \param qaj ... +!> \param qbi ... +!> \param qbj ... +!> \param rai ... +!> \param raj ... +!> \param rbi ... +!> \param rbj ... +! ************************************************************************************************** + SUBROUTINE f2update(fij, p0a, p0b, p1a, p1b, ds, na, nb, wabi, wabj, & + qai, qaj, qbi, qbj, rai, raj, rbi, rbj) + + REAL(KIND=dp), INTENT(OUT) :: fij + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: p0a, p0b, p1a, p1b, ds + INTEGER, INTENT(IN) :: na, nb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: wabi, wabj + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: qai, qaj, qbi, qbj, rai, raj, rbi, rbj + + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(na) :: dpsa, dqa, wa + REAL(KIND=dp), DIMENSION(na, nb) :: dpab + REAL(KIND=dp), DIMENSION(nb) :: dpsb, dqb, wb + + fij = 0.0_dp + + dqa = qai - qbi + dqb = qaj - qbj + wa = MATMUL(wabi, dqa) + wb = MATMUL(wabj, dqb) + dpab = p1a - p1b + dpsa = 0.0_dp + dpsb = 0.0_dp + DO ib = 1, nb + DO ia = 1, na + dpsa(ia) = dpsa(ia) + dpab(ia, ib)*ds(ia, ib) + dpsb(ib) = dpsb(ib) + dpab(ia, ib)*ds(ia, ib) + END DO + END DO + + fij = fij + SUM(wa*dpsa) + SUM(wb*dpsb) + + dqa = rai - rbi + dqb = raj - rbj + wa = MATMUL(wabi, dqa) + wb = MATMUL(wabj, dqb) + dpab = p0a - p0b + dpsa = 0.0_dp + dpsb = 0.0_dp + DO ib = 1, nb + DO ia = 1, na + dpsa(ia) = dpsa(ia) + dpab(ia, ib)*ds(ia, ib) + dpsb(ib) = dpsb(ib) + dpab(ia, ib)*ds(ia, ib) + END DO + END DO + + fij = fij + SUM(wa*dpsa) + SUM(wb*dpsb) + + END SUBROUTINE f2update + +END MODULE xtb_spinpol diff --git a/src/xtb_types.F b/src/xtb_types.F index 9ec859eae6..5075595868 100644 --- a/src/xtb_types.F +++ b/src/xtb_types.F @@ -69,6 +69,7 @@ MODULE xtb_types REAL(KIND=dp), DIMENSION(5) :: kappa = -1.0_dp REAL(KIND=dp), DIMENSION(5) :: hen = -1.0_dp REAL(KIND=dp), DIMENSION(5) :: zeta = -1.0_dp + REAL(KIND=dp), DIMENSION(3, 3) :: wall = -1.0_dp ! spin polarisation ! gfn0 params REAL(KIND=dp) :: en = -1.0_dp REAL(KIND=dp) :: kqat2 = -1.0_dp @@ -127,6 +128,7 @@ CONTAINS xtb_parameter%occupation = 0 xtb_parameter%kpoly = 0.0_dp xtb_parameter%kappa = 0.0_dp + xtb_parameter%wall = 0.0_dp xtb_parameter%hen = 0.0_dp xtb_parameter%zeta = 0.0_dp xtb_parameter%en = 0.0_dp @@ -180,6 +182,7 @@ CONTAINS !> \param lval ... !> \param kpoly ... !> \param kappa ... +!> \param wall ... !> \param hen ... !> \param zeta ... !> \param xi ... @@ -195,7 +198,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE get_xtb_atom_param(xtb_parameter, symbol, aname, typ, defined, z, zeff, natorb, lmax, nao, lao, & rcut, rcov, kx, eta, xgamma, alpha, zneff, nshell, nval, lval, kpoly, kappa, & - hen, zeta, xi, kappa0, alpg, occupation, electronegativity, chmax, & + wall, hen, zeta, xi, kappa0, alpg, occupation, electronegativity, chmax, & en, kqat2, kcn, kq) TYPE(xtb_atom_type), POINTER :: xtb_parameter @@ -210,7 +213,10 @@ CONTAINS REAL(KIND=dp), INTENT(OUT), OPTIONAL :: rcut, rcov, kx, eta, xgamma, alpha, zneff INTEGER, INTENT(OUT), OPTIONAL :: nshell INTEGER, DIMENSION(5), INTENT(OUT), OPTIONAL :: nval, lval - REAL(KIND=dp), DIMENSION(5), INTENT(OUT), OPTIONAL :: kpoly, kappa, hen, zeta + REAL(KIND=dp), DIMENSION(5), INTENT(OUT), OPTIONAL :: kpoly, kappa + REAL(KIND=dp), DIMENSION(3, 3), INTENT(OUT), & + OPTIONAL :: wall + REAL(KIND=dp), DIMENSION(5), INTENT(OUT), OPTIONAL :: hen, zeta REAL(KIND=dp), INTENT(OUT), OPTIONAL :: xi, kappa0, alpg INTEGER, DIMENSION(5), INTENT(OUT), OPTIONAL :: occupation REAL(KIND=dp), INTENT(OUT), OPTIONAL :: electronegativity, chmax, en, kqat2 @@ -243,6 +249,7 @@ CONTAINS IF (PRESENT(occupation)) occupation = xtb_parameter%occupation IF (PRESENT(kpoly)) kpoly = xtb_parameter%kpoly IF (PRESENT(kappa)) kappa = xtb_parameter%kappa + IF (PRESENT(wall)) wall(1:3, 1:3) = xtb_parameter%wall(1:3, 1:3) IF (PRESENT(hen)) hen = xtb_parameter%hen IF (PRESENT(zeta)) zeta = xtb_parameter%zeta IF (PRESENT(chmax)) chmax = xtb_parameter%chmax @@ -280,6 +287,7 @@ CONTAINS !> \param lval ... !> \param kpoly ... !> \param kappa ... +!> \param wall ... !> \param hen ... !> \param zeta ... !> \param xi ... @@ -295,7 +303,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE set_xtb_atom_param(xtb_parameter, aname, typ, defined, z, zeff, natorb, lmax, nao, lao, & rcut, rcov, kx, eta, xgamma, alpha, zneff, nshell, nval, lval, kpoly, kappa, & - hen, zeta, xi, kappa0, alpg, electronegativity, occupation, chmax, & + wall, hen, zeta, xi, kappa0, alpg, electronegativity, occupation, chmax, & en, kqat2, kcn, kq) TYPE(xtb_atom_type), POINTER :: xtb_parameter @@ -309,7 +317,10 @@ CONTAINS REAL(KIND=dp), INTENT(IN), OPTIONAL :: rcut, rcov, kx, eta, xgamma, alpha, zneff INTEGER, INTENT(IN), OPTIONAL :: nshell INTEGER, DIMENSION(5), INTENT(IN), OPTIONAL :: nval, lval - REAL(KIND=dp), DIMENSION(5), INTENT(IN), OPTIONAL :: kpoly, kappa, hen, zeta + REAL(KIND=dp), DIMENSION(5), INTENT(IN), OPTIONAL :: kpoly, kappa + REAL(KIND=dp), DIMENSION(3, 3), INTENT(IN), & + OPTIONAL :: wall + REAL(KIND=dp), DIMENSION(5), INTENT(IN), OPTIONAL :: hen, zeta REAL(KIND=dp), INTENT(IN), OPTIONAL :: xi, kappa0, alpg, electronegativity INTEGER, DIMENSION(5), INTENT(IN), OPTIONAL :: occupation REAL(KIND=dp), INTENT(IN), OPTIONAL :: chmax, en, kqat2 @@ -341,6 +352,7 @@ CONTAINS IF (PRESENT(occupation)) xtb_parameter%occupation = occupation IF (PRESENT(kpoly)) xtb_parameter%kpoly = kpoly IF (PRESENT(kappa)) xtb_parameter%kappa = kappa + IF (PRESENT(wall)) xtb_parameter%wall(1:3, 1:3) = wall(1:3, 1:3) IF (PRESENT(hen)) xtb_parameter%hen = hen IF (PRESENT(zeta)) xtb_parameter%zeta = zeta IF (PRESENT(chmax)) xtb_parameter%chmax = chmax @@ -370,9 +382,10 @@ CONTAINS CHARACTER(LEN=default_string_length) :: aname, bb INTEGER :: i, io_unit, m, natorb, nshell INTEGER, DIMENSION(5) :: lval, nval, occupation - LOGICAL :: defined + LOGICAL :: defined, have_sp REAL(dp) :: zeff REAL(KIND=dp) :: alpha, en, eta, xgamma, zneff + REAL(KIND=dp), DIMENSION(3, 3) :: wall REAL(KIND=dp), DIMENSION(5) :: hen, kappa, kpoly, zeta TYPE(cp_logger_type), POINTER :: logger @@ -394,6 +407,10 @@ CONTAINS CALL get_xtb_atom_param(xtb_parameter, nshell=nshell, lval=lval, nval=nval, occupation=occupation) CALL get_xtb_atom_param(xtb_parameter, kpoly=kpoly, kappa=kappa, hen=hen, zeta=zeta) CALL get_xtb_atom_param(xtb_parameter, electronegativity=en, xgamma=xgamma, eta=eta, alpha=alpha, zneff=zneff) + wall = 0.0_dp + CALL get_xtb_atom_param(xtb_parameter, wall=wall) + have_sp = .FALSE. + IF (SUM(ABS(wall)) /= 0.0_dp) have_sp = .TRUE. bb = " " WRITE (UNIT=io_unit, FMT="(/,A,T67,A14)") " xTB parameters: ", TRIM(aname) @@ -413,6 +430,10 @@ CONTAINS (kappa(i), i=1, nshell) WRITE (UNIT=io_unit, FMT="(T16,A,T71,F10.3)") "3rd Order constant", xgamma WRITE (UNIT=io_unit, FMT="(T16,A,T61,2F10.3)") "Repulsion potential [Z,alpha]", zneff, alpha + IF (have_sp) THEN + WRITE (UNIT=io_unit, FMT="(T16,A,T51,3F10.4)") "Spin Polarisation Wss sp pp", wall(1, 1), wall(1, 2), wall(2, 2) + WRITE (UNIT=io_unit, FMT="(T16,A,T51,3F10.4)") " Wsd pd dd", wall(1, 3), wall(2, 3), wall(3, 3) + END IF ELSE WRITE (UNIT=io_unit, FMT="(T55,A)") "Parameters are not defined" END IF diff --git a/tests/QS/regtest-debug-2/TEST_FILES.toml b/tests/QS/regtest-debug-2/TEST_FILES.toml index 132ecbab4e..043d6f8142 100644 --- a/tests/QS/regtest-debug-2/TEST_FILES.toml +++ b/tests/QS/regtest-debug-2/TEST_FILES.toml @@ -3,10 +3,13 @@ # e.g. 0 means do not compare anything, running is enough # 1 compares the last total energy in the file # for details see cp2k/tools/do_regtest -"h2o_lri.inp" = [{matcher="M087", tol=1e-05, ref=0.222165614960E+02}] -"h2o_pade_fd.inp" = [{matcher="M087", tol=1e-05, ref=0.168333363169E+02}] -"h2o_hfx.inp" = [{matcher="M087", tol=1e-05, ref=0.106990197203E+02}] -"h2o_hfx_admm.inp" = [{matcher="M087", tol=1e-05, ref=0.153251090463E+02}] -"h2o_admm_gapw.inp" = [{matcher="M087", tol=1e-05, ref=0.108571964857E+02}] -"h2o_admm_x.inp" = [{matcher="M087", tol=1e-05, ref=0.108790445340E+02}] +"h2o_lri.inp" = [] +"h2o_pade_fd.inp" = [] +"h2o_hfx.inp" = [] +"h2o_hfx_admm.inp" = [] +"h2o_admm_gapw.inp" = [] +"h2o_admm_x.inp" = [] +"h2o_pbe_fd.inp" = [] +# +#"h2o_tpss_fd.inp" = [] #EOF diff --git a/tests/QS/regtest-debug-2/h2o_admm_gapw.inp b/tests/QS/regtest-debug-2/h2o_admm_gapw.inp index 70acbfd20e..4b739123e2 100644 --- a/tests/QS/regtest-debug-2/h2o_admm_gapw.inp +++ b/tests/QS/regtest-debug-2/h2o_admm_gapw.inp @@ -59,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-2/h2o_admm_x.inp b/tests/QS/regtest-debug-2/h2o_admm_x.inp index 84f4e0912d..264392849d 100644 --- a/tests/QS/regtest-debug-2/h2o_admm_x.inp +++ b/tests/QS/regtest-debug-2/h2o_admm_x.inp @@ -59,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-2/h2o_hfx.inp b/tests/QS/regtest-debug-2/h2o_hfx.inp index 7859756baa..a3a681f63d 100644 --- a/tests/QS/regtest-debug-2/h2o_hfx.inp +++ b/tests/QS/regtest-debug-2/h2o_hfx.inp @@ -56,7 +56,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-2/h2o_hfx_admm.inp b/tests/QS/regtest-debug-2/h2o_hfx_admm.inp index b31484886f..1c9397200c 100644 --- a/tests/QS/regtest-debug-2/h2o_hfx_admm.inp +++ b/tests/QS/regtest-debug-2/h2o_hfx_admm.inp @@ -26,6 +26,9 @@ &END AUXILIARY_DENSITY_MATRIX_METHOD &EFIELD &END EFIELD + &MGRID + CUTOFF 100 + &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -38,9 +41,9 @@ &END QS &SCF EPS_SCF 1.0E-6 - MAX_SCF 100 + MAX_SCF 10 SCF_GUESS ATOMIC - &OT OFF + &OT ON MINIMIZER DIIS PRECONDITIONER FULL_SINGLE_INVERSE &END OT diff --git a/tests/QS/regtest-debug-2/h2o_lri.inp b/tests/QS/regtest-debug-2/h2o_lri.inp index e0ec64d6da..d4605011e3 100644 --- a/tests/QS/regtest-debug-2/h2o_lri.inp +++ b/tests/QS/regtest-debug-2/h2o_lri.inp @@ -21,8 +21,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 240 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -35,7 +34,7 @@ METHOD LRIGPW &END QS &SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-7 MAX_SCF 10 SCF_GUESS ATOMIC &OT @@ -43,7 +42,7 @@ PRECONDITIONER FULL_SINGLE_INVERSE &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -64,7 +63,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.5 4.5 4.5 + ABC [angstrom] 5.0 5.0 5.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-2/h2o_pade_fd.inp b/tests/QS/regtest-debug-2/h2o_pade_fd.inp index 13819d3810..39605d26ea 100644 --- a/tests/QS/regtest-debug-2/h2o_pade_fd.inp +++ b/tests/QS/regtest-debug-2/h2o_pade_fd.inp @@ -19,6 +19,9 @@ LSD &EFIELD &END EFIELD + &MGRID + CUTOFF 100 + &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -50,7 +53,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-09 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -60,7 +63,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.5 4.5 4.5 + ABC [angstrom] 4. 4. 4. PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-2/h2o_pbe_fd.inp b/tests/QS/regtest-debug-2/h2o_pbe_fd.inp index 1849583aa4..05165ceed1 100644 --- a/tests/QS/regtest-debug-2/h2o_pbe_fd.inp +++ b/tests/QS/regtest-debug-2/h2o_pbe_fd.inp @@ -18,6 +18,9 @@ &DFT &EFIELD &END EFIELD + &MGRID + CUTOFF 100 + &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -49,7 +52,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-09 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -59,7 +62,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 6.0 6.0 6.0 + ABC [angstrom] 5.0 5.0 5.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-2/h2o_tpss_fd.inp b/tests/QS/regtest-debug-2/h2o_tpss_fd.inp index fcea6cff85..91631001ea 100644 --- a/tests/QS/regtest-debug-2/h2o_tpss_fd.inp +++ b/tests/QS/regtest-debug-2/h2o_tpss_fd.inp @@ -19,6 +19,9 @@ LSD &EFIELD &END EFIELD + &MGRID + CUTOFF 100 + &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -54,8 +57,9 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-09 - PRECONDITIONER FULL_ALL + ENERGY_GAP 0.05 + EPS 1.e-07 + PRECONDITIONER FULL_SINGLE_INVERSE &POLAR DO_RAMAN T PERIODIC_DIPOLE_OPERATOR F @@ -64,7 +68,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 6.0 6.0 6.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/TEST_FILES.toml b/tests/QS/regtest-debug-7/TEST_FILES.toml index 4b7be864c6..360eb5a2ba 100644 --- a/tests/QS/regtest-debug-7/TEST_FILES.toml +++ b/tests/QS/regtest-debug-7/TEST_FILES.toml @@ -3,17 +3,17 @@ # e.g. 0 means do not compare anything, running is enough # 1 compares the last total energy in the file # for details see cp2k/tools/do_regtest -"ch2o_gapw_t1.inp" = [{matcher="M087", tol=1e-05, ref=0.483221735787E+02}] -"ch2o_gapw_t2.inp" = [{matcher="M087", tol=1e-05, ref=0.523034637680E+02}] -"ch2o_gapw_t3.inp" = [{matcher="M087", tol=1e-05, ref=0.514019909196E+02}] -"ch2o_gapw_t4.inp" = [{matcher="M087", tol=1e-05, ref=0.509623579715E+02}] -"h2o_gapw_t5.inp" = [{matcher="M087", tol=1e-05, ref=0.107325591393E+02}] -"h2o_gapw_t6.inp" = [{matcher="M087", tol=1e-05, ref=0.154795414458E+02}] -"h2o_gapw_t7.inp" = [{matcher="M087", tol=1e-05, ref=0.999033988860E+01}] -"ch2o_gapw_xc_t1.inp" = [{matcher="M087", tol=1e-05, ref=0.531344520427E+02}] -"ch2o_gapw_xc_t2.inp" = [{matcher="M087", tol=1e-05, ref=0.522983512347E+02}] -"ch2o_gapw_xc_t3.inp" = [{matcher="M087", tol=1e-05, ref=0.513981803741E+02}] -"ch2o_gapw_xc_t4.inp" = [{matcher="M087", tol=1e-05, ref=0.509588648640E+02}] -"h2o_gapw_xc_t5.inp" = [{matcher="M087", tol=1e-05, ref=0.108004306906E+02}] -"h2o_gapw_xc_t6.inp" = [{matcher="M087", tol=1e-05, ref=0.993781535670E+01}] +"ch2o_gapw_t1.inp" = [] +"ch2o_gapw_t2.inp" = [] +"ch2o_gapw_t3.inp" = [] +"ch2o_gapw_t4.inp" = [] +"h2o_gapw_t5.inp" = [] +"h2o_gapw_t6.inp" = [] +"h2o_gapw_t7.inp" = [] +"ch2o_gapw_xc_t1.inp" = [] +"ch2o_gapw_xc_t2.inp" = [] +"ch2o_gapw_xc_t3.inp" = [] +"ch2o_gapw_xc_t4.inp" = [] +"h2o_gapw_xc_t5.inp" = [] +"h2o_gapw_xc_t6.inp" = [] #EOF diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp index 80d678ae59..747c356b9e 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp @@ -19,8 +19,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 300 - REL_CUTOFF 50 + CUTOFF 100 &END MGRID &POISSON PERIODIC NONE @@ -56,7 +55,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -66,7 +65,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 6.0 6.0 6.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp index 6bedbc8d08..14b4becb29 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp @@ -19,8 +19,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -29,11 +28,11 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-7 MAX_SCF 20 SCF_GUESS ATOMIC &OT @@ -41,7 +40,7 @@ PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -52,7 +51,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp index aabe828566..68a2219c17 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp @@ -5,7 +5,7 @@ &END GLOBAL &DEBUG - DE 0.005 + DE 0.001 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .FALSE. DEBUG_POLARIZABILITY .TRUE. @@ -19,8 +19,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -29,19 +28,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-6 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -52,7 +51,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp index f48b57cebd..60b8f62253 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp @@ -27,8 +27,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -37,19 +36,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-6 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -60,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp index 9462398ec9..e86fcf1113 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp @@ -19,8 +19,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -29,19 +28,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-7 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -52,7 +51,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp index 5c27e56781..a70faff79e 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp @@ -19,8 +19,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -52,7 +51,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -62,7 +61,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 6.0 6.0 6.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp index b021b9c75d..c88e40c1f5 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp @@ -19,8 +19,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -29,19 +28,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-7 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -52,7 +51,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp index f8f7f65cd4..c00d805a5c 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp @@ -27,8 +27,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 100 &END MGRID &PRINT &MOMENTS ON @@ -37,19 +36,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-6 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -60,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp b/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp index 4f4338c4b1..84af39ac67 100644 --- a/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp +++ b/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp @@ -21,8 +21,7 @@ METHOD GPW &END QS &MGRID - CUTOFF 400 - REL_CUTOFF 60 + CUTOFF 100 &END MGRID &EFIELD &END EFIELD @@ -49,7 +48,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/h2o_gapw_t5.inp b/tests/QS/regtest-debug-7/h2o_gapw_t5.inp index 2b2a70b83c..1793187c29 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_t5.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_t5.inp @@ -28,7 +28,6 @@ &END EFIELD &MGRID CUTOFF 100 - REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -37,11 +36,11 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-5 + EPS_SCF 1.0E-7 MAX_SCF 20 SCF_GUESS ATOMIC &OT @@ -49,7 +48,7 @@ PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-5 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -60,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -70,7 +69,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 6.0 6.0 6.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/h2o_gapw_t6.inp b/tests/QS/regtest-debug-7/h2o_gapw_t6.inp index d61633ce9d..9809dd14ab 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_t6.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_t6.inp @@ -27,7 +27,6 @@ &END EFIELD &MGRID CUTOFF 100 - REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -36,19 +35,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-5 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-5 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -59,7 +58,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/h2o_gapw_t7.inp b/tests/QS/regtest-debug-7/h2o_gapw_t7.inp index 3273f865f2..be7da6dc9b 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_t7.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_t7.inp @@ -11,7 +11,7 @@ DEBUG_POLARIZABILITY .TRUE. DEBUG_STRESS_TENSOR .FALSE. EPS_NO_ERROR_CHECK 5.e-5 - STOP_ON_MISMATCH .FALSE. + STOP_ON_MISMATCH .TRUE. &END DEBUG &FORCE_EVAL @@ -31,7 +31,6 @@ &END EFIELD &MGRID CUTOFF 100 - REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -40,19 +39,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-6 - MAX_SCF 20 + EPS_SCF 1.0E-8 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-8 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -63,7 +62,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp b/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp index d16c59a6f5..4cbe9cc7ad 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp @@ -28,7 +28,6 @@ &END EFIELD &MGRID CUTOFF 100 - REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -37,11 +36,11 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-10 + EPS_DEFAULT 1.e-14 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-5 + EPS_SCF 1.0E-7 MAX_SCF 20 SCF_GUESS ATOMIC &OT @@ -49,7 +48,7 @@ PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-5 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -60,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -70,7 +69,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 6.0 6.0 6.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp b/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp index 22a5159d07..4d8e18c8fa 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp @@ -30,7 +30,6 @@ &END EFIELD &MGRID CUTOFF 100 - REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -43,15 +42,15 @@ METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-6 - MAX_SCF 20 + EPS_SCF 1.0E-7 + MAX_SCF 10 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-6 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -62,7 +61,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-5 + EPS 1.e-12 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-polar/TEST_FILES.toml b/tests/QS/regtest-polar/TEST_FILES.toml index 083c616850..02631ef944 100644 --- a/tests/QS/regtest-polar/TEST_FILES.toml +++ b/tests/QS/regtest-polar/TEST_FILES.toml @@ -9,5 +9,6 @@ "H2O_md_polar.inp" = [{matcher="M060", tol=6e-04, ref=0.619379304308}] "xTB_LRraman.inp" = [{matcher="M060", tol=2e-05, ref=0.807352993847}] "xTB_LRraman_loc.inp" = [{matcher="M060", tol=2e-05, ref=0.807352993847}] +"xTB_LRraman_spin.inp" = [] "h2o_LRraman_LRI.inp" = [{matcher="M060", tol=4e-04, ref=0.004283834553}] #EOF diff --git a/tests/QS/regtest-polar/xTB_LRraman_spin.inp b/tests/QS/regtest-polar/xTB_LRraman_spin.inp new file mode 100644 index 0000000000..89a9914030 --- /dev/null +++ b/tests/QS/regtest-polar/xTB_LRraman_spin.inp @@ -0,0 +1,63 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + DE 0.0002 + DEBUG_DIPOLE F + DEBUG_FORCES F + DEBUG_POLARIZABILITY T + DEBUG_STRESS_TENSOR F + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 3 + &EFIELD + &END EFIELD + &PRINT + &MOMENTS ON + PERIODIC F + REFERENCE COM + &END MOMENTS + &END PRINT + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION F + &END XTB + &END QS + &SCF + EPS_SCF 1.e-7 + MAX_SCF 100 + SCF_GUESS MOPAC + &END SCF + &END DFT + &PROPERTIES + &LINRES + EPS 1.e-10 + PRECONDITIONER FULL_ALL + &POLAR + DO_RAMAN T + PERIODIC_DIPOLE_OPERATOR F + &END POLAR + &END LINRES + &END PROPERTIES + &SUBSYS + &CELL + ABC 20.0 20.0 20.0 + PERIODIC NONE + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/SE/regtest-2-1/TEST_FILES.toml b/tests/SE/regtest-2-1/TEST_FILES.toml index c8541848d7..ba19a11cbe 100644 --- a/tests/SE/regtest-2-1/TEST_FILES.toml +++ b/tests/SE/regtest-2-1/TEST_FILES.toml @@ -10,7 +10,7 @@ "ch4-restart.inp" = [{matcher="M003", tol=1.0E-14, ref=-180.05471494670982}] "h2o.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315272006}] "h2o_lsd.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315083575}] -"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974557710}] +"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974541340}] "hcn.inp" = [{matcher="M003", tol=1.0E-14, ref=-346.49686119222844}] "hf.inp" = [{matcher="M003", tol=1.0E-14, ref=-499.98506659307861}] "nh4.inp" = [{matcher="M003", tol=1.0E-14, ref=-256.98965446201572}] diff --git a/tests/SE/regtest-2-2/TEST_FILES.toml b/tests/SE/regtest-2-2/TEST_FILES.toml index e0c012c482..1a53a9fbfc 100644 --- a/tests/SE/regtest-2-2/TEST_FILES.toml +++ b/tests/SE/regtest-2-2/TEST_FILES.toml @@ -14,7 +14,7 @@ "FeC.inp" = [{matcher="M003", tol=1.0E-14, ref=-545.05816363206452}] "FeH_1cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-427.83088810217504}] "FeH_7cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-144.32569270051397}] -"FeH_8cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-46.77363824958222}] +"FeH_8cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-46.77363824961697}] "FeH_9cat.inp" = [{matcher="M029", tol=1.0E-14, ref=11798.83943644446481}] "Pt-cis-2xpet3Cl2-si.inp" = [{matcher="M003", tol=3e-14, ref=-3116.3314196834754}] "Pt-cis-2xpet3Cl2-si-noc.inp" = [{matcher="M003", tol=8e-14, ref=-3116.62376488246764}] diff --git a/tests/SE/regtest/TEST_FILES.toml b/tests/SE/regtest/TEST_FILES.toml index ca5a64504c..af15e3f9bc 100644 --- a/tests/SE/regtest/TEST_FILES.toml +++ b/tests/SE/regtest/TEST_FILES.toml @@ -10,7 +10,7 @@ "ch4-restart.inp" = [{matcher="M003", tol=1.0E-14, ref=-180.05471494670982}] "h2o.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315272017}] "h2o_lsd.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315083575}] -"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974557710}] +"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974541340}] "hcn.inp" = [{matcher="M003", tol=1.0E-14, ref=-346.49686119222844}] "hf.inp" = [{matcher="M003", tol=1.0E-14, ref=-499.98506659307856}] "nh4.inp" = [{matcher="M003", tol=1.0E-14, ref=-256.98965446201606}] @@ -21,10 +21,10 @@ # tests for high-spin ROKS "O-ROKS.inp" = [{matcher="M003", tol=1.0E-14, ref=-316.09951999999998}] "O2-ROKS.inp" = [{matcher="M003", tol=1.0E-14, ref=-641.56947944509795}] -"NO2-ROKS.inp" = [{matcher="M003", tol=2.0e-14, ref=-746.41195754911917}] +"NO2-ROKS.inp" = [{matcher="M003", tol=2.0e-14, ref=-746.41195754911630}] #RM1 Model "c2h4_rm1.inp" = [{matcher="M003", tol=1.0E-14, ref=-306.76506723638988}] -"h2op_2.inp" = [{matcher="M003", tol=2.0e-10, ref=-329.25843415861925}] +"h2op_2.inp" = [{matcher="M003", tol=2.0e-10, ref=-329.25843400085944}] "h2po4.inp" = [{matcher="M003", tol=1.0e-11, ref=-2630.34613336826851}] "geom.inp" = [{matcher="M003", tol=3.0e-14, ref=-5484.9811538371541}] "b2h6_pm6.inp" = [{matcher="M003", tol=2.0e-14, ref=-191.26932146375466}] diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index 4bcedaf889..29c61adf90 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -71,6 +71,7 @@ QS/regtest-ot QS/regtest-openpmd openpmd QS/regtest-ec-force libint !ifx QS/regtest-embed libint !ifx +xTB/regtest-spinpol xTB/regtest-5 xTB/regtest-gfn1-d spglib QS/regtest-gpw-2-3 diff --git a/tests/xTB/regtest-1/TEST_FILES.toml b/tests/xTB/regtest-1/TEST_FILES.toml index f595a8da31..3f4b4af04c 100644 --- a/tests/xTB/regtest-1/TEST_FILES.toml +++ b/tests/xTB/regtest-1/TEST_FILES.toml @@ -9,13 +9,13 @@ "ch2o_smear.inp" = [{matcher="E_total", tol=1.0E-12, ref=-7.19753850357134}] "tmol.inp" = [{matcher="E_total", tol=1.0E-12, ref=-41.90845660778482}] "h2.inp" = [{matcher="E_total", tol=1.0E-12, ref=-1.03458223634251}] -"h2_kab.inp" = [{matcher="E_total", tol=1.0E-12, ref=-0.99816707611986}] +"h2_kab.inp" = [{matcher="E_total", tol=1.0E-12, ref=-0.9981670905879}] "h2o-md.inp" = [{matcher="E_total", tol=1.0E-12, ref=-185.14383606866977}] "h2o_str.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76524673249110}] "h2o_strsym.inp" = [] "h2o-atprop.inp" = [{matcher="E_total", tol=1.0E-10, ref=-185.16260010725958}] "h2o-atprop0.inp" = [{matcher="E_total", tol=1.0E-12, ref=-187.45499307126425}] -"si_geo.inp" = [{matcher="E_total", tol=1.0E-11, ref=-14.51194886943525}] +"si_geo.inp" = [{matcher="E_total", tol=1.0E-11, ref=-14.51194893694458}] "si_kp.inp" = [{matcher="E_total", tol=1.0E-12, ref=-14.73191475148811}] "h2o_dimer.inp" = [{matcher="E_total", tol=1.0E-12, ref=-11.54506384435821}] "ghost.inp" = [{matcher="E_total", tol=1.0E-12, ref=-1.03458221876736}] diff --git a/tests/xTB/regtest-debug/TEST_FILES.toml b/tests/xTB/regtest-debug/TEST_FILES.toml index 4e257f0714..2f4e44dd6a 100644 --- a/tests/xTB/regtest-debug/TEST_FILES.toml +++ b/tests/xTB/regtest-debug/TEST_FILES.toml @@ -12,6 +12,7 @@ "ch2o_t07.inp" = [{matcher="M086", tol=1.0E-12, ref=0.954101834865E+00}] "ch2o_t08.inp" = [{matcher="M086", tol=1.0E-12, ref=0.963121521347E+00}] "ch2o_t10.inp" = [] +"ch2o_t11.inp" = [] "ch3br_nonbond_2.inp" = [{matcher="E_total", tol=1.0E-12, ref=-11.78062819229165}] "ch3br_nonbond.inp" = [{matcher="E_total", tol=1.0E-12, ref=-11.78062802267188}] "ch3br_atprop_nonbond.inp" = [{matcher="E_total", tol=1.0E-10, ref=-11.78112904495693}] diff --git a/tests/xTB/regtest-debug/ch2o_t11.inp b/tests/xTB/regtest-debug/ch2o_t11.inp new file mode 100644 index 0000000000..7e0de0ebb2 --- /dev/null +++ b/tests/xTB/regtest-debug/ch2o_t11.inp @@ -0,0 +1,65 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + DE 0.0002 + DEBUG_DIPOLE F + DEBUG_FORCES F + DEBUG_POLARIZABILITY T + DEBUG_STRESS_TENSOR F + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 3 + &EFIELD + &END EFIELD + &PRINT + &MOMENTS ON + PERIODIC T + REFERENCE COM + &END MOMENTS + &END PRINT + &QS + METHOD xTB + &XTB + DO_EWALD T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-8 + MAX_SCF 100 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.2 + METHOD DIRECT_P_MIXING + &END MIXING + &END SCF + &END DFT + &PROPERTIES + &LINRES + EPS 1.e-10 + PRECONDITIONER FULL_ALL + &POLAR + DO_RAMAN T + PERIODIC_DIPOLE_OPERATOR T + &END POLAR + &END LINRES + &END PROPERTIES + &SUBSYS + &CELL + ABC 8.0 8.0 8.0 + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_1.inp b/tests/xTB/regtest-spinpol/Fecp2_1.inp new file mode 100644 index 0000000000..7e4ac3cdee --- /dev/null +++ b/tests/xTB/regtest-spinpol/Fecp2_1.inp @@ -0,0 +1,72 @@ +#High-throughput screening of spin states for transition metal +#complexes with spin-polarized extended tight-binding methods +#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme +#J Comput Chem. 44:2120-2129 (2023) +# +# Singlet energy for Fecp2 at B97-3c geometry +# +# Mult. Total energy diff paper +#gfn1-xTB(CP2K) 1 -29.479086484463970 +#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 +#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 +# +&GLOBAL + PRINT_LEVEL LOW + PROJECT fcp + RUN_TYPE ENERGY +&END GLOBAL + +&FORCE_EVAL + &DFT + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + GFN_TYPE 1 + &END XTB + &END QS + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.e-7 + MAX_SCF 500 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.1 + &END MIXING + &SMEAR ON + ELECTRONIC_TEMPERATURE 300 + FIXED_MAGNETIC_MOMENT -1 + METHOD Fermi_Dirac + &END SMEAR + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 50.0 50.0 50.0 + PERIODIC NONE + &END CELL + &COORD + Fe 0.0004943970693 0.00050226806065 0.00020494479873 + C -0.3748945476706 1.15078378775299 1.63064436887779 + C -1.21024684838874 0.00009720947321 1.62988389793261 + C -0.37398399900121 -1.14992851709978 1.63077532916028 + C 0.97812547612693 -0.70999404521766 1.63184519545447 + C 0.97756566955233 0.71191836616162 1.63175937739436 + H -0.70818900861141 2.17469544072034 1.59690178626611 + H -2.28702109419269 -0.00032606472668 1.59586956045273 + H -0.70648737841786 -2.17410164905906 1.59717234659556 + H 1.84971377940345 -1.34235639717661 1.59936176302322 + H 1.84863500728739 1.34499015079161 1.59918899520882 + C -0.97658096112243 0.7118425331789 -1.63138632255292 + C 0.37587390637791 1.15071653679839 -1.63028814098592 + C -0.97713437408181 -0.7100698747375 -1.63139739298304 + H -1.84767296055729 1.34488555954776 -1.59884933194674 + C 1.21123472478417 0.0000343387919 -1.62947531021637 + H 0.70918449672145 2.17462452492938 -1.59660160539228 + C 0.37498047250513 -1.1499957282639 -1.63031293852782 + H -1.84869994419919 -1.34246107275978 -1.59887902317148 + H 2.28800899615906 -0.00039346637333 -1.59546189880925 + H 0.70746789025611 -2.17417250079252 -1.59665480057888 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_5.inp b/tests/xTB/regtest-spinpol/Fecp2_5.inp new file mode 100644 index 0000000000..3baca7ed9d --- /dev/null +++ b/tests/xTB/regtest-spinpol/Fecp2_5.inp @@ -0,0 +1,75 @@ +#High-throughput screening of spin states for transition metal +#complexes with spin-polarized extended tight-binding methods +#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme +#J Comput Chem. 44:2120-2129 (2023) +# +# Quintet energy for Fecp2 at B97-3c geometry +# Parameter set from supplemental material (sign change!) +# +# Mult. Total energy diff paper +#gfn1-xTB(CP2K) 1 -29.479086484463970 +#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 +#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 +# +&GLOBAL + PRINT_LEVEL LOW + PROJECT fcp + RUN_TYPE ENERGY +&END GLOBAL + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 5 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + GFN_TYPE 1 + &END XTB + &END QS + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.e-7 + MAX_SCF 500 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.10 + &END MIXING + &SMEAR ON + ELECTRONIC_TEMPERATURE 300 + FIXED_MAGNETIC_MOMENT -1 + METHOD Fermi_Dirac + &END SMEAR + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 50.0 50.0 50.0 + PERIODIC NONE + &END CELL + &COORD + Fe 0.00046667507209 0.00007145221698 0.00020650908794 + C -0.29638297378219 1.13792952402792 1.91281475677087 + C -1.1353711727193 -0.01307211356389 1.85694327787714 + C -0.29624869915853 -1.15966026966281 1.94842805058997 + C 1.04087385079726 -0.71562387526317 2.07580896633105 + C 1.04244423611723 0.6947942723046 2.05171179195287 + H -0.62650212350503 2.16327072796029 1.88603396689195 + H -2.2117227394285 -0.01415674206402 1.80863041734873 + H -0.62579911475609 -2.18554059534209 1.93720363428829 + H 1.91216002120559 -1.34806313942887 2.1283304806085 + H 1.91409262335761 1.32757762270685 2.09081210664184 + C -1.03941112021214 0.71741195345069 -2.07528737626978 + C 0.29799620713813 1.16052094578281 -1.94784180534153 + C -1.0419290803645 -0.69301008093721 -2.05138407383301 + H -1.91027753858542 1.35044071196014 -2.12766496611585 + C 1.13635987921557 0.01338364594266 -1.85654165280359 + H 0.62822033535291 2.18618156712011 -1.93633378033781 + C 0.29662013454123 -1.13707637009906 -1.9126008359967 + H -1.91399740141563 -1.32520603287501 -2.09062682589173 + H 2.21271190076452 0.01375882553937 -1.80822349672861 + H 0.62606980036518 -2.16264062977632 -1.88611834507055 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_5_sp.inp b/tests/xTB/regtest-spinpol/Fecp2_5_sp.inp new file mode 100644 index 0000000000..19cac3dab8 --- /dev/null +++ b/tests/xTB/regtest-spinpol/Fecp2_5_sp.inp @@ -0,0 +1,82 @@ +#High-throughput screening of spin states for transition metal +#complexes with spin-polarized extended tight-binding methods +#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme +#J Comput Chem. 44:2120-2129 (2023) +# +# Quintet energy for Fecp2 at B97-3c geometry +# Parameter set from supplemental material (sign change!) +# +# Mult. Total energy diff paper +#gfn1-xTB(CP2K) 1 -29.479086484463970 +#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 +#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 +# +&GLOBAL + PRINT_LEVEL LOW + PROJECT fcp + RUN_TYPE ENERGY +&END GLOBAL + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 5 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + GFN_TYPE 1 + SPIN_POLARISATION T + &PARAMETER + ## SPIN_POL_PARAM atomtype Wss Wsp Wpp Wsd Wpd Wdd + SPIN_POL_PARAM Fe -0.015400 -0.011925 -0.017850 -0.003300 -0.001162 -0.017125 + SPIN_POL_PARAM C -0.030200 -0.025025 -0.022725 -0.000000 -0.000000 -0.000000 + SPIN_POL_PARAM H -0.071550 -0.000000 -0.000000 -0.000000 -0.000000 -0.000000 + &END PARAMETER + &END XTB + &END QS + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.e-7 + MAX_SCF 500 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.10 + &END MIXING + &SMEAR ON + ELECTRONIC_TEMPERATURE 300 + FIXED_MAGNETIC_MOMENT -1 + METHOD Fermi_Dirac + &END SMEAR + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 50.0 50.0 50.0 + PERIODIC NONE + &END CELL + &COORD + Fe 0.00046667507209 0.00007145221698 0.00020650908794 + C -0.29638297378219 1.13792952402792 1.91281475677087 + C -1.1353711727193 -0.01307211356389 1.85694327787714 + C -0.29624869915853 -1.15966026966281 1.94842805058997 + C 1.04087385079726 -0.71562387526317 2.07580896633105 + C 1.04244423611723 0.6947942723046 2.05171179195287 + H -0.62650212350503 2.16327072796029 1.88603396689195 + H -2.2117227394285 -0.01415674206402 1.80863041734873 + H -0.62579911475609 -2.18554059534209 1.93720363428829 + H 1.91216002120559 -1.34806313942887 2.1283304806085 + H 1.91409262335761 1.32757762270685 2.09081210664184 + C -1.03941112021214 0.71741195345069 -2.07528737626978 + C 0.29799620713813 1.16052094578281 -1.94784180534153 + C -1.0419290803645 -0.69301008093721 -2.05138407383301 + H -1.91027753858542 1.35044071196014 -2.12766496611585 + C 1.13635987921557 0.01338364594266 -1.85654165280359 + H 0.62822033535291 2.18618156712011 -1.93633378033781 + C 0.29662013454123 -1.13707637009906 -1.9126008359967 + H -1.91399740141563 -1.32520603287501 -2.09062682589173 + H 2.21271190076452 0.01375882553937 -1.80822349672861 + H 0.62606980036518 -2.16264062977632 -1.88611834507055 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_5_spext.inp b/tests/xTB/regtest-spinpol/Fecp2_5_spext.inp new file mode 100644 index 0000000000..a3231c1980 --- /dev/null +++ b/tests/xTB/regtest-spinpol/Fecp2_5_spext.inp @@ -0,0 +1,79 @@ +#High-throughput screening of spin states for transition metal +#complexes with spin-polarized extended tight-binding methods +#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme +#J Comput Chem. 44:2120-2129 (2023) +# +# Quintet energy for Fecp2 at B97-3c geometry +# Parameter set from supplemental material (sign change!) +# +# Mult. Total energy diff paper +#gfn1-xTB(CP2K) 1 -29.479086484463970 +#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 +#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 +# +&GLOBAL + PRINT_LEVEL LOW + PROJECT fcp + RUN_TYPE ENERGY +&END GLOBAL + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 5 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + GFN_TYPE 1 + SPIN_POLARISATION T + &PARAMETER + SPINPOL_PARAM_FILE_NAME xTB_sp_param_030 + &END PARAMETER + &END XTB + &END QS + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.e-7 + MAX_SCF 500 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.10 + &END MIXING + &SMEAR ON + ELECTRONIC_TEMPERATURE 300 + FIXED_MAGNETIC_MOMENT -1 + METHOD Fermi_Dirac + &END SMEAR + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 50.0 50.0 50.0 + PERIODIC NONE + &END CELL + &COORD + Fe 0.00046667507209 0.00007145221698 0.00020650908794 + C -0.29638297378219 1.13792952402792 1.91281475677087 + C -1.1353711727193 -0.01307211356389 1.85694327787714 + C -0.29624869915853 -1.15966026966281 1.94842805058997 + C 1.04087385079726 -0.71562387526317 2.07580896633105 + C 1.04244423611723 0.6947942723046 2.05171179195287 + H -0.62650212350503 2.16327072796029 1.88603396689195 + H -2.2117227394285 -0.01415674206402 1.80863041734873 + H -0.62579911475609 -2.18554059534209 1.93720363428829 + H 1.91216002120559 -1.34806313942887 2.1283304806085 + H 1.91409262335761 1.32757762270685 2.09081210664184 + C -1.03941112021214 0.71741195345069 -2.07528737626978 + C 0.29799620713813 1.16052094578281 -1.94784180534153 + C -1.0419290803645 -0.69301008093721 -2.05138407383301 + H -1.91027753858542 1.35044071196014 -2.12766496611585 + C 1.13635987921557 0.01338364594266 -1.85654165280359 + H 0.62822033535291 2.18618156712011 -1.93633378033781 + C 0.29662013454123 -1.13707637009906 -1.9126008359967 + H -1.91399740141563 -1.32520603287501 -2.09062682589173 + H 2.21271190076452 0.01375882553937 -1.80822349672861 + H 0.62606980036518 -2.16264062977632 -1.88611834507055 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Ferrocene.inp b/tests/xTB/regtest-spinpol/Ferrocene.inp new file mode 100644 index 0000000000..8761cc2156 --- /dev/null +++ b/tests/xTB/regtest-spinpol/Ferrocene.inp @@ -0,0 +1,64 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT fcp + RUN_TYPE ENERGY +&END GLOBAL + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 5 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + GFN_TYPE 1 + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.e-7 + MAX_SCF 500 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.04 + #METHOD DIRECT_P_MIXING + &END MIXING + &SMEAR ON + ELECTRONIC_TEMPERATURE 300 + FIXED_MAGNETIC_MOMENT -1 + METHOD Fermi_Dirac + &END SMEAR + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 50.0 50.0 50.0 + PERIODIC NONE + &END CELL + &COORD + Fe 0.00049406476719 0.00053168004165 0.00020491843636 + C -0.37271343833523 1.14624540866561 1.67922290481448 + C -1.20491760216065 0.00011606553248 1.67867752557376 + C -0.37195847519282 -1.14545516103349 1.67923381734091 + C 0.97468028030604 -0.70729459020657 1.67902691822851 + C 0.97422867195674 0.7089288330528 1.67897677410672 + H -0.70638981845675 2.17223173166618 1.76533130266172 + H -2.28379902754658 -0.00021140895756 1.76462815066646 + H -0.70497268601096 -2.17165352881699 1.7653501482553 + H 1.84766822202289 -1.34114936541527 1.76542334732916 + H 1.84679969810106 1.34335706981963 1.76538111079929 + C -0.97323936548635 0.70899355225443 -1.6786095674155 + C 0.37367886169607 1.14629178120918 -1.67881030467712 + C -0.97369370100792 -0.70722987462659 -1.67857444641498 + H -1.84582276828766 1.34340645872887 -1.76499406584606 + C 1.20590557946464 0.00018966220257 -1.67826815962836 + H 0.7073473789547 2.17227911799041 -1.76490781463678 + C 0.37296900620916 -1.14540880634454 -1.67882727297382 + H -1.84666917780632 -1.34110011176957 -1.76499032806053 + H 2.28478694620084 -0.00017101174833 -1.76421928202354 + H 0.70599105061188 -2.17160610224494 -1.764954876536 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/TEST_FILES.toml b/tests/xTB/regtest-spinpol/TEST_FILES.toml new file mode 100644 index 0000000000..c5179f4583 --- /dev/null +++ b/tests/xTB/regtest-spinpol/TEST_FILES.toml @@ -0,0 +1,21 @@ +# runs are executed in the same order as in this file +# the second field tells which test should be run in order to compare with the last available output +# e.g. 0 means do not compare anything, running is enough +# 1 compares the last total energy in the file +# for details see cp2k/tools/do_regtest +"ch2o.inp" = [{matcher="E_total", tol=1.0E-12, ref=-7.70606717289255}] +"Ferrocene.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.41637966342602}] +"ch2o_force.inp" = [] +"ch2o_stress.inp" = [] +# +"ch2o_kp_force.inp" = [] +"ch2o_kp_stress.inp" = [] +# +"ch2o_polar.inp" = [] +"h2o_sTDA_spin.inp" = [] +# +"Fecp2_1.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.47908648446399}] +"Fecp2_5.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.3754324434514}] +"Fecp2_5_sp.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.45805742032436}] +"Fecp2_5_spext.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.45805742032436}] +#EOF diff --git a/tests/xTB/regtest-spinpol/ch2o.inp b/tests/xTB/regtest-spinpol/ch2o.inp new file mode 100644 index 0000000000..1a74e021bd --- /dev/null +++ b/tests/xTB/regtest-spinpol/ch2o.inp @@ -0,0 +1,43 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + STRESS_TENSOR ANALYTICAL + &DFT + CHARGE 0 + LSD + MULTIPLICITY 3 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-7 + MAX_SCF 100 + SCF_GUESS MOPAC + &END SCF + &END DFT + &PRINT + &FORCES + &END FORCES + &STRESS_TENSOR + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + ABC 20.0 20.0 20.0 + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_force.inp b/tests/xTB/regtest-spinpol/ch2o_force.inp new file mode 100644 index 0000000000..b84d5fe973 --- /dev/null +++ b/tests/xTB/regtest-spinpol/ch2o_force.inp @@ -0,0 +1,49 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 XY + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0001 + EPS_NO_ERROR_CHECK 0.000001 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + &DFT + CHARGE 0 + LSD + MULTIPLICITY 3 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-6 + MAX_SCF 100 + SCF_GUESS MOPAC + &END SCF + &END DFT + &PRINT + &FORCES + &END FORCES + &END PRINT + &SUBSYS + &CELL + ABC 5.0 5.0 5.0 + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_kp_force.inp b/tests/xTB/regtest-spinpol/ch2o_kp_force.inp new file mode 100644 index 0000000000..7fafc8fb94 --- /dev/null +++ b/tests/xTB/regtest-spinpol/ch2o_kp_force.inp @@ -0,0 +1,54 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O_kp + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 X + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0001 + EPS_NO_ERROR_CHECK 0.000001 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + &DFT + CHARGE 0 + LSD + MULTIPLICITY 3 + &KPOINTS + FULL_GRID ON + PARALLEL_GROUP_SIZE 0 + SCHEME MONKHORST-PACK 2 2 2 + SYMMETRY ON + &END KPOINTS + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-6 + MAX_SCF 100 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.1 + &END MIXING + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 4.0 4.0 4.0 + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_kp_stress.inp b/tests/xTB/regtest-spinpol/ch2o_kp_stress.inp new file mode 100644 index 0000000000..22a0d05074 --- /dev/null +++ b/tests/xTB/regtest-spinpol/ch2o_kp_stress.inp @@ -0,0 +1,54 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O_kp + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + DEBUG_FORCES F + DEBUG_STRESS_TENSOR T + DX 0.0001 + EPS_NO_ERROR_CHECK 0.000001 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + STRESS_TENSOR ANALYTICAL + &DFT + CHARGE 0 + LSD + MULTIPLICITY 3 + &KPOINTS + FULL_GRID ON + PARALLEL_GROUP_SIZE 0 + SCHEME MONKHORST-PACK 2 2 2 + SYMMETRY ON + &END KPOINTS + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-6 + MAX_SCF 100 + SCF_GUESS MOPAC + &MIXING + ALPHA 0.40 + &END MIXING + &END SCF + &END DFT + &SUBSYS + &CELL + ABC 4.0 4.0 4.0 + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_polar.inp b/tests/xTB/regtest-spinpol/ch2o_polar.inp new file mode 100644 index 0000000000..01247c697d --- /dev/null +++ b/tests/xTB/regtest-spinpol/ch2o_polar.inp @@ -0,0 +1,63 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + DE 0.0002 + DEBUG_DIPOLE F + DEBUG_FORCES F + DEBUG_POLARIZABILITY T + DEBUG_STRESS_TENSOR F + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + &DFT + LSD + MULTIPLICITY 3 + &EFIELD + &END EFIELD + &PRINT + &MOMENTS ON + PERIODIC F + REFERENCE COM + &END MOMENTS + &END PRINT + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-7 + MAX_SCF 100 + SCF_GUESS MOPAC + &END SCF + &END DFT + &PROPERTIES + &LINRES + EPS 1.e-10 + PRECONDITIONER FULL_ALL + &POLAR + DO_RAMAN T + PERIODIC_DIPOLE_OPERATOR F + &END POLAR + &END LINRES + &END PROPERTIES + &SUBSYS + &CELL + ABC 20.0 20.0 20.0 + PERIODIC NONE + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_stress.inp b/tests/xTB/regtest-spinpol/ch2o_stress.inp new file mode 100644 index 0000000000..2c4b342e67 --- /dev/null +++ b/tests/xTB/regtest-spinpol/ch2o_stress.inp @@ -0,0 +1,51 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT CH2O + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + DEBUG_FORCES F + DEBUG_STRESS_TENSOR T + DX 0.001 + EPS_NO_ERROR_CHECK 0.000001 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + STRESS_TENSOR ANALYTICAL + &DFT + CHARGE 0 + LSD + MULTIPLICITY 3 + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.e-7 + MAX_SCF 100 + SCF_GUESS MOPAC + &END SCF + &END DFT + &PRINT + &FORCES + &END FORCES + &STRESS_TENSOR + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + ABC 5.0 5.0 5.0 + &END CELL + &COORD + O 0.051368 0.000000 0.000000 + C 1.278612 0.000000 0.000000 + H 1.870460 0.939607 0.000000 + H 1.870460 -0.939607 0.000000 + &END COORD + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp b/tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp new file mode 100644 index 0000000000..7df33baca4 --- /dev/null +++ b/tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp @@ -0,0 +1,67 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT H2O + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 Z + DE 0.0002 + DEBUG_DIPOLE .FALSE. + DEBUG_FORCES .TRUE. + DEBUG_POLARIZABILITY .FALSE. + DEBUG_STRESS_TENSOR .FALSE. + STOP_ON_MISMATCH F +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + LSD + MULTIPLICITY 3 + &EXCITED_STATES T + STATE 1 + &END EXCITED_STATES + &QS + METHOD xTB + &XTB + CHECK_ATOMIC_CHARGES F + SPIN_POLARISATION T + &END XTB + &END QS + &SCF + EPS_SCF 1.0E-8 + MAX_SCF 50 + SCF_GUESS MOPAC + &END SCF + &END DFT + &PRINT + &FORCES + &END FORCES + &END PRINT + &PROPERTIES + &TDDFPT + CONVERGENCE [eV] 1.0e-7 + KERNEL sTDA + MAX_ITER 50 + NSTATES 5 + &STDA + FRACTION 0.50 + &END STDA + &END TDDFPT + &END PROPERTIES + &SUBSYS + &CELL + ABC [angstrom] 6.0 6.0 6.0 + &END CELL + &COORD + O 0.000000 0.000000 0.000000 + H 0.000000 -0.757136 0.580545 + H 0.000000 0.757136 0.580545 + &END COORD + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/xTB/regtest-stda-force/TEST_FILES.toml b/tests/xTB/regtest-stda-force/TEST_FILES.toml index 0d12f0d51c..4b6f5e42ce 100644 --- a/tests/xTB/regtest-stda-force/TEST_FILES.toml +++ b/tests/xTB/regtest-stda-force/TEST_FILES.toml @@ -7,9 +7,9 @@ "h2o_f12.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.85052842359978}] "h2o_f13.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76860088550339}] "h2o_f14.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76860088550339}] -#h2o_f15.inp 1 1.0E-12 0.000000E+00 -#h2o_f16.inp 1 1.0E-12 0.000000E+00 -#h2o_f17.inp 1 1.0E-12 0.000000E+00 +"h2o_f15.inp" = [] +"h2o_f16.inp" = [] +"h2o_f17.inp" = [] "h2o_f18.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76904757361574}] -#h2o_f19.inp 1 1.0E-12 0.000000E+00 +"h2o_f19.inp" = [] #EOF diff --git a/tests/xTB/regtest-stda-force/h2o_f12.inp b/tests/xTB/regtest-stda-force/h2o_f12.inp index 2be85f896e..e98e98e15b 100644 --- a/tests/xTB/regtest-stda-force/h2o_f12.inp +++ b/tests/xTB/regtest-stda-force/h2o_f12.inp @@ -2,7 +2,6 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f13.inp b/tests/xTB/regtest-stda-force/h2o_f13.inp index e01f2491ed..a640fa6bb8 100644 --- a/tests/xTB/regtest-stda-force/h2o_f13.inp +++ b/tests/xTB/regtest-stda-force/h2o_f13.inp @@ -2,7 +2,6 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f14.inp b/tests/xTB/regtest-stda-force/h2o_f14.inp index 08b179a313..7500a208d0 100644 --- a/tests/xTB/regtest-stda-force/h2o_f14.inp +++ b/tests/xTB/regtest-stda-force/h2o_f14.inp @@ -2,7 +2,6 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f15.inp b/tests/xTB/regtest-stda-force/h2o_f15.inp index 3a2456ec73..2592ffb9a6 100644 --- a/tests/xTB/regtest-stda-force/h2o_f15.inp +++ b/tests/xTB/regtest-stda-force/h2o_f15.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG + CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-stda-force/h2o_f16.inp b/tests/xTB/regtest-stda-force/h2o_f16.inp index 26e6aabd46..1777b1bdc4 100644 --- a/tests/xTB/regtest-stda-force/h2o_f16.inp +++ b/tests/xTB/regtest-stda-force/h2o_f16.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG + CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-stda-force/h2o_f17.inp b/tests/xTB/regtest-stda-force/h2o_f17.inp index 70c6e8cd96..15c0d8c3da 100644 --- a/tests/xTB/regtest-stda-force/h2o_f17.inp +++ b/tests/xTB/regtest-stda-force/h2o_f17.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG + CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-stda-force/h2o_f18.inp b/tests/xTB/regtest-stda-force/h2o_f18.inp index 806cd27e75..4db31f65bd 100644 --- a/tests/xTB/regtest-stda-force/h2o_f18.inp +++ b/tests/xTB/regtest-stda-force/h2o_f18.inp @@ -2,7 +2,6 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f19.inp b/tests/xTB/regtest-stda-force/h2o_f19.inp index ac704de479..6b10b2a23b 100644 --- a/tests/xTB/regtest-stda-force/h2o_f19.inp +++ b/tests/xTB/regtest-stda-force/h2o_f19.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG - ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG + CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml b/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml index 6041b7d58f..267e910c69 100644 --- a/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml @@ -19,8 +19,8 @@ "N2_gfn2_uks_cp2k_mixer_force.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "O2_gfn2_uks_force.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "O2_gfn2_uks_ot.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.9319651546}] -"O2_gfn2_uks_xyz_ls_cp2k_mixer.inp" = [{matcher="M011", tol=1.0E-8, ref=-7.93196513956454}] -"O2plus_gfn2_uks_cp2k_mixer.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.26596846265160}] +"O2_gfn2_uks_xyz_ls_cp2k_mixer.inp" = [{matcher="M011", tol=1.0E-8, ref=-7.931965128812277}] +"O2plus_gfn2_uks_cp2k_mixer.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.27211104712107}] "O2plus_gfn2_uks_cp2k_mixer_force.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "CH2O_gfn2_force_cp2k_mixer.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "CH2O_gfn2_stress.inp" = [{matcher="M042", tol=1.0E-7, ref=0.0000000}] From 263dc54b7d6ab4dd71283fea512c2af048e8c56b Mon Sep 17 00:00:00 2001 From: SY Wang Date: Wed, 22 Jul 2026 17:40:05 +0800 Subject: [PATCH 19/30] CMake: Drop manual default setting of CMAKE_INSTALL_LIBDIR to follow GNUInstallDirs rule (#5617) --- CMakeLists.txt | 4 ---- make_cp2k.sh | 3 +++ tools/toolchain/build_cp2k.sh | 3 ++- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index e5e5b846e5..cc5327c8b3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -106,10 +106,6 @@ foreach(__var ROCM_ROOT CRAY_ROCM_ROOT ORNL_ROCM_ROOT CRAY_ROCM_PREFIX endif() endforeach() -set(CMAKE_INSTALL_LIBDIR - "lib" - CACHE PATH "Default installation directory for libraries") - # ================================================================================================= # OPTIONS option(CMAKE_POSITION_INDEPENDENT_CODE "Enable position independent code" ON) diff --git a/make_cp2k.sh b/make_cp2k.sh index d6bb56006c..db27114208 100755 --- a/make_cp2k.sh +++ b/make_cp2k.sh @@ -1363,6 +1363,7 @@ if [[ ! -d "${CMAKE_BUILD_PATH}" ]]; then -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} \ -DCMAKE_BUILD_TYPE="${CP2K_BUILD_TYPE}" \ -DCMAKE_INSTALL_PREFIX="${INSTALL_PREFIX}" \ + -DCMAKE_INSTALL_LIBDIR="lib" \ -DCMAKE_INSTALL_MESSAGE="${INSTALL_MESSAGE}" \ -DCMAKE_SKIP_RPATH="ON" \ -DCMAKE_VERBOSE_MAKEFILE="${VERBOSE_MAKEFILE}" \ @@ -1380,6 +1381,7 @@ if [[ ! -d "${CMAKE_BUILD_PATH}" ]]; then -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} \ -DCMAKE_BUILD_TYPE="${CP2K_BUILD_TYPE}" \ -DCMAKE_INSTALL_PREFIX="${INSTALL_PREFIX}" \ + -DCMAKE_INSTALL_LIBDIR="lib" \ -DCMAKE_INSTALL_MESSAGE="${INSTALL_MESSAGE}" \ -DCMAKE_SKIP_RPATH="ON" \ -DCMAKE_VERBOSE_MAKEFILE="${VERBOSE_MAKEFILE}" \ @@ -1401,6 +1403,7 @@ if [[ ! -d "${CMAKE_BUILD_PATH}" ]]; then -DCMAKE_EXE_LINKER_FLAGS="-static" \ -DCMAKE_FIND_LIBRARY_SUFFIXES=".a" \ -DCMAKE_INSTALL_PREFIX="${INSTALL_PREFIX}" \ + -DCMAKE_INSTALL_LIBDIR="lib" \ -DCMAKE_INSTALL_MESSAGE="${INSTALL_MESSAGE}" \ -DCMAKE_SKIP_RPATH="ON" \ -DCMAKE_VERBOSE_MAKEFILE="${VERBOSE_MAKEFILE}" \ diff --git a/tools/toolchain/build_cp2k.sh b/tools/toolchain/build_cp2k.sh index 981a109e8b..b8a671c904 100755 --- a/tools/toolchain/build_cp2k.sh +++ b/tools/toolchain/build_cp2k.sh @@ -178,7 +178,8 @@ source "${TOOLCHAIN_INSTALL_DIR}/setup" source "${TOOLCHAIN_INSTALL_DIR}/toolchain.conf" # Generate cmake options for compiling cp2k -CMAKE_OPTIONS="-DCMAKE_INSTALL_PREFIX=${CMAKE_INSTALL_PREFIX} -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS}" +CMAKE_OPTIONS="-DCMAKE_INSTALL_PREFIX=${CMAKE_INSTALL_PREFIX} -DCMAKE_INSTALL_LIBDIR=lib" +CMAKE_OPTIONS+=" -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS}" if [[ ${CMAKE_INSTALL_PREFIX} == ${CP2K_ROOT}/* ]]; then CMAKE_OPTIONS+=" -DCP2K_DATA_DIR=${CP2K_ROOT}/data" fi From ee8ac2f01ad12ae98d1ea8920a545808cc2a33f2 Mon Sep 17 00:00:00 2001 From: SY Wang Date: Thu, 23 Jul 2026 00:21:19 +0800 Subject: [PATCH 20/30] Correct CMAKE_INSTALL_LIBDIR in Fedora SPEC (#5620) --- tools/fedora/cp2k.spec | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/fedora/cp2k.spec b/tools/fedora/cp2k.spec index 322ed2629a..a748292ab1 100644 --- a/tools/fedora/cp2k.spec +++ b/tools/fedora/cp2k.spec @@ -154,6 +154,7 @@ for mpi in '' mpich openmpi; do module load mpi/${mpi}-%{_arch} cmake_mpi_args=( "-DCMAKE_INSTALL_PREFIX:PATH=${MPI_HOME}" + "-DCMAKE_INSTALL_LIBDIR:PATH=lib" "-DCMAKE_PREFIX_PATH:PATH=${MPI_HOME};%{_prefix}" "-DCMAKE_INSTALL_Fortran_MODULES:PATH=${MPI_FORTRAN_MOD_DIR}/cp2k" "-DCP2K_DATA_DIR:PATH=%{_datadir}/cp2k/data" @@ -163,7 +164,6 @@ for mpi in '' mpich openmpi; do else cmake_mpi_args=( "-DCMAKE_INSTALL_Fortran_MODULES:PATH=%{_fmoddir}/cp2k" - "-DCMAKE_INSTALL_LIBDIR:PATH=lib64" "-DCP2K_USE_MPI:BOOL=OFF" ) fi From 735a61ddab628ae54d18a6817003872322ab6f70 Mon Sep 17 00:00:00 2001 From: RitajTyagi <93324922+RitajTyagi@users.noreply.github.com> Date: Wed, 22 Jul 2026 22:00:38 +0200 Subject: [PATCH 21/30] RIRS: Improvement in GW RIRS code for non-periodic systems (#5621) Co-authored-by: Ritaj Tyagi --- src/gw_large_cell_gamma_ri_rs.F | 156 +- src/gw_non_periodic_ri_rs.F | 3739 +++++++++++++---- src/gw_utils.F | 36 +- src/input_cp2k_properties_dft.F | 127 +- src/post_scf_bandstructure_types.F | 25 +- .../06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp | 83 + ...S-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix | Bin 102883 -> 103043 bytes tests/QS/regtest-gw-realspace/TEST_FILES.toml | 4 + 8 files changed, 3212 insertions(+), 958 deletions(-) create mode 100644 tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp diff --git a/src/gw_large_cell_gamma_ri_rs.F b/src/gw_large_cell_gamma_ri_rs.F index d80730fb64..5ed9974a7b 100644 --- a/src/gw_large_cell_gamma_ri_rs.F +++ b/src/gw_large_cell_gamma_ri_rs.F @@ -225,8 +225,8 @@ CONTAINS INTEGER :: c_size, chunk_size, dimen_ORB, handle, i, i_blk, iatom, natom, npcol, nprow, & num_grid_chunks, r_end, r_start, total_grid_npts INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf - INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, col_dist_ks, & - r_blk_sizes, row_dist, row_dist_ks + INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, r_blk_sizes, & + row_dist REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: atom_col_buffer TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell @@ -273,12 +273,9 @@ CONTAINS ! C. Fetch CP2K's Default Process Grid Configuration CALL get_qs_env(qs_env, dbcsr_dist=dbcsr_dist_ks) - CALL dbcsr_distribution_get(dbcsr_dist_ks, row_dist=row_dist_ks, col_dist=col_dist_ks) + CALL dbcsr_distribution_get(dbcsr_dist_ks, nprows=nprow, npcols=npcol) ! D. Build Custom Mappings using Round-Robin across the 2D process grid - ! (MAXVAL + 1 accounts for 0-based process indexing in DBCSR) - nprow = MAXVAL(row_dist_ks) + 1 - npcol = MAXVAL(col_dist_ks) + 1 ALLOCATE (row_dist(num_grid_chunks)) DO i = 1, num_grid_chunks @@ -379,43 +376,34 @@ CONTAINS TYPE(cell_type), POINTER :: cell REAL(KIND=dp), INTENT(IN) :: r2_threshold - INTEGER :: first_sgf, i_pt, ico, iend_co, ikind, ipgf, iset, isgf, ishell, istart_co, ix, & - ix_max, ix_min, iy, iy_max, iy_min, iz, iz_max, iz_min, l, last_sgf, lx, ly, lz, & - n_cart_total, row_idx + CHARACTER(LEN=*), PARAMETER :: routineN = 'fill_phi_for_atom' + + INTEGER :: first_sgf, handle, i_pt, ico, iend_co, ikind, ipgf, iset, isgf, ishell, & + istart_co, ix, ix_max, ix_min, iy, iy_max, iy_min, iz, iz_max, iz_min, l, last_sgf, lx, & + ly, lz, n_cart_total, row_idx REAL(KIND=dp) :: alpha, cell_vector(3), dist_vec(3), & dist_vec_raw(3), exp_val, poly, r2, & r_atom(3), weight REAL(KIND=dp), DIMENSION(3, 3) :: hmat TYPE(gto_basis_set_type), POINTER :: orb_basis_set + CALL timeset(routineN, handle) + ! Get Atom Info ikind = particle_set(iatom)%atomic_kind%kind_number CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type="ORB") CALL get_cell(cell=cell, h=hmat) - IF (.NOT. ASSOCIATED(orb_basis_set)) RETURN - - IF (cell%perd(1) == 1) THEN - ix_min = -1 - ix_max = 1 - ELSE - ix_min = 0 - ix_max = 0 - END IF - IF (cell%perd(2) == 1) THEN - iy_min = -1 - iy_max = 1 - ELSE - iy_min = 0 - iy_max = 0 + IF (.NOT. ASSOCIATED(orb_basis_set)) THEN + CALL timestop(handle) + RETURN END IF - IF (cell%perd(3) == 1) THEN - iz_min = -1 - iz_max = 1 - ELSE - iz_min = 0 - iz_max = 0 + IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0 + END IF + IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0 + END IF + IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0 END IF r_atom = particle_set(iatom)%r @@ -482,6 +470,8 @@ CONTAINS END DO !$OMP END PARALLEL DO + CALL timestop(handle) + END SUBROUTINE fill_phi_for_atom ! ************************************************************************************************** @@ -506,13 +496,14 @@ CONTAINS routineN = 'compute_coeff_Z_lP' INTEGER :: atom_j_mepos, atom_j_stride, atom_P, atom_P_start, atom_P_stride, col_end, & - col_start, current_chunk_size, g, group_handle, handle, i, i_blk, ikind, info, j, j_ri, & - l, loc_idx, loc_ptr, max_ao_size, max_loc_ri, my_group, n_ao_total, n_grid_total, & - n_groups, n_loc_ri, n_local_grid, n_procs_per_atom, natom, nkind, num_grid_chunks, & - P_loop_atom, r_end, r_start, source_atom + col_start, current_chunk_size, g, group_handle, handle, handle_dpotrf, handle_dpotrs, & + handle_dsyrk, i, i_blk, ikind, info, j, j_ri, l, loc_idx, loc_ptr, max_ao_size, & + max_loc_ri, my_group, n_ao_total, n_grid_total, n_groups, n_loc_ri, n_local_grid, & + n_procs_per_atom, natom, nkind, npcol_phi, num_grid_chunks, P_loop_atom, r_end, r_start, & + source_atom INTEGER, ALLOCATABLE, DIMENSION(:) :: local_grid_idx, row_offset - INTEGER, DIMENSION(:), POINTER :: col_dist_phi, col_dist_ri, r_blk_sizes, & - ri_blk_sizes, row_dist_grid + INTEGER, DIMENSION(:), POINTER :: col_dist_ri, r_blk_sizes, ri_blk_sizes, & + row_dist_grid REAL(KIND=dp) :: cutoff_ri, cutoff_ri_2, d_sP, dist2_min, & r2_threshold, r_c, t1, t2, t3 REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cutoff_ri_per_atom, cutoff_ri_per_kind, & @@ -577,7 +568,8 @@ CONTAINS ! 1. SETUP DBCSR TOPOLOGY & EXACT OFFSETS ! ========================================================================= CALL dbcsr_get_info(mat_phi_mu_l, row_blk_size=r_blk_sizes, distribution=dist_phi) - CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, col_dist=col_dist_phi, group=group_handle) + CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, & + group=group_handle, npcols=npcol_phi) num_grid_chunks = SIZE(r_blk_sizes) @@ -590,7 +582,7 @@ CONTAINS ALLOCATE (ri_blk_sizes(natom), col_dist_ri(natom)) DO atom_P = 1, natom ri_blk_sizes(atom_P) = bs_env%i_RI_end_from_atom(atom_P) - bs_env%i_RI_start_from_atom(atom_P) + 1 - col_dist_ri(atom_P) = MOD(atom_P - 1, MAXVAL(col_dist_phi) + 1) + col_dist_ri(atom_P) = MOD(atom_P - 1, npcol_phi) END DO CALL dbcsr_distribution_new(dist_Z, template=dist_phi, row_dist=row_dist_grid, col_dist=col_dist_ri) @@ -759,8 +751,10 @@ CONTAINS ALLOCATE (D_local(n_local_grid, n_local_grid)) D_local = 0.0_dp + CALL timeset(routineN//"_dsyrk", handle_dsyrk) CALL dsyrk("L", "N", n_local_grid, n_ao_total, 1.0_dp, phi_local, & n_local_grid, 0.0_dp, D_local, n_local_grid) + CALL timestop(handle_dsyrk) !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(n_local_grid, D_local, d_vec_local, bs_env) & @@ -821,9 +815,13 @@ CONTAINS ! F. Solve — BLAS dpotrf/dpotrs or ScaLAPACK pdpotrf/pdpotrs ! --------------------------------------------------------------------- IF (n_procs_per_atom == 1) THEN + CALL timeset(routineN//"_dpotrf", handle_dpotrf) CALL dpotrf('L', n_local_grid, D_local, n_local_grid, info) + CALL timestop(handle_dpotrf) + CALL timeset(routineN//"_dpotrs", handle_dpotrs) CALL dpotrs('L', n_local_grid, n_loc_ri, D_local, n_local_grid, & d_lp_local, n_local_grid, info) + CALL timestop(handle_dpotrs) DEALLOCATE (D_local) ELSE CALL solve_D_lp_distributed(phi_local, d_vec_local, d_lp_local, & @@ -958,12 +956,12 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_d_lp' INTEGER, PARAMETER :: grid_chunk = 1024 - INTEGER :: atom_j, atom_k, c, handle, ix_max, ix_min, ix_R, ix_S, iy_max, iy_min, iy_R, & - iy_S, iz_max, iz_min, iz_R, iz_S, j, jk_idx, jsize, jstart, k, ksize, kstart, l, l0, & - natom, ri + INTEGER :: atom_j, atom_k, c, handle, handle_dgemm, ix_max, ix_min, ix_R, ix_S, iy_max, & + iy_min, iy_R, iy_S, iz_max, iz_min, iz_R, iz_S, j, jk_idx, jsize, jstart, k, ksize, & + kstart, l, l0, natom, ri INTEGER, DIMENSION(3) :: cell_R_vec, cell_S_vec LOGICAL :: any_kept, screened - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: int_2d_prv, rho_chunk + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: d_lp_prv, int_2d_prv, rho_chunk REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: int_3c_prv, int_3c_sum TYPE(gw_3c_ws_type) :: ws @@ -971,41 +969,28 @@ CONTAINS natom = SIZE(bs_env%i_ao_start_from_atom) - IF (cell%perd(1) == 1) THEN - ix_min = -1 - ix_max = 1 - ELSE - ix_min = 0 - ix_max = 0 + IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0 END IF - IF (cell%perd(2) == 1) THEN - iy_min = -1 - iy_max = 1 - ELSE - iy_min = 0 - iy_max = 0 + IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0 END IF - IF (cell%perd(3) == 1) THEN - iz_min = -1 - iz_max = 1 - ELSE - iz_min = 0 - iz_max = 0 + IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0 END IF !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, max_ao_size, & !$OMP natom, ix_min, ix_max, iy_min, iy_max, iz_min, iz_max, & !$OMP atom_j_mepos, atom_j_stride) & - !$OMP PRIVATE(any_kept, atom_j, atom_k, c, j, jk_idx, jsize, jstart, k, ksize, kstart, l, & - !$OMP l0, ri, ix_R, iy_R, iz_R, ix_S, iy_S, iz_S, cell_R_vec, cell_S_vec, & - !$OMP screened, int_2d_prv, rho_chunk, int_3c_prv, int_3c_sum, ws) + !$OMP PRIVATE(any_kept, atom_j, atom_k, c, handle_dgemm, j, jk_idx, jsize, jstart, k, & + !$OMP ksize, kstart, l, l0, ri, ix_R, iy_R, iz_R, ix_S, iy_S, iz_S, cell_R_vec, & + !$OMP cell_S_vec, screened, d_lp_prv, int_2d_prv, rho_chunk, int_3c_prv, int_3c_sum, ws) CALL gw_3c_ws_create(ws, ctx) ALLOCATE (int_3c_prv(max_ao_size, max_ao_size, n_loc_ri)) ALLOCATE (int_3c_sum(max_ao_size, max_ao_size, n_loc_ri)) ALLOCATE (int_2d_prv(max_ao_size*max_ao_size, n_loc_ri)) ALLOCATE (rho_chunk(grid_chunk, max_ao_size*max_ao_size)) + ALLOCATE (d_lp_prv(n_grid_total, n_loc_ri)) + d_lp_prv(:, :) = 0.0_dp ! atom_P pinned at cell (0,0,0); enumerate (atom_j, cell_R) × (atom_k, cell_S). The ctx ! integral builder's kind_radius triangle screen sets screened=.TRUE. for the bulk of @@ -1014,7 +999,7 @@ CONTAINS ! MPI-stride atom_j over the subgroup (atom_j_stride = 1 for the BLAS path, > 1 for the ! ScaLAPACK path). COLLAPSE(2) dropped because the outer stride is non-unit under ! ScaLAPACK; the inner atom_k loop carries enough work for DYNAMIC. - !$OMP DO SCHEDULE(DYNAMIC) REDUCTION(+:d_lp) + !$OMP DO SCHEDULE(DYNAMIC) DO atom_j = atom_j_mepos + 1, natom, atom_j_stride DO atom_k = 1, natom jstart = bs_env%i_ao_start_from_atom(atom_j) @@ -1079,16 +1064,23 @@ CONTAINS END DO END DO END DO + CALL timeset(routineN//"_dgemm", handle_dgemm) CALL dgemm("N", "N", c, n_loc_ri, jsize*ksize, & 1.0_dp, rho_chunk, grid_chunk, & int_2d_prv, max_ao_size*max_ao_size, & - 1.0_dp, d_lp(l0, 1), n_grid_total) + 1.0_dp, d_lp_prv(l0, 1), n_grid_total) + CALL timestop(handle_dgemm) END DO END DO END DO !$OMP END DO - DEALLOCATE (int_3c_prv, int_3c_sum, int_2d_prv, rho_chunk) + !$OMP CRITICAL (compute_d_lp_reduce) + d_lp(1:n_grid_total, 1:n_loc_ri) = d_lp(1:n_grid_total, 1:n_loc_ri) + & + d_lp_prv(1:n_grid_total, 1:n_loc_ri) + !$OMP END CRITICAL (compute_d_lp_reduce) + + DEALLOCATE (int_3c_prv, int_3c_sum, int_2d_prv, rho_chunk, d_lp_prv) CALL gw_3c_ws_release(ws) !$OMP END PARALLEL @@ -1114,8 +1106,8 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'get_mat_chi_Gamma_tau' INTEGER :: handle, i, i_t, ispin, npcol - INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_ao, & - dist_col_grid, dist_row_grid + INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_grid, & + dist_row_grid REAL(KIND=dp) :: t1, tau TYPE(dbcsr_distribution_type) :: dist_grid_grid, dist_phi TYPE(dbcsr_type) :: matrix_chi_grid, matrix_chi_grid_spin, & @@ -1127,10 +1119,7 @@ CONTAINS ! 1. SETUP CORE TOPOLOGIES ! ========================================================================= CALL dbcsr_get_info(mat_phi_mu_l, distribution=dist_phi, row_blk_size=blk_grid, col_blk_size=blk_ao) - CALL dbcsr_distribution_get(dist_phi, row_dist=dist_row_grid, col_dist=dist_col_ao) - - ! Determine number of MPI process columns - npcol = MAXVAL(dist_col_ao) + 1 + CALL dbcsr_distribution_get(dist_phi, row_dist=dist_row_grid, npcols=npcol) ! Build a perfectly safe column distribution for the Grid dimension ALLOCATE (dist_col_grid(SIZE(blk_grid))) @@ -1993,18 +1982,23 @@ CONTAINS TYPE(dbcsr_distribution_type), INTENT(OUT) :: square_dist INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: blk_sizes, mapped_dist - INTEGER :: i, np + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_square_topology' + + INTEGER :: handle, i, np, npcols, nprows INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist, row_blk, row_dist TYPE(dbcsr_distribution_type) :: dist_template + CALL timeset(routineN, handle) + CALL dbcsr_get_info(matrix_template, distribution=dist_template, & row_blk_size=row_blk, col_blk_size=col_blk) - CALL dbcsr_distribution_get(dist_template, row_dist=row_dist, col_dist=col_dist) + CALL dbcsr_distribution_get(dist_template, row_dist=row_dist, col_dist=col_dist, & + nprows=nprows, npcols=npcols) IF (TRIM(dim_type) == 'ROW') THEN ! Creates ROW x ROW (e.g., Grid x Grid from mat_phi_mu_l) blk_sizes => row_blk - np = MAXVAL(col_dist) + 1 ! npcol + np = npcols ALLOCATE (mapped_dist(SIZE(blk_sizes))) DO i = 1, SIZE(blk_sizes) mapped_dist(i) = MOD(i - 1, np) @@ -2015,7 +2009,7 @@ CONTAINS ELSE IF (TRIM(dim_type) == 'COL') THEN ! Creates COL x COL (e.g., Aux x Aux from mat_Z_lP) blk_sizes => col_blk - np = MAXVAL(row_dist) + 1 ! nprow + np = nprows ALLOCATE (mapped_dist(SIZE(blk_sizes))) DO i = 1, SIZE(blk_sizes) mapped_dist(i) = MOD(i - 1, np) @@ -2024,6 +2018,8 @@ CONTAINS row_dist=mapped_dist, col_dist=col_dist) END IF + CALL timestop(handle) + END SUBROUTINE setup_square_topology ! ************************************************************************************************** @@ -2044,6 +2040,12 @@ CONTAINS POINTER :: mapped_dist TYPE(dbcsr_type), INTENT(INOUT), OPTIONAL :: m1, m2, m3, m4 + CHARACTER(LEN=*), PARAMETER :: routineN = 'release_dbcsr_topology_and_matrices' + + INTEGER :: handle + + CALL timeset(routineN, handle) + IF (PRESENT(dist)) CALL dbcsr_distribution_release(dist) IF (PRESENT(mapped_dist)) THEN IF (ASSOCIATED(mapped_dist)) THEN @@ -2056,6 +2058,8 @@ CONTAINS IF (PRESENT(m3)) CALL dbcsr_release(m3) IF (PRESENT(m4)) CALL dbcsr_release(m4) + CALL timestop(handle) + END SUBROUTINE release_dbcsr_topology_and_matrices END MODULE gw_large_cell_Gamma_ri_rs diff --git a/src/gw_non_periodic_ri_rs.F b/src/gw_non_periodic_ri_rs.F index 0cf7dfc5ef..40b9532453 100644 --- a/src/gw_non_periodic_ri_rs.F +++ b/src/gw_non_periodic_ri_rs.F @@ -10,82 +10,88 @@ !> \par History !> 04.2026 created [Ritaj Tyagi] ! ************************************************************************************************** + MODULE gw_non_periodic_ri_rs - USE atomic_kind_types, ONLY: atomic_kind_type,& - get_atomic_kind_set - USE basis_set_types, ONLY: gto_basis_set_type - USE cell_types, ONLY: cell_type,& - pbc - USE constants_operator, ONLY: operator_coulomb - USE cp_blacs_env, ONLY: cp_blacs_env_create,& - cp_blacs_env_release,& - cp_blacs_env_type - USE cp_dbcsr_api, ONLY: & - dbcsr_add, dbcsr_binary_read, dbcsr_binary_write, dbcsr_copy, dbcsr_create, & - dbcsr_deallocate_matrix, dbcsr_distribution_get, dbcsr_distribution_new, & - dbcsr_distribution_release, dbcsr_distribution_type, dbcsr_finalize, dbcsr_get_block_p, & - dbcsr_get_info, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & - dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, & - dbcsr_p_type, dbcsr_put_block, dbcsr_release, dbcsr_scale, dbcsr_set, dbcsr_type, & - dbcsr_type_no_symmetry - USE cp_dbcsr_contrib, ONLY: dbcsr_reserve_all_blocks - USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& - copy_fm_to_dbcsr,& - dbcsr_deallocate_matrix_set,& - max_elements_per_block - USE cp_files, ONLY: close_file,& - open_file - USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add,& - cp_fm_uplo_to_full - USE cp_fm_cholesky, ONLY: cp_fm_cholesky_decompose,& - cp_fm_cholesky_invert,& - cp_fm_cholesky_solve - USE cp_fm_diag, ONLY: cp_fm_power - USE cp_fm_struct, ONLY: cp_fm_struct_create,& - cp_fm_struct_release,& - cp_fm_struct_type - USE cp_fm_types, ONLY: cp_fm_create,& - cp_fm_get_info,& - cp_fm_get_submatrix,& - cp_fm_release,& - cp_fm_set_all,& - cp_fm_set_submatrix,& - cp_fm_to_fm,& - cp_fm_type - USE cp_log_handling, ONLY: cp_get_default_logger,& - cp_logger_type - USE cp_output_handling, ONLY: cp_p_file,& - cp_print_key_should_output - USE gw_integrals, ONLY: build_3c_integral_block_ctx,& - gw_3c_ctx_create,& - gw_3c_ctx_release,& - gw_3c_ctx_type,& - gw_3c_ws_create,& - gw_3c_ws_release,& - gw_3c_ws_type - USE gw_large_cell_gamma, ONLY: & - Fourier_transform_w_to_t, G_occ_vir, compute_QP_energies, compute_fm_chi_Gamma_freq, & - create_fm_W_MIC_time, delete_unnecessary_files, fill_fm_Sigma_c_Gamma_time, fm_write, & - multiply_fm_W_MIC_time_with_Minv_Gamma - USE gw_utils, ONLY: de_init_bs_env - USE input_constants, ONLY: rtp_method_bse - USE input_section_types, ONLY: section_vals_type - USE kinds, ONLY: default_path_length,& - default_string_length,& - dp - USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp - USE machine, ONLY: m_walltime - USE message_passing, ONLY: mp_para_env_type - USE mp2_ri_2c, ONLY: RI_2c_integral_mat - USE orbital_pointers, ONLY: indco,& - ncoset - USE parallel_gemm_api, ONLY: parallel_gemm - USE particle_types, ONLY: particle_type - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type - USE qs_environment_types, ONLY: get_qs_env,& - qs_environment_type - USE qs_kind_types, ONLY: get_qs_kind,& - qs_kind_type + USE atomic_kind_types, ONLY: atomic_kind_type, & + get_atomic_kind_set + USE basis_set_types, ONLY: gto_basis_set_type + USE cell_types, ONLY: cell_type, & + pbc + USE constants_operator, ONLY: operator_coulomb + USE cp_blacs_env, ONLY: cp_blacs_env_create, & + cp_blacs_env_release, & + cp_blacs_env_type + USE cp_dbcsr_api, ONLY: & + dbcsr_add, dbcsr_binary_read, dbcsr_binary_write, dbcsr_copy, dbcsr_create, & + dbcsr_deallocate_matrix, dbcsr_distribution_get, dbcsr_distribution_new, & + dbcsr_distribution_release, dbcsr_distribution_type, dbcsr_finalize, & + dbcsr_get_block_p, dbcsr_filter, dbcsr_get_data_size, dbcsr_get_info, & + dbcsr_get_occupation, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & + dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, & + dbcsr_p_type, dbcsr_put_block, dbcsr_release, dbcsr_scale, dbcsr_set, dbcsr_type, & + dbcsr_type_no_symmetry + USE cp_dbcsr_contrib, ONLY: dbcsr_reserve_all_blocks + USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm, & + copy_fm_to_dbcsr, & + dbcsr_deallocate_matrix_set, & + max_elements_per_block + USE cp_files, ONLY: close_file, & + open_file + USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add, & + cp_fm_uplo_to_full + USE cp_fm_cholesky, ONLY: cp_fm_cholesky_decompose, & + cp_fm_cholesky_invert, & + cp_fm_cholesky_solve + USE cp_fm_diag, ONLY: cp_fm_power + USE cp_fm_struct, ONLY: cp_fm_struct_create, & + cp_fm_struct_release, & + cp_fm_struct_type + USE cp_fm_types, ONLY: cp_fm_create, & + cp_fm_get_info, & + cp_fm_get_submatrix, & + cp_fm_release, & + cp_fm_set_all, & + cp_fm_set_submatrix, & + cp_fm_to_fm, & + cp_fm_type + USE cp_log_handling, ONLY: cp_get_default_logger, & + cp_logger_type + USE cp_output_handling, ONLY: cp_p_file, & + cp_print_key_should_output + USE gw_integrals, ONLY: build_3c_integral_block_ctx, & + gw_3c_ctx_create, & + gw_3c_ctx_release, & + gw_3c_ctx_type, & + gw_3c_ws_create, & + gw_3c_ws_release, & + gw_3c_ws_type + USE gw_large_cell_gamma, ONLY: & + Fourier_transform_w_to_t, G_occ_vir, compute_QP_energies, compute_fm_chi_Gamma_freq, & + create_fm_W_MIC_time, delete_unnecessary_files, fill_fm_Sigma_c_Gamma_time, fm_write, & + multiply_fm_W_MIC_time_with_Minv_Gamma + USE gw_utils, ONLY: de_init_bs_env + USE input_constants, ONLY: rtp_method_bse + USE input_section_types, ONLY: section_vals_type + USE kinds, ONLY: default_path_length, & + default_string_length, & + dp, int_4, int_8 + USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp + USE machine, ONLY: m_flush, m_hostnm, & + m_memory_details, m_walltime + USE message_passing, ONLY: mp_para_env_type + USE mp2_ri_2c, ONLY: RI_2c_integral_mat + USE orbital_pointers, ONLY: indco, & + ncoset + USE parallel_gemm_api, ONLY: parallel_gemm + USE particle_types, ONLY: particle_type + USE physcon, ONLY: angstrom + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE qs_environment_types, ONLY: get_qs_env, & + qs_environment_type + USE qs_kind_types, ONLY: get_qs_kind, & + qs_kind_type + USE util, ONLY: sort + #include "./base/base_uses.f90" IMPLICIT NONE @@ -94,6 +100,14 @@ MODULE gw_non_periodic_ri_rs CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_non_periodic_ri_rs' + ! DBCSR ships each ranks matrix panel in one MPI message whose length is stored in a + ! 32-bit default INTEGER (dbcsr_mpiwrap.F: msglen = SIZE(buffer)). Exceeding this ceiling + ! overflows the count to a negative/garbage value and multiply_cannon segfaults. This is + ! that hard limit in elements (= HUGE(int_4) = 2^31-1), the same bound DBCSR uses + ! internally as mp_max_memory_size. Panel sizing keeps every per-rank message below it. + + INTEGER(KIND=int_8), PARAMETER, PRIVATE :: dbcsr_msg_elem_limit = INT(HUGE(0_int_4), int_8) + PUBLIC :: gw_calc_non_periodic_ri_rs, ri_rs_grid_assembler, & get_basis_offsets, precompute_ri_rs_radii, solve_D_lp_distributed @@ -104,7 +118,6 @@ CONTAINS !> \param qs_env ... !> \param bs_env ... ! ************************************************************************************************** - SUBROUTINE gw_calc_non_periodic_ri_rs(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env @@ -118,94 +131,92 @@ CONTAINS CALL timeset(routineN, handle) - !!======================================================================== - !! 0. Precompute AO and RI Radii - !! Determine per-atom cutoff radii from the most diffuse Gaussian - !! primitives in the AO and RI auxiliary basis sets. - !! Equations: - !! a. α_min,ao = min_{i,j} { ζ_ao(i,j) | ζ_ao(i,j) > 10⁻³ } - !! b. α_min,ri = min_{i,j} { ζ_ri(i,j) | ζ_ri(i,j) > 10⁻³ } - !! c. r_ao = sqrt( -ln(ε) / α_min,ao ) (radius_ao_per_atom) - !! d. r_ri = sqrt( -ln(ε) / α_min,ri ) (radius_ri_per_atom) - !!======================================================================== + ! ======================================================================== + ! 0. Precompute AO and RI radii + ! Per-atom cutoff radii from the most diffuse Gaussian primitives of + ! the AO ("ORB") and RI auxiliary ("RI_AUX") basis sets: + ! α_min,ao = min { ζ_ao | ζ_ao > 10⁻³ }, α_min,ri analogous + ! r_ao = sqrt( -ln(ε) / α_min,ao ) (radius_ao_per_atom) + ! r_ri = sqrt( -ln(ε) / α_min,ri ) (radius_ri_per_atom) + ! ======================================================================== CALL precompute_ri_rs_radii(qs_env, bs_env) - !!======================================================================== - !! 1. Grid Generation for RI-RS - !! (Modified Lebedev grids from Ivan Duchemin and Xavier Blase) - !! Generate flattened 1D array of grid points for RI-RS. - !! Equation: r_g(k) = R_A + r_g(A) - !!======================================================================== + ! ======================================================================== + ! 1. Grid generation for RI-RS + ! Modified Lebedev atomic grids (Duchemin & Blase), one per atom, + ! concatenated into a flat global list: r_l = R_A + r_l^(A) + ! ======================================================================== CALL ri_rs_grid_assembler(qs_env, bs_env, bs_env%ri_rs%grid_points) - !!======================================================================== - !! 2. Atomic Basis Evaluation - !! Compute values of spherical atomic basis functions at grid points. - !! Expression: Φ_μl = Φ_μ(r_l) (mat_phi_mu_l) - !!======================================================================== + ! ======================================================================== + ! 2a. Atomic basis evaluation on the grid (grid x AO matrix) + ! Φ_μl = Φ_μ(r_l) (mat_phi_mu_l) + ! ======================================================================== CALL atomic_basis_at_grid_point(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l) - !!======================================================================== - !! 3. Compute RI-RS Coefficients (Z_lp) - !! Solve the regularized system for each atom P, where the grid domain - !! is restricted to r_l within a cutoff distance of atom P: - !! a. D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]^2 (Equation 13) - !! b. D_lP = Σ_{μν} Φ_μ(r_l) Φ_ν(r_l) (μν|P) (Equation 15) - !! c. Conditioning: - !! Dvec_l = 1 / sqrt(D_ll) (Diagonal scaling vector) - !! D'_ll' = Dvec_l * D_ll' * Dvec_l' + λδ_ll' - !! D'_lP = Dvec_l * D_lP - !! d. Solve: Σ_l' D'_ll' * Z'_l'P = D'_lP (Equation 14) - !! e. Rescale: Z_lP = Z'_lP * Dvec_l (Z_lP stored in mat_Z_lP) - !!======================================================================== + ! ======================================================================== + ! 2b. Print the memory estimate for the RI-RS calculation + ! ======================================================================== + CALL print_ri_rs_memory_estimate(qs_env, bs_env) + + ! ======================================================================== + ! 3. RI-RS fitting coefficients Z_lP (grid x RI matrix) + ! Per-atom regularized solve, restricted to grid points r_l within a + ! cutoff distance of atom P: + ! a. D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]² + ! b. D_lP = Σ_μν Φ_μ(r_l) Φ_ν(r_l) (μν|P) + ! c. Jacobi conditioning with d_l = 1/sqrt(D_ll): + ! D'_ll' = d_l D_ll' d_l' + λδ_ll' , D'_lP = d_l D_lP + ! d. Solve Σ_l' D'_ll' Z'_l'P = D'_lP + ! e. Rescale Z_lP = d_l Z'_lP (mat_Z_lP) + ! ======================================================================== CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) - !!======================================================================== - !! 4. Compute Independent-Particle Polarizability (χ) - !! G^occ_µλ(i|τ|) = sum_n^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - !! G^vir_µλ(i|τ|) = sum_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - !! G^occ_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') - !! G^vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^vir_µν Φ_ν(r_l') - !! χ_ll'(iτ) = G^occ_ll'(i|τ|) * G^vir_ll'(i|τ|) - !! χ_PQ(iτ) = sum_ll' Z_lP χ_ll'(iτ) Z_l'Q - !!======================================================================== + ! ======================================================================== + ! 4. Polarizability matrix χ on the imaginary-time grid + ! G^occ_µλ(i|τ|) = Σ_n^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + ! G^vir_µλ(i|τ|) = Σ_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + ! G^occ_ll'(i|τ|) = Σ_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') (G^vir analogous) + ! χ_ll'(iτ) = G^occ_ll'(i|τ|) ∘ G^vir_ll'(i|τ|) (element-wise) + ! χ_PQ(iτ) = Σ_ll' Z_lP χ_ll'(iτ) Z_l'Q + ! ======================================================================== CALL get_mat_chi_Gamma_tau(bs_env, bs_env%mat_chi_Gamma_tau, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) - !!======================================================================== - !! 5. Compute Screened Interaction (W) - !! χ_PQ(iτ) -> χ_PQ(iω) -> ε_PQ(iω) -> W_PQ(iω) -> W_PQ(iτ) - !!======================================================================== + ! ======================================================================== + ! 5. Screened Coulomb interaction W (RI basis) + ! χ_PQ(iτ) -> χ_PQ(iω) -> ε_PQ(iω) -> W_PQ(iω) -> W_PQ(iτ) + ! ======================================================================== CALL compute_W(bs_env, qs_env, bs_env%mat_chi_Gamma_tau, fm_W_time) - !!======================================================================== - !! 6. Compute Exact Exchange Self-Energy (Σ^x) - !! D_µν = sum_n^occ C_µn C_νn - !! D_ll' = sum_µν Φ_µ(r_l) D_µν Φ_ν(r_l') - !! V^trunc_ll' = sum_PQ Z_lP V^trunc_PQ Z_l'Q - !! Σ^x_ll' = D_ll' * V^trunc_ll' - !! Σ^x_λσ(k=0) = -sum_ll' Φ_λ(r_l) Σ^x_ll' Φ_σ(r_l') - !!======================================================================== + ! ======================================================================== + ! 6. Exact-exchange self-energy Σ^x + ! D_µν = Σ_n^occ C_µn C_νn (density matrix) + ! D_ll' = Σ_µν Φ_µ(r_l) D_µν Φ_ν(r_l') + ! V^tr_ll' = Σ_PQ Z_lP V^tr_PQ Z_l'Q (truncated Coulomb) + ! Σ^x_ll' = D_ll' ∘ V^tr_ll' + ! Σ^x_λσ(k=0) = -Σ_ll' Φ_λ(r_l) Σ^x_ll' Φ_σ(r_l') + ! ======================================================================== CALL compute_Sigma_x(bs_env, qs_env, bs_env%ri_rs%mat_phi_mu_l, & bs_env%ri_rs%mat_Z_lP, fm_Sigma_x_Gamma) - !!======================================================================== - !! 7. Compute Correlation Self-Energy (Σ^c) - !! W_ll'(iτ) = sum_PQ Z_lP W^MIC_PQ(iτ) Z_l'Q - !! Σ^c_ll'(iτ) = -G^occ_ll'(i|τ|) * W_ll'(iτ), for τ < 0 - !! Σ^c_ll'(iτ) = G^vir_ll'(i|τ|) * W_ll'(iτ), for τ > 0 - !! Σ^c_λσ(iτ) = sum_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l') - !!======================================================================== + ! ======================================================================== + ! 7. Correlation self-energy Σ^c on the imaginary-time grid + ! W_ll'(iτ) = Σ_PQ Z_lP W^MIC_PQ(iτ) Z_l'Q + ! Σ^c_ll'(iτ) = -G^occ_ll'(i|τ|) ∘ W_ll'(iτ), τ < 0 + ! Σ^c_ll'(iτ) = G^vir_ll'(i|τ|) ∘ W_ll'(iτ), τ > 0 + ! Σ^c_λσ(iτ) = Σ_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l') + ! ======================================================================== CALL compute_Sigma_c(bs_env, fm_W_time, bs_env%ri_rs%mat_phi_mu_l, & bs_env%ri_rs%mat_Z_lP, fm_Sigma_c_Gamma_time) - !!======================================================================== - !! 8. Compute Quasiparticle Energies - !! Σ^c_λσ(iτ) -> Σ^c_nn(ϵ) - !! ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ) + Σ^x_nn - v^xc_nn - !!======================================================================== + ! ======================================================================== + ! 8. Quasiparticle energies (analytic continuation iτ -> iω -> real ϵ) + ! Σ^c_λσ(iτ) -> Σ^c_nn(ϵ) + ! ϵ_n^GW = ϵ_n^DFT + Σ^c_nn(ϵ_n^GW) + Σ^x_nn - v^xc_nn + ! ======================================================================== CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) CALL de_init_bs_env(bs_env) @@ -224,7 +235,6 @@ CONTAINS !> \param qs_env ... !> \param bs_env ... ! ************************************************************************************************** - SUBROUTINE precompute_ri_rs_radii(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env @@ -258,14 +268,14 @@ CONTAINS DO i = 1, SIZE(zet_ao, 1) DO j = 1, SIZE(zet_ao, 2) - IF (zet_ao(i, j) > 1.0E-3_dp) THEN + IF (zet_ao(i, j) > 1.0E-3_dp) then alpha_min_ao_kind(ikind) = MIN(alpha_min_ao_kind(ikind), zet_ao(i, j)) END IF END DO END DO DO i = 1, SIZE(zet_ri, 1) DO j = 1, SIZE(zet_ri, 2) - IF (zet_ri(i, j) > 1.0E-3_dp) THEN + IF (zet_ri(i, j) > 1.0E-3_dp) then alpha_min_ri_kind(ikind) = MIN(alpha_min_ri_kind(ikind), zet_ri(i, j)) END IF END DO @@ -283,14 +293,14 @@ CONTAINS END DO IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind RI-RS basis radii (Bohr):' - WRITE (bs_env%unit_nr, '(T4,A6,2X,A4,2A14)') 'Kind', 'Elem', 'r_AO', 'r_RI' + WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind RI-RS basis radii (Å):' + WRITE (bs_env%unit_nr, '(T4,A6,2X,A4,2A14)') 'Kind', 'Elem', 'r_AO (Å)', 'r_RI (Å)' DO ikind = 1, nkind WRITE (bs_env%unit_nr, '(T4,I6,2X,A4,2F14.4)') & ikind, & atomic_kind_set(ikind)%element_symbol, & - SQRT(-LOG(eps)/alpha_min_ao_kind(ikind)), & - SQRT(-LOG(eps)/alpha_min_ri_kind(ikind)) + SQRT(-LOG(eps)/alpha_min_ao_kind(ikind))*angstrom, & + SQRT(-LOG(eps)/alpha_min_ri_kind(ikind))*angstrom END DO WRITE (bs_env%unit_nr, '(A)') ' ' END IF @@ -301,6 +311,86 @@ CONTAINS END SUBROUTINE precompute_ri_rs_radii +! ************************************************************************************************** +!> \brief Spreads the low 21 bits of a into every third bit (bits 0,3,6,...,60): the 1-D helper +!> for a 3-D Morton (Z-order) code. Standard 64-bit magic-mask implementation. +!> \param a value in [0, 2^21) +!> \param x a with two zero bits inserted between consecutive input bits +! ************************************************************************************************** + SUBROUTINE morton_split3(a, x) + INTEGER(KIND=int_8), INTENT(IN) :: a + INTEGER(KIND=int_8), INTENT(OUT) :: x + + x = IAND(a, INT(z'1FFFFF', int_8)) + x = IAND(IOR(x, ISHFT(x, 32)), INT(z'1F00000000FFFF', int_8)) + x = IAND(IOR(x, ISHFT(x, 16)), INT(z'1F0000FF0000FF', int_8)) + x = IAND(IOR(x, ISHFT(x, 8)), INT(z'100F00F00F00F00F', int_8)) + x = IAND(IOR(x, ISHFT(x, 4)), INT(z'10C30C30C30C30C3', int_8)) + x = IAND(IOR(x, ISHFT(x, 2)), INT(z'1249249249249249', int_8)) + END SUBROUTINE morton_split3 + +! ************************************************************************************************** +!> \brief Returns a permutation of atom indices in Morton (Z-order) space-filling order of their +!> Cartesian centers, so consecutive atoms are spatial neighbors. The RI-RS grid rows are +!> laid down in this order, so a contiguous grid panel maps to a compact spatial region and +!> the CUTOFF_RADIUS_RL_W neighborhood of every panel shrinks. The grid row index +!> is a summed contraction index, so ANY permutation is result-preserving; this one is +!> chosen purely to improve locality. Coordinates are normalized to the atom bounding box +!> and quantized to 21 bits per axis (sub-picometre for any real cell). +!> \param particle_set ... +!> \param order order(i) = atom index placed at layout position i +! ************************************************************************************************** + SUBROUTINE spatial_atom_order(particle_set, order) + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: order + + CHARACTER(LEN=*), PARAMETER :: routineN = 'spatial_atom_order' + INTEGER, PARAMETER :: nbits = 21 + + INTEGER :: handle, ia, k, natom + INTEGER(KIND=int_8) :: cmax, ic(3), m1, m2, m3 + INTEGER(KIND=int_8), ALLOCATABLE :: mcode(:) + REAL(KIND=dp) :: hi(3), lo(3), span(3) + + CALL timeset(routineN, handle) + + natom = SIZE(particle_set) + ALLOCATE (order(natom), mcode(natom)) + cmax = ISHFT(1_int_8, nbits) - 1_int_8 + + lo(:) = HUGE(1.0_dp) + hi(:) = -HUGE(1.0_dp) + DO ia = 1, natom + DO k = 1, 3 + lo(k) = MIN(lo(k), particle_set(ia)%r(k)) + hi(k) = MAX(hi(k), particle_set(ia)%r(k)) + END DO + END DO + span(:) = hi(:) - lo(:) + DO k = 1, 3 + IF (span(k) <= 0.0_dp) span(k) = 1.0_dp + END DO + + DO ia = 1, natom + DO k = 1, 3 + ic(k) = INT(((particle_set(ia)%r(k) - lo(k))/span(k))*REAL(cmax, dp), int_8) + ic(k) = MIN(cmax, MAX(0_int_8, ic(k))) + END DO + CALL morton_split3(ic(1), m1) + CALL morton_split3(ic(2), m2) + CALL morton_split3(ic(3), m3) + mcode(ia) = IOR(IOR(m1, ISHFT(m2, 1)), ISHFT(m3, 2)) + END DO + + ! sort(mcode, natom, order): order(i) = original atom index with the i-th smallest code + CALL sort(mcode, natom, order) + + DEALLOCATE (mcode) + + CALL timestop(handle) + + END SUBROUTINE spatial_atom_order + ! ************************************************************************************************** !> \brief Compute grid points for RI-RS !> Right now based on Ivan and Xavier implementation @@ -309,7 +399,6 @@ CONTAINS !> \param bs_env ... !> \param ri_rs_grid_points ... ! ************************************************************************************************** - SUBROUTINE ri_rs_grid_assembler(qs_env, bs_env, ri_rs_grid_points) TYPE(qs_environment_type), POINTER :: qs_env @@ -318,10 +407,11 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'ri_rs_grid_assembler' - INTEGER :: atom_idx, end_idx, handle, ikind, j, & - natom, nkind, start_idx, & + INTEGER :: atom_idx, end_idx, handle, i_layout, & + ikind, j, natom, nkind, start_idx, & total_grid_npts - INTEGER, ALLOCATABLE :: atom_to_kind(:), ri_rs_grid_offsets(:) + INTEGER, ALLOCATABLE :: atom_order(:), atom_to_kind(:), & + ri_rs_grid_offsets(:) REAL(KIND=dp) :: atomic_center(3) TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(particle_type), DIMENSION(:), POINTER :: particle_set @@ -341,17 +431,37 @@ CONTAINS ALLOCATE (ri_rs_grid_offsets(natom + 1)) ALLOCATE (atom_to_kind(natom)) - total_grid_npts = 0 + ! grid_atom_boundaries(k) = 1-based start of the k-th atom's grid run in LAYOUT order + ! (the order in which the points are laid down below). Used later to build atom-aligned + ! DBCSR grid row-blocks in atomic_basis_at_grid_point. + IF (ALLOCATED(bs_env%ri_rs%grid_atom_boundaries)) DEALLOCATE (bs_env%ri_rs%grid_atom_boundaries) + ALLOCATE (bs_env%ri_rs%grid_atom_boundaries(natom + 1)) + + ! atom -> kind map (needed before the spatial layout loop, which visits atoms in a + ! kind-independent order). DO ikind = 1, nkind DO j = 1, SIZE(atomic_kind_set(ikind)%atom_list) - atom_idx = atomic_kind_set(ikind)%atom_list(j) - atom_to_kind(atom_idx) = ikind - ri_rs_grid_offsets(atom_idx) = total_grid_npts + 1 - total_grid_npts = total_grid_npts + bs_env%ri_rs%grid_cache(ikind)%npts + atom_to_kind(atomic_kind_set(ikind)%atom_list(j)) = ikind END DO END DO + ! Lay the grid rows down in Morton (spatial) atom order rather than kind-major, so a + ! contiguous grid panel maps to a compact spatial region and the CUTOFF_RADIUS_RL_W + ! neighborhood width of every panel shrinks. The grid row index is summed over in χ/Σ, + ! so this reordering is result-preserving (see spatial_atom_order). + CALL spatial_atom_order(particle_set, atom_order) + + total_grid_npts = 0 + DO i_layout = 1, natom + atom_idx = atom_order(i_layout) + ikind = atom_to_kind(atom_idx) + ri_rs_grid_offsets(atom_idx) = total_grid_npts + 1 + bs_env%ri_rs%grid_atom_boundaries(i_layout) = total_grid_npts + 1 + total_grid_npts = total_grid_npts + bs_env%ri_rs%grid_cache(ikind)%npts + END DO + ri_rs_grid_offsets(natom + 1) = total_grid_npts + 1 + bs_env%ri_rs%grid_atom_boundaries(natom + 1) = total_grid_npts + 1 IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, FMT="(T2,A,T69,I12)") & @@ -375,7 +485,7 @@ CONTAINS start_idx = ri_rs_grid_offsets(atom_idx) end_idx = start_idx + bs_env%ri_rs%grid_cache(ikind)%npts - 1 - !! Shift the cached origin grid by the atom's center + !! Shift the cached origin grid by the atom's center ri_rs_grid_points(1, start_idx:end_idx) = bs_env%ri_rs%grid_cache(ikind)%raw_points(1, :) + atomic_center(1) ri_rs_grid_points(2, start_idx:end_idx) = bs_env%ri_rs%grid_cache(ikind)%raw_points(2, :) + atomic_center(2) ri_rs_grid_points(3, start_idx:end_idx) = bs_env%ri_rs%grid_cache(ikind)%raw_points(3, :) + atomic_center(3) @@ -391,7 +501,8 @@ CONTAINS DEALLOCATE (bs_env%ri_rs%grid_cache) END IF - DEALLOCATE (atom_to_kind, ri_rs_grid_offsets) + DEALLOCATE (atom_order, atom_to_kind, ri_rs_grid_offsets) + CALL timestop(handle) END SUBROUTINE ri_rs_grid_assembler @@ -401,17 +512,21 @@ CONTAINS !> \param bs_env ... !> \param atomic_kind_set ... ! ************************************************************************************************** - SUBROUTINE build_grid_cache(bs_env, atomic_kind_set) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_grid_cache' + CHARACTER(LEN=default_path_length) :: filename, full_path, line CHARACTER(LEN=default_string_length) :: atom_sym, suffix - INTEGER :: colon_idx, i, ierr, ikind, iunit, nkind + INTEGER :: colon_idx, handle, i, ierr, ikind, & + iunit, nkind REAL(KIND=dp) :: pt(3) + CALL timeset(routineN, handle) + ! Determine the file suffix based on the user's choice IF (bs_env%ri_rs%grid_select == 1) THEN suffix = "_def2-tzvp-rs.ion" @@ -467,16 +582,25 @@ CONTAINS CALL close_file(unit_number=iunit) END DO + CALL timestop(handle) + END SUBROUTINE build_grid_cache ! ************************************************************************************************** -!> \brief Evaluates atomic basis functions on a real-space grid and builds a sparse DBCSR matrix. +!> \brief Evaluates the AO basis on the RI-RS grid and stores it as the sparse DBCSR matrix +!> Φ_μl = Φ_μ(r_l) (rows = grid points in atom-aligned blocks of at most +!> max_elements_per_block points, columns = one block per atom's full AO set). +!> Grid points outside the reach of an atom's most +!> diffuse Gaussian (or the CUTOFF_RADIUS_RL_AO) are skipped, and only blocks +!> with at least one element > eps_filter are stored. This locality is the source of +!> ALL grid-dimension sparsity used downstream. Also caches the atom centers and the +!> per-chunk centroids needed by the optional CUTOFF_RADIUS_G_W / CUTOFF_RADIUS_RL_W +!> operator truncations. !> \param qs_env ... !> \param bs_env ... !> \param ri_rs_grid_points ... !> \param mat_phi_mu_l ... ! ************************************************************************************************** - SUBROUTINE atomic_basis_at_grid_point(qs_env, bs_env, ri_rs_grid_points, mat_phi_mu_l) TYPE(qs_environment_type), POINTER :: qs_env @@ -486,11 +610,12 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'atomic_basis_at_grid_point' - INTEGER :: c_size, chunk_size, dimen_ORB, handle, i, i_blk, iatom, natom, npcol, nprow, & - num_grid_chunks, r_end, r_start, total_grid_npts - INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf - INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, col_dist_ks, & - r_blk_sizes, row_dist, row_dist_ks + INTEGER :: bs_eff, c_size, dimen_ORB, handle, i, i_blk, ia, iatom, natom, npcol, nprow, & + num_grid_chunks, r_end, r_start, remaining, run, safe_max, total_grid_npts + INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_row_start, first_sgf + INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, & + r_blk_sizes, row_dist + REAL(KIND=dp) :: r2_threshold REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: atom_col_buffer TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell @@ -502,8 +627,6 @@ CONTAINS CALL timeset(routineN, handle) - chunk_size = max_elements_per_block - ! Extract environment variables CALL get_qs_env(qs_env, cell=cell, atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set, particle_set=particle_set, & @@ -526,22 +649,71 @@ CONTAINS c_blk_sizes(iatom) = first_sgf(iatom + 1) - first_sgf(iatom) END DO - ! B. Define Row Block Sizes (Grid chunks of max size 256) - num_grid_chunks = CEILING(REAL(total_grid_npts, KIND=dp)/REAL(chunk_size, KIND=dp)) - ALLOCATE (r_blk_sizes(num_grid_chunks)) - r_blk_sizes = chunk_size - IF (MOD(total_grid_npts, chunk_size) /= 0) THEN - r_blk_sizes(num_grid_chunks) = MOD(total_grid_npts, chunk_size) + ! B. Define Row Block Sizes: atom-aligned blocks (a block never spans two atoms' grid + ! runs), each atom's run subdivided into blocks of at most bs_eff points. + + ! Fetch CP2K's default process grid configuration + CALL get_qs_env(qs_env, dbcsr_dist=dbcsr_dist_ks) + CALL dbcsr_distribution_get(dbcsr_dist_ks, nprows=nprow, npcols=npcol) + + ! Overflow-safe upper bound on the block size (see dbcsr_msg_elem_limit). + safe_max = INT(0.5_dp*REAL(dbcsr_msg_elem_limit, dp)*REAL(MAX(MIN(nprow, npcol), 1), dp)/ & + REAL(total_grid_npts, dp)) + safe_max = MAX(1, safe_max) + ! Block size = CP2K's global max_elements_per_block (GLOBAL/DBCSR input; default 32), + ! overflow-capped. + bs_eff = MAX(1, MIN(max_elements_per_block, safe_max)) + + ! Count the atom-aligned blocks, then fill r_blk_sizes and each block's starting grid row. + num_grid_chunks = 0 + DO ia = 1, natom + run = bs_env%ri_rs%grid_atom_boundaries(ia + 1) - bs_env%ri_rs%grid_atom_boundaries(ia) + IF (run > 0) num_grid_chunks = num_grid_chunks + (run + bs_eff - 1)/bs_eff + END DO + ALLOCATE (r_blk_sizes(num_grid_chunks), blk_row_start(num_grid_chunks)) + i_blk = 0 + r_start = 1 + DO ia = 1, natom + remaining = bs_env%ri_rs%grid_atom_boundaries(ia + 1) - bs_env%ri_rs%grid_atom_boundaries(ia) + DO WHILE (remaining > 0) + i_blk = i_blk + 1 + r_blk_sizes(i_blk) = MIN(bs_eff, remaining) + blk_row_start(i_blk) = r_start + r_start = r_start + r_blk_sizes(i_blk) + remaining = remaining - r_blk_sizes(i_blk) + END DO + END DO + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T69,I12)') 'RI-RS grid row-blocks of phi(mu,l)', num_grid_chunks + WRITE (bs_env%unit_nr, '(T2,A,T69,I12)') 'RI-RS grid points per block (max)', bs_eff END IF - ! C. Fetch CP2K's Default Process Grid Configuration - CALL get_qs_env(qs_env, dbcsr_dist=dbcsr_dist_ks) - CALL dbcsr_distribution_get(dbcsr_dist_ks, row_dist=row_dist_ks, col_dist=col_dist_ks) + ! Cache atomic positions: AO and RI blocks are one-block-per-atom, so these are the + ! block centers used by the optional CUTOFF_RADIUS_G_W atom-pair truncation. + IF (ALLOCATED(bs_env%ri_rs%atom_centers)) DEALLOCATE (bs_env%ri_rs%atom_centers) + ALLOCATE (bs_env%ri_rs%atom_centers(3, natom)) + DO iatom = 1, natom + bs_env%ri_rs%atom_centers(1:3, iatom) = particle_set(iatom)%r(1:3) + END DO - ! D. Build Custom Mappings using Round-Robin across the 2D process grid - ! (MAXVAL + 1 accounts for 0-based process indexing in DBCSR) - nprow = MAXVAL(row_dist_ks) + 1 - npcol = MAXVAL(col_dist_ks) + 1 + ! Cache per-chunk centroids for the optional CUTOFF_RADIUS_RL_W block truncation. + IF (bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp) THEN + IF (ALLOCATED(bs_env%ri_rs%chunk_centroids)) DEALLOCATE (bs_env%ri_rs%chunk_centroids) + ALLOCATE (bs_env%ri_rs%chunk_centroids(3, num_grid_chunks)) + DO i_blk = 1, num_grid_chunks + r_start = blk_row_start(i_blk) + r_end = r_start + r_blk_sizes(i_blk) - 1 + bs_env%ri_rs%chunk_centroids(1, i_blk) = & + SUM(ri_rs_grid_points(1, r_start:r_end))/REAL(r_blk_sizes(i_blk), dp) + bs_env%ri_rs%chunk_centroids(2, i_blk) = & + SUM(ri_rs_grid_points(2, r_start:r_end))/REAL(r_blk_sizes(i_blk), dp) + bs_env%ri_rs%chunk_centroids(3, i_blk) = & + SUM(ri_rs_grid_points(3, r_start:r_end))/REAL(r_blk_sizes(i_blk), dp) + END DO + END IF + + ! C. Build Custom Mappings using Round-Robin across the 2D process grid ALLOCATE (row_dist(num_grid_chunks)) DO i = 1, num_grid_chunks @@ -575,15 +747,20 @@ CONTAINS ! Evaluate the basis functions on the grid. Skip grid points outside ! the spatial extent of the most diffuse AO Gaussian on iatom; beyond - ! that radius the contribution is guaranteed below eps_filter. + ! that radius the contribution is guaranteed below eps_filter. A positive + ! CUTOFF_RADIUS_RL_AO overrides this with a user-defined hard cutoff. + IF (bs_env%ri_rs%cutoff_radius_ri_ao > 0.0_dp) THEN + r2_threshold = bs_env%ri_rs%cutoff_radius_ri_ao**2 + ELSE + r2_threshold = bs_env%ri_rs%radius_ao_per_atom(iatom)**2 + END IF CALL fill_phi_for_atom(atom_col_buffer, ri_rs_grid_points, total_grid_npts, & - iatom, particle_set, qs_kind_set, cell, & - bs_env%ri_rs%radius_ao_per_atom(iatom)**2) + iatom, particle_set, qs_kind_set, cell, r2_threshold) - ! Slice the dense column into chunks and insert into DBCSR + ! Slice the dense column into the atom-aligned grid row-blocks and insert into DBCSR DO i_blk = 1, num_grid_chunks - r_start = (i_blk - 1)*chunk_size + 1 - r_end = MIN(i_blk*chunk_size, total_grid_npts) + r_start = blk_row_start(i_blk) + r_end = r_start + r_blk_sizes(i_blk) - 1 ! Apply dynamic sparsity filtering: Only store blocks with physical significance IF (MAXVAL(ABS(atom_col_buffer(r_start:r_end, 1:c_size))) > bs_env%eps_filter) THEN @@ -596,13 +773,14 @@ CONTAINS END DO - ! Finalize triggers internal MPI communication to route blocks to their correct 2D process owners CALL dbcsr_finalize(mat_phi_mu_l) + CALL print_matrix_occupation(mat_phi_mu_l, 'φ(μ,l)', para_env, bs_env%unit_nr) + ! ------------------------------------------------------------------------- ! CLEANUP ! ------------------------------------------------------------------------- - DEALLOCATE (first_sgf, r_blk_sizes, c_blk_sizes, row_dist, col_dist) + DEALLOCATE (first_sgf, r_blk_sizes, c_blk_sizes, row_dist, col_dist, blk_row_start) CALL dbcsr_distribution_release(dist) CALL timestop(handle) @@ -610,7 +788,13 @@ CONTAINS END SUBROUTINE atomic_basis_at_grid_point ! ************************************************************************************************** -!> \brief Compute value of all basis function for single atom across all grid points +!> \brief Evaluates all spherical AO basis functions of one atom on a set of grid points and +!> ACCUMULATES them into phi_val (+=). For each point within the cutoff radius, +!> Φ_μ(r) = Σ_pgf Σ_cart sphi(cart,μ) · (x-X_A)^lx (y-Y_A)^ly (z-Z_A)^lz · e^(-ζ_pgf |r-R_A|²) +!> i.e. contracted Cartesian Gaussians transformed to the spherical basis via the sphi +!> coefficients. Distances are minimum-image wrapped (pbc); points with +!> |r - R_A|² > r2_threshold are skipped since every primitive is below eps there. +!> OMP-parallel over grid points. !> \param phi_val ... !> \param ri_rs_grid ... !> \param npts ... @@ -620,7 +804,6 @@ CONTAINS !> \param cell ... !> \param r2_threshold ... ! ************************************************************************************************** - SUBROUTINE fill_phi_for_atom(phi_val, ri_rs_grid, npts, iatom, & particle_set, qs_kind_set, cell, r2_threshold) @@ -633,18 +816,25 @@ CONTAINS TYPE(cell_type), POINTER :: cell REAL(KIND=dp), INTENT(IN) :: r2_threshold - INTEGER :: first_sgf, i_pt, ico, iend_co, ikind, & - ipgf, iset, isgf, ishell, istart_co, & - l, last_sgf, lx, ly, lz, n_cart_total, & - row_idx + CHARACTER(LEN=*), PARAMETER :: routineN = 'fill_phi_for_atom' + + INTEGER :: first_sgf, handle, i_pt, ico, iend_co, & + ikind, ipgf, iset, isgf, ishell, & + istart_co, l, last_sgf, lx, ly, lz, & + n_cart_total, row_idx REAL(KIND=dp) :: alpha, dist_vec(3), exp_val, poly, r2, & r_atom(3), weight TYPE(gto_basis_set_type), POINTER :: orb_basis_set + CALL timeset(routineN, handle) + ! Get Atom Info ikind = particle_set(iatom)%atomic_kind%kind_number CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type="ORB") - IF (.NOT. ASSOCIATED(orb_basis_set)) RETURN + IF (.NOT. ASSOCIATED(orb_basis_set)) THEN + CALL timestop(handle) + RETURN + END IF r_atom = particle_set(iatom)%r @@ -694,16 +884,19 @@ CONTAINS END DO !$OMP END PARALLEL DO + CALL timestop(handle) + END SUBROUTINE fill_phi_for_atom ! ************************************************************************************************** -!> \brief Helper for OMP threads to fill phi_val column values +!> \brief Computes the AO basis offsets: first_sgf(iatom) is the global index of the first +!> spherical Gaussian function (SGF) of iatom, first_sgf(natom+1) = total_sgf + 1, +!> and total_sgf is the total number of AO basis functions. !> \param particle_set ... !> \param qs_kind_set ... !> \param first_sgf ... !> \param total_sgf ... ! ************************************************************************************************** - SUBROUTINE get_basis_offsets(particle_set, qs_kind_set, first_sgf, total_sgf) TYPE(particle_type), DIMENSION(:), POINTER :: particle_set @@ -730,17 +923,29 @@ CONTAINS END SUBROUTINE get_basis_offsets ! ************************************************************************************************** -!> \brief Compute RI-RS Coefficients (Z_lP) +!> \brief Computes the RI-RS fitting coefficients Z_lP by solving, independently for every RI +!> atom P, a Jacobi-conditioned, Tikhonov-regularized linear system restricted to the +!> grid points r_l inside P's integration sphere |r_l - R_P| <= cutoff_ri(P): +!> D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]² (squared grid Gram matrix, Eq. 13) +!> D_lP = Σ_μν Φ_μ(r_l) Φ_ν(r_l) (μν|P) (grid-RI right-hand side, Eq. 15) +!> d_l = 1 / sqrt(D_ll) (Jacobi conditioning vector) +!> D'_ll' = d_l D_ll' d_l' + λ δ_ll' (λ = TIKHONOV_SIGMA regularization) +!> Σ_l' D'_ll' Z'_l'P = d_l D_lP (Cholesky solve, Eq. 14) +!> Z_lP = d_l Z'_l'P (undo the conditioning) +!> Work is distributed over atoms in two phases (planned by classify_z_lp_atoms and +!> lpt_assign_atoms): Phase A solves "small" atoms with single-rank LAPACK +!> (dpotrf/dpotrs); Phase B solves "big" atoms, whose dense Gram matrix would exceed one +!> rank's memory, with ScaLAPACK (pdpotrf/pdpotrs) over rank subgroups of size G. +!> The solved Z columns are scattered into the sparse global mat_Z_lP. +!> If a Z_lP restart file exists, it is read instead and the solve is skipped entirely. !> \param qs_env ... !> \param bs_env ... !> \param ri_rs_grid_points ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... ! ************************************************************************************************** - SUBROUTINE compute_coeff_Z_lP(qs_env, bs_env, ri_rs_grid_points, mat_phi_mu_l, mat_Z_lP) - ! Arguments TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env REAL(KIND=dp), ALLOCATABLE, INTENT(INOUT) :: ri_rs_grid_points(:, :) @@ -748,23 +953,21 @@ CONTAINS TYPE(dbcsr_type), INTENT(OUT) :: mat_Z_lP CHARACTER(LEN=*), PARAMETER :: key = 'PROPERTIES%BANDSTRUCTURE%GW%PRINT%RESTART', & - routineN = 'compute_coeff_Z_lP' + routineN = 'compute_coeff_Z_lP' - INTEGER :: atom_j_mepos, atom_j_stride, atom_P, atom_P_start, atom_P_stride, col_end, & - col_start, current_chunk_size, g, group_handle, handle, i, i_blk, ikind, info, j, j_ri, & - l, loc_idx, loc_ptr, max_ao_size, max_loc_ri, my_group, n_ao_total, n_grid_total, & - n_groups, n_loc_ri, n_local_grid, n_procs_per_atom, natom, nkind, num_grid_chunks, & - P_loop_atom, r_end, r_start, source_atom - INTEGER, ALLOCATABLE, DIMENSION(:) :: local_grid_idx, row_offset - INTEGER, DIMENSION(:), POINTER :: col_dist_phi, col_dist_ri, r_blk_sizes, & + INTEGER :: atom_j_mepos, atom_j_stride, atom_P, G, handle, handle_dpotrf, handle_dpotrs, & + i_blk, idx, info, iphase, j, max_ao_size, my_group, n_ao_total, n_big, n_done, & + n_groups, n_loc_ri, n_local_grid, n_my_atoms, n_small, natom, next_pct, & + npcol_phi, num_grid_chunks, P_loop_atom, phase_hi + INTEGER, ALLOCATABLE, DIMENSION(:) :: big_list, local_grid_idx, & + my_atoms_A, my_atoms_B, & + n_local_grid_atom, row_offset, small_list + INTEGER, DIMENSION(:), POINTER :: col_dist_ri, r_blk_sizes, & ri_blk_sizes, row_dist_grid - REAL(KIND=dp) :: cutoff_ri, d_sP, dist, r2_threshold, & - r_c, t1 - REAL(KIND=dp), ALLOCATABLE :: cutoff_ri_per_kind(:) + LOGICAL :: do_scatter, use_dist + REAL(KIND=dp) :: balance_A, balance_B, cutoff_ri, r_c, t1 REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cutoff_ri_per_atom, d_vec_local - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: D_local, d_lp_local, phi_local, & - sphere_grid, Z_blk - REAL(KIND=dp), DIMENSION(3) :: pos_P + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: D_local, d_lp_local, phi_local TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub @@ -785,44 +988,18 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env, particle_set=particle_set, input=input, & qs_kind_set=qs_kind_set, cell=cell, atomic_kind_set=atomic_kind_set) - ! --------------------------------------------------------------------- - ! Subgroup setup. Default G=1 keeps the single-rank BLAS path; G>1 splits - ! ranks into atom-groups so the Cholesky on D_local distributes across G - ! ranks (memory ~1/G) and the compute_d_lp build also splits across the - ! subgroup. G=1 leaves para_env_sub / blacs_env_sub NULL — no subgroup - ! comms created, atom_P loop uses per-rank round-robin, compute_d_lp runs - ! its full atom_j range on each rank, no allreduce. - ! --------------------------------------------------------------------- - n_procs_per_atom = MIN(bs_env%ri_rs%n_procs_per_atom_z_lp, para_env%num_pe) - IF (n_procs_per_atom < 1) n_procs_per_atom = 1 - NULLIFY (para_env_sub, blacs_env_sub) - IF (n_procs_per_atom > 1) THEN - n_groups = para_env%num_pe/n_procs_per_atom - my_group = MIN(para_env%mepos/n_procs_per_atom, n_groups - 1) - ALLOCATE (para_env_sub) - CALL para_env_sub%from_split(para_env, my_group) - CALL cp_blacs_env_create(blacs_env=blacs_env_sub, para_env=para_env_sub) - atom_P_start = my_group + 1 - atom_P_stride = n_groups - atom_j_mepos = para_env_sub%mepos - atom_j_stride = para_env_sub%num_pe - ELSE - atom_P_start = para_env%mepos + 1 - atom_P_stride = para_env%num_pe - atom_j_mepos = 0 - atom_j_stride = 1 - END IF natom = SIZE(bs_env%i_RI_start_from_atom) n_ao_total = bs_env%i_ao_end_from_atom(natom) - n_grid_total = SIZE(ri_rs_grid_points, 2) ! ========================================================================= ! 1. SETUP DBCSR TOPOLOGY & EXACT OFFSETS + ! mat_Z_lP inherits the grid row blocking (and row distribution) of + ! mat_phi_mu_l; its columns are one block per RI atom. ! ========================================================================= CALL dbcsr_get_info(mat_phi_mu_l, row_blk_size=r_blk_sizes, distribution=dist_phi) - CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, col_dist=col_dist_phi, group=group_handle) + CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, npcols=npcol_phi) num_grid_chunks = SIZE(r_blk_sizes) @@ -835,7 +1012,7 @@ CONTAINS ALLOCATE (ri_blk_sizes(natom), col_dist_ri(natom)) DO atom_P = 1, natom ri_blk_sizes(atom_P) = bs_env%i_RI_end_from_atom(atom_P) - bs_env%i_RI_start_from_atom(atom_P) + 1 - col_dist_ri(atom_P) = MOD(atom_P - 1, MAXVAL(col_dist_phi) + 1) + col_dist_ri(atom_P) = MOD(atom_P - 1, npcol_phi) END DO CALL dbcsr_distribution_new(dist_Z, template=dist_phi, row_dist=row_dist_grid, col_dist=col_dist_ri) @@ -847,6 +1024,11 @@ CONTAINS IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & 'Read Z_lP from file ', ' Execution time', m_walltime() - t1, ' s' + ! The grid rows are laid out in Morton (spatial) order (spatial_atom_order); a Z_lP.matrix + ! written by an older build with a different grid ordering would be silently misread into + ! the current row order. Delete stale Z_lP.matrix files and recompute if in doubt. + WRITE (bs_env%unit_nr, '(T2,A)') & + '*** NOTE: Z_lP restart must match the current (spatial) grid row ordering ***' WRITE (bs_env%unit_nr, '(A)') ' ' END IF ELSE @@ -855,17 +1037,17 @@ CONTAINS matrix_type=dbcsr_type_no_symmetry, & row_blk_size=r_blk_sizes, col_blk_size=ri_blk_sizes) + ! Largest per-atom AO block, needed to size the 3c-integral work buffers. max_ao_size = 0 DO j = 1, SIZE(bs_env%i_ao_start_from_atom) max_ao_size = MAX(max_ao_size, bs_env%i_ao_end_from_atom(j) - bs_env%i_ao_start_from_atom(j) + 1) END DO - max_loc_ri = MAXVAL(ri_blk_sizes) ! Per-atom RI-RS integration sphere: - ! cutoff_ri(P) = r_c + r_AO(P) - ! where r_c is the truncated-Coulomb cutoff of the RI metric. The - ! CUTOFF_RADIUS_RI_RS keyword (when > 0) overrides the entire cutoff calculation. - nkind = SIZE(atomic_kind_set) + ! cutoff_ri(P) = r_c + r_RI(P) + ! where r_c is the truncated-Coulomb cutoff of the RI metric and r_RI the radius of + ! the most diffuse RI auxiliary Gaussian on P. The CUTOFF_RADIUS_RL_RI keyword + ! (when > 0) overrides the entire cutoff calculation. ALLOCATE (cutoff_ri_per_atom(natom)) IF (bs_env%ri_rs%cutoff_radius_ri_rs > 0.0_dp) THEN @@ -874,267 +1056,215 @@ CONTAINS r_c = bs_env%ri_metric%cutoff_radius DO P_loop_atom = 1, natom cutoff_ri_per_atom(P_loop_atom) = & - r_c + bs_env%ri_rs%radius_ao_per_atom(P_loop_atom) + r_c + bs_env%ri_rs%radius_ri_per_atom(P_loop_atom) END DO END IF - ALLOCATE (cutoff_ri_per_kind(nkind)) - cutoff_ri_per_kind(:) = 0.0_dp + CALL print_sphere_cutoff_table(bs_env, atomic_kind_set, particle_set, cutoff_ri_per_atom) + + ! ========================================================================= + ! 2. PER-ATOM SOLVER CLASSIFICATION + ! Split the atoms into "small" (single-rank LAPACK, Phase A) and "big" + ! (distributed ScaLAPACK over subgroups of G ranks, Phase B) by comparing + ! each atom's estimated solve peak memory against the measured budget. + ! ========================================================================= + CALL classify_z_lp_atoms(bs_env, para_env, ri_rs_grid_points, particle_set, & + cutoff_ri_per_atom, ri_blk_sizes, n_ao_total, & + n_local_grid_atom, small_list, n_small, big_list, n_big, G) + + ! LPT scheduling: sort the atoms of each phase by estimated solve cost + ! (n_local_grid^3, Cholesky-dominated) and greedily assign to the least-loaded + ! rank (Phase A) / subgroup (Phase B). + CALL lpt_assign_atoms(small_list, n_small, n_local_grid_atom, para_env%num_pe, & + para_env%mepos, my_atoms_A, balance_A) + IF (n_big > 0) THEN + n_groups = para_env%num_pe/G + my_group = MIN(para_env%mepos/G, n_groups - 1) + CALL lpt_assign_atoms(big_list, n_big, n_local_grid_atom, n_groups, my_group, & + my_atoms_B, balance_B) + ELSE + ALLOCATE (my_atoms_B(0)) + balance_B = 1.0_dp + END IF + + ! Atoms this rank will process across both phases for rank-0 progress + n_my_atoms = SIZE(my_atoms_A) + SIZE(my_atoms_B) + n_done = 0 + next_pct = 25 + IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind maximum RI-RS sphere cutoff (Bohr):' - WRITE (bs_env%unit_nr, '(T4,A4,A14)') 'Kind', 'max cutoff_ri' - ! Walk atoms once; accumulate per-kind max using atomic_kind index - DO P_loop_atom = 1, natom - ikind = particle_set(P_loop_atom)%atomic_kind%kind_number - cutoff_ri_per_kind(ikind) = MAX(cutoff_ri_per_kind(ikind), & - cutoff_ri_per_atom(P_loop_atom)) - END DO - DO ikind = 1, nkind - WRITE (bs_env%unit_nr, '(T4,A4,F14.4)') & - atomic_kind_set(ikind)%element_symbol, & - cutoff_ri_per_kind(ikind) - END DO + WRITE (bs_env%unit_nr, '(T2,A,I7,A,I8,A)') & + 'RI-RS Z_lP solver: ', n_small, ' atoms single-rank (BLAS), ', n_big, & + ' atoms distributed' + IF (n_small > 0) WRITE (bs_env%unit_nr, '(T4,A,F18.2)') & + 'estimated single-rank load balance (max/mean cost per rank)', balance_A + IF (n_big > 0) THEN + WRITE (bs_env%unit_nr, '(T4,A,I44,A)') & + 'distributed subgroup size G', G, ' ranks' + WRITE (bs_env%unit_nr, '(T4,A,F17.2)') & + 'estimated distributed load balance (max/mean cost per group)', balance_B + END IF WRITE (bs_env%unit_nr, '(A)') ' ' END IF - DEALLOCATE (cutoff_ri_per_kind) - ! Build the shared 3c-integral context once, before the atom_P loop and outside - ! any OMP region. This hoists out the libint / t_c_g0 / md_ftable inits and the - ! contracted sphi tables, which would otherwise re-run on every per-block call. - ! gw_3c_ctx_create is MPI-collective (truncated-Coulomb init reads a file + bcasts). + ! Shared context for the three-center integrals (μν|P) of the RHS build CALL gw_3c_ctx_create(ctx_3c, qs_env, bs_env%ri_metric, & basis_j=bs_env%basis_set_AO, basis_k=bs_env%basis_set_AO, & basis_i=bs_env%basis_set_RI) ! ========================================================================= - ! 2. MPI LOOP OVER ATOMS (Fully independent, no MPI barriers inside) - ! This distributes the N_atoms among the available MPI processors. - ! phi_local for each atom_P's cutoff sphere is built on the fly via - ! fill_phi_for_atom — no dense replicated phi_global, no allreduce. + ! 3. TWO-PHASE LOOP OVER ATOMS + ! Phase A processes the "small" atoms with the single-rank BLAS path + ! Phase B processes the "big" atoms with the distributed ScaLAPACK path + ! over rank subgroups of size G. phi_local for each atom's cutoff sphere + ! is built on the fly to avoid replicating a global grid x AO matrix. ! ========================================================================= - DO atom_P = atom_P_start, natom, atom_P_stride + DO iphase = 1, 2 + IF (iphase == 1) THEN + use_dist = .FALSE. + atom_j_mepos = 0 + atom_j_stride = 1 + phase_hi = SIZE(my_atoms_A) + ELSE + IF (n_big == 0) CYCLE + use_dist = .TRUE. + n_groups = para_env%num_pe/G + my_group = MIN(para_env%mepos/G, n_groups - 1) + ALLOCATE (para_env_sub) + CALL para_env_sub%from_split(para_env, my_group) + CALL cp_blacs_env_create(blacs_env=blacs_env_sub, para_env=para_env_sub) + atom_j_mepos = para_env_sub%mepos + atom_j_stride = para_env_sub%num_pe + ! All ranks of a subgroup share my_group, hence the identical my_atoms_B list + ! (the per-atom ScaLAPACK solve is collective over the subgroup). + phase_hi = SIZE(my_atoms_B) + END IF - n_loc_ri = ri_blk_sizes(atom_P) - pos_P(:) = particle_set(atom_P)%r(:) - - cutoff_ri = cutoff_ri_per_atom(atom_P) - - ! --------------------------------------------------------------------- - ! A. Determine Local Grid Domain based on cutoff_ri - ! --------------------------------------------------------------------- - n_local_grid = 0 - DO l = 1, n_grid_total - dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) - IF (dist <= cutoff_ri) n_local_grid = n_local_grid + 1 - END DO - - ALLOCATE (local_grid_idx(n_local_grid)) - - n_local_grid = 0 - DO l = 1, n_grid_total - dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) - IF (dist <= cutoff_ri) THEN - n_local_grid = n_local_grid + 1 - local_grid_idx(n_local_grid) = l + DO idx = 1, phase_hi + IF (iphase == 1) THEN + atom_P = my_atoms_A(idx) + ELSE + atom_P = my_atoms_B(idx) END IF - END DO - ! --------------------------------------------------------------------- - ! B. Build phi_local on the fly via fill_phi_for_atom (no replication) - ! --------------------------------------------------------------------- - ! Copy the local sphere coordinates into a contiguous buffer for - ! fill_phi_for_atom. Only source atoms whose AO basis can reach the - ! sphere of atom_P contribute; the others are pruned by the inequality - ! using the per-atom radii precomputed in precompute_ri_rs_radii. - ALLOCATE (sphere_grid(3, n_local_grid)) - DO loc_idx = 1, n_local_grid - sphere_grid(:, loc_idx) = ri_rs_grid_points(:, local_grid_idx(loc_idx)) - END DO + n_loc_ri = ri_blk_sizes(atom_P) + cutoff_ri = cutoff_ri_per_atom(atom_P) - ALLOCATE (phi_local(n_local_grid, n_ao_total)) - phi_local = 0.0_dp + ! --------------------------------------------------------------------- + ! A. Sphere-local AO matrix Φ_μ(r_l): select the grid points with + ! |r_l - R_P| <= cutoff_ri(P), evaluate every AO on them, and drop + ! points whose largest AO amplitude is below EPS_FILTER. + ! --------------------------------------------------------------------- + CALL build_phi_on_sphere(bs_env, particle_set, qs_kind_set, cell, & + ri_rs_grid_points, atom_P, cutoff_ri, n_ao_total, & + local_grid_idx, n_local_grid, phi_local) - DO source_atom = 1, natom - d_sP = NORM2(particle_set(source_atom)%r(:) - pos_P(:)) - IF (d_sP > bs_env%ri_rs%radius_ao_per_atom(source_atom) + cutoff_ri) CYCLE + ! --------------------------------------------------------------------- + ! B. Right-hand side D_lP = Σ_μν Φ_μ(r_l) Φ_ν(r_l) (μν|P) + ! --------------------------------------------------------------------- + ALLOCATE (d_lp_local(n_local_grid, n_loc_ri)) + d_lp_local = 0.0_dp - col_start = bs_env%i_ao_start_from_atom(source_atom) - col_end = bs_env%i_ao_end_from_atom(source_atom) - r2_threshold = bs_env%ri_rs%radius_ao_per_atom(source_atom)**2 + CALL compute_d_lp(bs_env, ctx_3c, phi_local, d_lp_local, n_local_grid, & + n_loc_ri, atom_P, max_ao_size, atom_j_mepos, atom_j_stride) - CALL fill_phi_for_atom(phi_local(:, col_start:col_end), sphere_grid, & - n_local_grid, source_atom, particle_set, qs_kind_set, & - cell, r2_threshold) - END DO + ! Reduce per-subgroup-rank partials into the replicated d_lp_local. + ! Skipped for BLAS path: each rank has the full sum locally. + IF (use_dist) THEN + CALL para_env_sub%sum(d_lp_local) + END IF - DEALLOCATE (sphere_grid) + ! --------------------------------------------------------------------- + ! C. Jacobi conditioning vector d_l = 1/sqrt(D_ll) and, on the BLAS path, + ! the dense conditioned Gram matrix D'_ll' = d_l D_ll' d_l' + λδ_ll'. + ! --------------------------------------------------------------------- + ALLOCATE (d_vec_local(n_local_grid)) - ! --------------------------------------------------------------------- - ! C. Build Local RHS Matrix (d_lp_local) - ! Done first so the subgroup-distributed compute_d_lp + allreduce - ! is not entangled with the LHS build. compute_d_lp does not - ! depend on D_local or d_vec_local. - ! --------------------------------------------------------------------- - ALLOCATE (d_lp_local(n_local_grid, n_loc_ri)) - d_lp_local = 0.0_dp + IF (.NOT. use_dist) THEN + CALL build_gram_jacobi_blas(phi_local, n_local_grid, n_ao_total, & + bs_env%ri_rs%tikhonov, D_local, d_vec_local) + ELSE + ! ScaLAPACK path: only d_vec is needed here (= 1/||phi(r_l)||^2); + ! solve_D_lp_distributed builds its block-cyclic slice of D' internally + ! with the squared+scaled values, so no dense D_local on this rank. + CALL build_jacobi_diag_from_phi(phi_local, n_local_grid, n_ao_total, & + d_vec_local) + END IF - CALL compute_d_lp(bs_env, ctx_3c, phi_local, d_lp_local, n_local_grid, & - n_loc_ri, atom_P, max_ao_size, atom_j_mepos, atom_j_stride) + ! --------------------------------------------------------------------- + ! D. Pre-scale the RHS: D'_lP = d_l * D_lP + ! --------------------------------------------------------------------- + CALL scale_rows_by_diag(d_lp_local, d_vec_local, n_local_grid, n_loc_ri) - ! Reduce per-subgroup-rank partials into the replicated d_lp_local. - ! Skipped for G=1 (BLAS path): each rank has the full sum locally. - IF (n_procs_per_atom > 1) THEN - CALL para_env_sub%sum(d_lp_local) - END IF + ! --------------------------------------------------------------------- + ! E. Cholesky solve Σ_l' D'_ll' Z'_l'P = D'_lP + ! (BLAS dpotrf/dpotrs or ScaLAPACK pdpotrf/pdpotrs) + ! --------------------------------------------------------------------- + IF (.NOT. use_dist) THEN + CALL timeset(routineN//"_dpotrf", handle_dpotrf) + CALL dpotrf('L', n_local_grid, D_local, n_local_grid, info) + CALL timestop(handle_dpotrf) + CALL timeset(routineN//"_dpotrs", handle_dpotrs) + CALL dpotrs('L', n_local_grid, n_loc_ri, D_local, n_local_grid, & + d_lp_local, n_local_grid, info) + CALL timestop(handle_dpotrs) + DEALLOCATE (D_local) + ELSE + CALL solve_D_lp_distributed(phi_local, d_vec_local, d_lp_local, & + n_local_grid, n_ao_total, n_loc_ri, & + bs_env%ri_rs%tikhonov, & + para_env_sub, blacs_env_sub, & + fm_struct_D, fm_struct_b, fm_D, fm_b, info) + END IF - ! --------------------------------------------------------------------- - ! D. Build d_vec_local (Jacobi diagonal) + LHS — BLAS or ScaLAPACK - ! --------------------------------------------------------------------- - ALLOCATE (d_vec_local(n_local_grid)) + ! --------------------------------------------------------------------- + ! F. Undo the conditioning: Z_lP = d_l * Z'_lP + ! --------------------------------------------------------------------- + CALL scale_rows_by_diag(d_lp_local, d_vec_local, n_local_grid, n_loc_ri) - IF (n_procs_per_atom == 1) THEN - ! BLAS path: build D_local densely, compute d_vec as side-effect - ! of the Jacobi step (preserves bit-identical arithmetic with the - ! previous branch). - ALLOCATE (D_local(n_local_grid, n_local_grid)) - D_local = 0.0_dp + ! --------------------------------------------------------------------- + ! G. Scatter the solved Z columns back into the global sparse mat_Z_lP. + ! --------------------------------------------------------------------- + do_scatter = .TRUE. + IF (use_dist) do_scatter = (para_env_sub%mepos == 0) + IF (do_scatter) THEN + CALL scatter_z_columns(mat_Z_lP, d_lp_local, local_grid_idx, n_local_grid, & + n_loc_ri, atom_P, r_blk_sizes, row_offset, & + bs_env%eps_filter) + END IF - CALL dsyrk("L", "N", n_local_grid, n_ao_total, 1.0_dp, phi_local, & - n_local_grid, 0.0_dp, D_local, n_local_grid) + DEALLOCATE (d_vec_local, d_lp_local) + DEALLOCATE (local_grid_idx, phi_local) - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, D_local, d_vec_local, bs_env) & - !$OMP PRIVATE(i) & - !$OMP SCHEDULE(STATIC) - DO i = 1, n_local_grid - D_local(i, i) = D_local(i, i)**2 - d_vec_local(i) = 1.0_dp/SQRT(MAX(D_local(i, i), 1.0E-16_dp)) - D_local(i, i) = (D_local(i, i)*d_vec_local(i)**2) + bs_env%ri_rs%tikhonov - END DO - !$OMP END PARALLEL DO - - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, D_local, d_vec_local) & - !$OMP PRIVATE(j, i) & - !$OMP SCHEDULE(DYNAMIC) - DO j = 1, n_local_grid - DO i = j + 1, n_local_grid - D_local(i, j) = D_local(i, j)**2 - D_local(i, j) = D_local(i, j)*d_vec_local(i)*d_vec_local(j) - D_local(j, i) = D_local(i, j) + ! Progress based on rank 0 only + n_done = n_done + 1 + IF (bs_env%unit_nr > 0 .AND. n_my_atoms > 0) THEN + DO WHILE (next_pct <= 100 .AND. n_done*100 >= next_pct*n_my_atoms) + WRITE (bs_env%unit_nr, '(T2,A,I57,A)') 'Computing Z_lP:', next_pct, ' % done' + next_pct = next_pct + 25 END DO - END DO - !$OMP END PARALLEL DO - ELSE - ! ScaLAPACK path: d_vec computed directly from phi (= 1/||phi_i||^2); - ! solve_D_lp_distributed builds D block-cyclic internally with - ! the squared+scaled values, so no dense D_local on this rank. - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, n_ao_total, phi_local, d_vec_local) & - !$OMP PRIVATE(i, j) & - !$OMP SCHEDULE(STATIC) - DO i = 1, n_local_grid - d_vec_local(i) = 0.0_dp - DO j = 1, n_ao_total - d_vec_local(i) = d_vec_local(i) + phi_local(i, j)*phi_local(i, j) - END DO - d_vec_local(i) = 1.0_dp/MAX(d_vec_local(i), 1.0E-16_dp) - END DO - !$OMP END PARALLEL DO + END IF + END DO ! idx: atoms of this phase owned by this rank / subgroup + + ! Tear down the Phase-B subgroup (all ranks created it collectively). + IF (iphase == 2) THEN + CALL cp_blacs_env_release(blacs_env_sub) + CALL para_env_sub%free() + DEALLOCATE (para_env_sub) END IF - - ! --------------------------------------------------------------------- - ! E. Pre-scale d_lp by d_vec - ! --------------------------------------------------------------------- - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_loc_ri, n_local_grid, d_lp_local, d_vec_local) & - !$OMP PRIVATE(j_ri, i) & - !$OMP SCHEDULE(STATIC) - DO j_ri = 1, n_loc_ri - DO i = 1, n_local_grid - d_lp_local(i, j_ri) = d_lp_local(i, j_ri)*d_vec_local(i) - END DO - END DO - !$OMP END PARALLEL DO - - ! --------------------------------------------------------------------- - ! F. Solve — BLAS dpotrf/dpotrs or ScaLAPACK pdpotrf/pdpotrs - ! --------------------------------------------------------------------- - IF (n_procs_per_atom == 1) THEN - CALL dpotrf('L', n_local_grid, D_local, n_local_grid, info) - CALL dpotrs('L', n_local_grid, n_loc_ri, D_local, n_local_grid, & - d_lp_local, n_local_grid, info) - DEALLOCATE (D_local) - ELSE - CALL solve_D_lp_distributed(phi_local, d_vec_local, d_lp_local, & - n_local_grid, n_ao_total, n_loc_ri, & - bs_env%ri_rs%tikhonov, & - para_env_sub, blacs_env_sub, & - fm_struct_D, fm_struct_b, fm_D, fm_b, info) - END IF - - ! --------------------------------------------------------------------- - ! G. Post-scale solution by d_vec (common to both paths) - ! --------------------------------------------------------------------- - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_loc_ri, n_local_grid, d_lp_local, d_vec_local) & - !$OMP PRIVATE(j_ri, i) & - !$OMP SCHEDULE(STATIC) - DO j_ri = 1, n_loc_ri - DO i = 1, n_local_grid - d_lp_local(i, j_ri) = d_lp_local(i, j_ri)*d_vec_local(i) - END DO - END DO - !$OMP END PARALLEL DO - - ! --------------------------------------------------------------------- - ! H. Scatter Local Solution Back to Global DBCSR Matrix - ! local_grid_idx is ascending (built by the ordered scan above), so a - ! single walking pointer over it sweeps the chunks in one pass. - ! Under ScaLAPACK (G>1) the d_lp_local solution is identical on all - ! G subgroup ranks (gathered via cp_fm_get_submatrix); only the - ! subgroup root writes to mat_Z_lP so each atom column is emitted - ! exactly once. DBCSR routes blocks to their global owner on finalize. - ! --------------------------------------------------------------------- - IF (n_procs_per_atom == 1 .OR. para_env_sub%mepos == 0) THEN - ALLOCATE (Z_blk(MAXVAL(r_blk_sizes), n_loc_ri)) - loc_ptr = 1 - - DO i_blk = 1, num_grid_chunks - r_start = row_offset(i_blk) + 1 - r_end = row_offset(i_blk) + r_blk_sizes(i_blk) - current_chunk_size = r_blk_sizes(i_blk) - - Z_blk = 0.0_dp - - DO WHILE (loc_ptr <= n_local_grid) - g = local_grid_idx(loc_ptr) - IF (g > r_end) EXIT - Z_blk(g - r_start + 1, 1:n_loc_ri) = d_lp_local(loc_ptr, 1:n_loc_ri) - loc_ptr = loc_ptr + 1 - END DO - - IF (MAXVAL(ABS(Z_blk(1:current_chunk_size, 1:n_loc_ri))) > bs_env%eps_filter) THEN - CALL dbcsr_put_block(mat_Z_lP, row=i_blk, col=atom_P, & - block=Z_blk(1:current_chunk_size, 1:n_loc_ri)) - END IF - END DO - - DEALLOCATE (Z_blk) - END IF - - DEALLOCATE (d_vec_local, d_lp_local) - DEALLOCATE (local_grid_idx, phi_local) - - END DO + END DO ! iphase DEALLOCATE (cutoff_ri_per_atom) + DEALLOCATE (small_list, big_list) CALL gw_3c_ctx_release(ctx_3c) CALL dbcsr_finalize(mat_Z_lP) + CALL print_matrix_occupation(mat_Z_lP, 'Z(l,P)', para_env, bs_env%unit_nr) + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(A)') ' ' WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & 'Computed Z_lP ', ' Execution time', m_walltime() - t1, ' s' WRITE (bs_env%unit_nr, '(A)') ' ' @@ -1151,36 +1281,666 @@ CONTAINS DEALLOCATE (row_offset, ri_blk_sizes, col_dist_ri) CALL dbcsr_distribution_release(dist_Z) - IF (n_procs_per_atom > 1) THEN - CALL cp_blacs_env_release(blacs_env_sub) - CALL para_env_sub%free() - DEALLOCATE (para_env_sub) - END IF - DEALLOCATE (ri_rs_grid_points) CALL timestop(handle) END SUBROUTINE compute_coeff_Z_lP +! ************************************************************************************************** +!> \brief Prints the per-kind maximum RI-RS integration-sphere cutoff table. +!> \param bs_env ... +!> \param atomic_kind_set ... +!> \param particle_set ... +!> \param cutoff_ri_per_atom ... +! ************************************************************************************************** + SUBROUTINE print_sphere_cutoff_table(bs_env, atomic_kind_set, particle_set, cutoff_ri_per_atom) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: cutoff_ri_per_atom + CHARACTER(LEN=*), PARAMETER :: routineN = 'print_sphere_cutoff_table' + + INTEGER :: handle + + INTEGER :: iatom, ikind, nkind + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cutoff_ri_per_kind + + CALL timeset(routineN, handle) + + IF (bs_env%unit_nr <= 0) THEN + CALL timestop(handle) + RETURN + END IF + + nkind = SIZE(atomic_kind_set) + ALLOCATE (cutoff_ri_per_kind(nkind)) + cutoff_ri_per_kind(:) = 0.0_dp + + DO iatom = 1, SIZE(particle_set) + ikind = particle_set(iatom)%atomic_kind%kind_number + cutoff_ri_per_kind(ikind) = MAX(cutoff_ri_per_kind(ikind), cutoff_ri_per_atom(iatom)) + END DO + + WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind maximum RI-RS sphere cutoff (Å):' + WRITE (bs_env%unit_nr, '(T4,A4,A14)') 'Kind', 'cutoff (Å)' + DO ikind = 1, nkind + WRITE (bs_env%unit_nr, '(T4,A4,F14.4)') & + atomic_kind_set(ikind)%element_symbol, & + cutoff_ri_per_kind(ikind)*angstrom + END DO + WRITE (bs_env%unit_nr, '(A)') ' ' + + DEALLOCATE (cutoff_ri_per_kind) + + CALL timestop(handle) + + END SUBROUTINE print_sphere_cutoff_table + +! ************************************************************************************************** +!> \brief Splits the atoms of the Z_lP solve into a single-rank list ("small", Phase A: LAPACK +!> dpotrf/dpotrs on one rank) and a distributed list ("big", Phase B: ScaLAPACK +!> pdpotrf/pdpotrs over a rank subgroup of size G), and sizes G. +!> AUTO mode (N_PROCS_PER_ATOM_Z_LP <= 0, the default): estimate each atom's single-rank +!> peak memory +!> peak(P) = 8*n_local_grid(P)^2 (dense Gram matrix D_local) +!> + 8*n_local_grid(P)*n_ao (phi_local) +!> + 8*n_local_grid(P)*n_RI(P)*(1+n_threads) (d_lp + OMP partials) +!> and send atoms whose peak exceeds mem_safety * available-memory-per-proc to the +!> distributed path; G is auto-sized so the biggest atom's distributed D_local (/G) +!> fits alongside the replicated phi_local + d_lp. +!> MANUAL mode (> 0): 1 forces the single-rank path for every atom; > 1 keeps the +!> memory-based classification but forces that fixed subgroup size G. +!> In every mode G is floored by the ScaLAPACK 32-bit index limit (a local block-cyclic +!> slice of ~n_local_grid^2/G elements must stay below 2^31 or pdpotrf segfaults). +!> \param bs_env ... +!> \param para_env ... +!> \param ri_rs_grid_points ... +!> \param particle_set ... +!> \param cutoff_ri_per_atom ... +!> \param ri_blk_sizes per-atom ... +!> \param n_ao_total ... +!> \param n_local_grid_atom ... +!> \param small_list ... +!> \param n_small ... +!> \param big_list ... +!> \param n_big ... +!> \param G ... +! ************************************************************************************************** + SUBROUTINE classify_z_lp_atoms(bs_env, para_env, ri_rs_grid_points, particle_set, & + cutoff_ri_per_atom, ri_blk_sizes, n_ao_total, & + n_local_grid_atom, small_list, n_small, big_list, n_big, G) + +!$ USE OMP_LIB, ONLY: omp_get_max_threads + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(mp_para_env_type), POINTER :: para_env + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: ri_rs_grid_points + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: cutoff_ri_per_atom + INTEGER, DIMENSION(:), INTENT(IN) :: ri_blk_sizes + INTEGER, INTENT(IN) :: n_ao_total + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: n_local_grid_atom, small_list, big_list + INTEGER, INTENT(OUT) :: n_small, n_big, G + CHARACTER(LEN=*), PARAMETER :: routineN = 'classify_z_lp_atoms' + + INTEGER :: handle + + ! Conservative fraction of measured available memory usable per rank for the Z_lP + REAL(KIND=dp), PARAMETER :: mem_safety = 0.8_dp + + ! ScaLAPACK/BLACS index the per-rank local block-cyclic slice (~n_local_grid^2/G + ! elements) with 32-bit integers; keep it safely below 2^31 or pdpotrf segfaults. + REAL(KIND=dp), PARAMETER :: scalapack_loc_limit = 2.0E9_dp + + INTEGER :: G_atom, G_int32, G_int32_max, l, & + n_grid_total, n_local_grid, natom, & + nthreads_cls, P_loop_atom + LOGICAL :: auto_mode + REAL(KIND=dp) :: budget_bytes, cutoff_ri, dlp_bytes, & + mem_avail_GB, ng, nri, peak_bytes, & + phi_bytes + REAL(KIND=dp), DIMENSION(3) :: pos_P + + CALL timeset(routineN, handle) + + natom = SIZE(particle_set) + n_grid_total = SIZE(ri_rs_grid_points, 2) + + ! Per-atom sphere size: n_local_grid(P) = #{ l : |r_l - R_P| <= cutoff_ri(P) }. + ! It sets both the memory footprint (D_local is n_local_grid^2) and the solve + ! cost (~n_local_grid^3), so it drives classification and the LPT load balancing. + ALLOCATE (n_local_grid_atom(natom), small_list(natom), big_list(natom)) + DO P_loop_atom = 1, natom + pos_P(:) = particle_set(P_loop_atom)%r(:) + cutoff_ri = cutoff_ri_per_atom(P_loop_atom) + n_local_grid = 0 + DO l = 1, n_grid_total + IF (SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2) <= cutoff_ri**2) then + n_local_grid = n_local_grid + 1 + end if + END DO + n_local_grid_atom(P_loop_atom) = n_local_grid + END DO + + nthreads_cls = 1 +!$ nthreads_cls = omp_get_max_threads() + ! N_PROCS_PER_ATOM_Z_LP: -1 (default) = AUTO (classify by memory, auto-size G); + ! 1 = force single-rank BLAS for every atom; >1 = classify by memory but use this + ! fixed subgroup size G for the big atoms. + auto_mode = (bs_env%ri_rs%n_procs_per_atom_z_lp <= 0) + CALL ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) ! collective over all ranks + budget_bytes = mem_safety*mem_avail_GB*1.0E9_dp + + n_small = 0 + n_big = 0 + G = 1 + G_atom = 1 ! max G a big atom needs (memory + ScaLAPACK int32 floor) + G_int32_max = 1 ! max ScaLAPACK-int32 floor over the distributed atoms + IF (bs_env%ri_rs%n_procs_per_atom_z_lp == 1) THEN + ! Force single-rank BLAS for every atom. + DO P_loop_atom = 1, natom + n_small = n_small + 1 + small_list(n_small) = P_loop_atom + END DO + ELSE IF (mem_avail_GB <= 0.0_dp) THEN + ! No /proc/meminfo => cannot size by memory. + IF (auto_mode) THEN + IF (bs_env%unit_nr > 0) then + CPWARN("RI-RS Z_lP: no meminfo; single-rank solve for all atoms") + end if + DO P_loop_atom = 1, natom + n_small = n_small + 1 + small_list(n_small) = P_loop_atom + END DO + ELSE + ! Fixed G, no meminfo: distribute all atoms; still floor G by the int32 limit. + DO P_loop_atom = 1, natom + ng = REAL(n_local_grid_atom(P_loop_atom), dp) + G_int32_max = MAX(G_int32_max, CEILING(ng*ng/scalapack_loc_limit)) + n_big = n_big + 1 + big_list(n_big) = P_loop_atom + END DO + G = MIN(bs_env%ri_rs%n_procs_per_atom_z_lp, para_env%num_pe) + IF (G < G_int32_max) THEN + G = MIN(G_int32_max, para_env%num_pe) + IF (bs_env%unit_nr > 0) then + CPWARN("RI-RS Z_lP: raised G to avoid ScaLAPACK overflow") + end if + END IF + END IF + ELSE + ! Classify by memory: peak (D_local + phi_local + d_lp) vs budget. Small -> BLAS, + ! big -> distributed. Same classification for AUTO and fixed-G modes. + DO P_loop_atom = 1, natom + ng = REAL(n_local_grid_atom(P_loop_atom), dp) + nri = REAL(ri_blk_sizes(P_loop_atom), dp) + phi_bytes = 8.0_dp*ng*REAL(n_ao_total, dp) + dlp_bytes = 8.0_dp*ng*nri*REAL(1 + nthreads_cls, dp) + peak_bytes = 8.0_dp*ng*ng + phi_bytes + dlp_bytes + IF (peak_bytes <= budget_bytes) THEN + n_small = n_small + 1 + small_list(n_small) = P_loop_atom + ELSE + n_big = n_big + 1 + big_list(n_big) = P_loop_atom + ! G must satisfy BOTH: (a) memory — distributed D_local (/G) fits next to the + ! replicated phi_local + d_lp; (b) ScaLAPACK — local ~ng^2/G below the int32 limit. + G_int32 = CEILING(ng*ng/scalapack_loc_limit) + G_int32_max = MAX(G_int32_max, G_int32) + G_atom = MAX(G_atom, G_int32, & + CEILING(8.0_dp*ng*ng/MAX(budget_bytes - phi_bytes - dlp_bytes, 1.0_dp))) + END IF + END DO + IF (n_big > 0) THEN + IF (auto_mode) THEN + ! Auto-size G from the most demanding big atom. + IF (G_atom > para_env%num_pe) THEN + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A)') & + 'RI-RS Z_lP: an atom is too large to fit even distributed over all '// & + 'ranks. Add nodes, use fewer MPI ranks/node, lower CUTOFF_RADIUS_RL_RI, '// & + 'or raise EPS_FILTER (more grid screening).' + END IF + CPABORT("RI-RS Z_lP: atom too large even fully distributed") + END IF + G = MIN(MAX(G_atom, 2), para_env%num_pe) + ELSE + ! Fixed G from the keyword. Hard-floor by the ScaLAPACK int32 limit (below it + ! pdpotrf segfaults); warn if it is still below the memory recommendation. + G = MIN(bs_env%ri_rs%n_procs_per_atom_z_lp, para_env%num_pe) + IF (G < G_int32_max) THEN + G = MIN(G_int32_max, para_env%num_pe) + IF (bs_env%unit_nr > 0) then + CPWARN("RI-RS Z_lP: raised G to avoid ScaLAPACK overflow") + end if + ELSE IF (G < G_atom .AND. bs_env%unit_nr > 0) THEN + CPWARN("RI-RS Z_lP: N_PROCS_PER_ATOM_Z_LP too small for the largest atom") + END IF + END IF + END IF + END IF + + CALL timestop(handle) + + END SUBROUTINE classify_z_lp_atoms + +! ************************************************************************************************** +!> \brief Builds the sphere-local AO matrix phi_local(l, μ) = Φ_μ(r_l) for one RI atom P +!> \param bs_env ... +!> \param particle_set ... +!> \param qs_kind_set ... +!> \param cell ... +!> \param ri_rs_grid_points ... +!> \param atom_P ... +!> \param cutoff_ri ... +!> \param n_ao_total ... +!> \param local_grid_idx ... +!> \param n_local_grid ... +!> \param phi_local ... +! ************************************************************************************************** + SUBROUTINE build_phi_on_sphere(bs_env, particle_set, qs_kind_set, cell, ri_rs_grid_points, & + atom_P, cutoff_ri, n_ao_total, local_grid_idx, n_local_grid, & + phi_local) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + TYPE(cell_type), POINTER :: cell + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: ri_rs_grid_points + INTEGER, INTENT(IN) :: atom_P + REAL(KIND=dp), INTENT(IN) :: cutoff_ri + INTEGER, INTENT(IN) :: n_ao_total + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: local_grid_idx + INTEGER, INTENT(OUT) :: n_local_grid + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), & + INTENT(OUT) :: phi_local + + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_phi_on_sphere' + + INTEGER :: col_end, col_start, handle, j, k, l, & + loc_idx, n_grid_total, n_keep, & + source_atom + REAL(KIND=dp) :: d_sP, dist, r2_threshold + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: w_pt + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: phi_keep, sphere_grid + REAL(KIND=dp), DIMENSION(3) :: pos_P + + CALL timeset(routineN, handle) + + n_grid_total = SIZE(ri_rs_grid_points, 2) + pos_P(:) = particle_set(atom_P)%r(:) + + n_local_grid = 0 + DO l = 1, n_grid_total + dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) + IF (dist <= cutoff_ri) n_local_grid = n_local_grid + 1 + END DO + + ALLOCATE (local_grid_idx(n_local_grid)) + + n_local_grid = 0 + DO l = 1, n_grid_total + dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) + IF (dist <= cutoff_ri) THEN + n_local_grid = n_local_grid + 1 + local_grid_idx(n_local_grid) = l + END IF + END DO + + ALLOCATE (sphere_grid(3, n_local_grid)) + DO loc_idx = 1, n_local_grid + sphere_grid(:, loc_idx) = ri_rs_grid_points(:, local_grid_idx(loc_idx)) + END DO + + ALLOCATE (phi_local(n_local_grid, n_ao_total)) + phi_local = 0.0_dp + + DO source_atom = 1, SIZE(particle_set) + d_sP = NORM2(particle_set(source_atom)%r(:) - pos_P(:)) + IF (d_sP > bs_env%ri_rs%radius_ao_per_atom(source_atom) + cutoff_ri) CYCLE + + col_start = bs_env%i_ao_start_from_atom(source_atom) + col_end = bs_env%i_ao_end_from_atom(source_atom) + ! A positive CUTOFF_RADIUS_RI_AO overrides the per-atom Gaussian radius + ! with a user-defined hard cutoff. + IF (bs_env%ri_rs%cutoff_radius_ri_ao > 0.0_dp) THEN + r2_threshold = bs_env%ri_rs%cutoff_radius_ri_ao**2 + ELSE + r2_threshold = bs_env%ri_rs%radius_ao_per_atom(source_atom)**2 + END IF + + CALL fill_phi_for_atom(phi_local(:, col_start:col_end), sphere_grid, & + n_local_grid, source_atom, particle_set, qs_kind_set, & + cell, r2_threshold) + END DO + + DEALLOCATE (sphere_grid) + + IF (n_local_grid > 0) THEN + ALLOCATE (w_pt(n_local_grid)) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, n_ao_total, phi_local, w_pt) & + !$OMP PRIVATE(l, j) SCHEDULE(STATIC) + DO l = 1, n_local_grid + w_pt(l) = 0.0_dp + DO j = 1, n_ao_total + w_pt(l) = MAX(w_pt(l), ABS(phi_local(l, j))) + END DO + END DO + !$OMP END PARALLEL DO + n_keep = COUNT(w_pt > bs_env%eps_filter) + IF (n_keep < n_local_grid) THEN + ALLOCATE (phi_keep(n_keep, n_ao_total)) + k = 0 + DO l = 1, n_local_grid + IF (w_pt(l) > bs_env%eps_filter) THEN + k = k + 1 + phi_keep(k, :) = phi_local(l, :) + local_grid_idx(k) = local_grid_idx(l) + END IF + END DO + CALL MOVE_ALLOC(phi_keep, phi_local) + n_local_grid = n_keep + END IF + DEALLOCATE (w_pt) + END IF + + CALL timestop(handle) + + END SUBROUTINE build_phi_on_sphere + +! ************************************************************************************************** +!> \brief Builds the dense Jacobi-conditioned Gram matrix and the conditioning vector for the +!> single-rank (BLAS/LAPACK) Z_lP solve: +!> D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]² (dsyrk of phi_local, then squared) +!> d_l = 1 / sqrt(D_ll) +!> D'_ll' = d_l D_ll' d_l' + λ δ_ll' +!> Only the lower triangle is referenced by the subsequent dpotrf('L') +!> \param phi_local ... +!> \param n_local_grid ... +!> \param n_ao_total ... +!> \param tikhonov ... +!> \param D_local ... +!> \param d_vec_local ... +! ************************************************************************************************** + SUBROUTINE build_gram_jacobi_blas(phi_local, n_local_grid, n_ao_total, tikhonov, D_local, & + d_vec_local) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: phi_local + INTEGER, INTENT(IN) :: n_local_grid, n_ao_total + REAL(KIND=dp), INTENT(IN) :: tikhonov + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), & + INTENT(OUT) :: D_local + REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: d_vec_local + + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_gram_jacobi_blas' + + INTEGER :: handle, handle_dsyrk, i, j + + CALL timeset(routineN, handle) + + ALLOCATE (D_local(n_local_grid, n_local_grid)) + D_local = 0.0_dp + + ! D_ll' = Σ_μ Φ_μ(r_l) Φ_μ(r_l') (lower triangle only) + CALL timeset(routineN//"_dsyrk", handle_dsyrk) + CALL dsyrk("L", "N", n_local_grid, n_ao_total, 1.0_dp, phi_local, & + n_local_grid, 0.0_dp, D_local, n_local_grid) + CALL timestop(handle_dsyrk) + + ! Diagonal: square, derive d_l = 1/sqrt(D_ll), scale, add Tikhonov λ + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, D_local, d_vec_local, tikhonov) & + !$OMP PRIVATE(i) & + !$OMP SCHEDULE(STATIC) + DO i = 1, n_local_grid + D_local(i, i) = D_local(i, i)**2 + d_vec_local(i) = 1.0_dp/SQRT(MAX(D_local(i, i), 1.0E-16_dp)) + D_local(i, i) = (D_local(i, i)*d_vec_local(i)**2) + tikhonov + END DO + !$OMP END PARALLEL DO + + ! Off-diagonal: D'_ll' = d_l D_ll'^2 d_l' (mirror to the upper triangle) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, D_local, d_vec_local) & + !$OMP PRIVATE(j, i) & + !$OMP SCHEDULE(DYNAMIC) + DO j = 1, n_local_grid + DO i = j + 1, n_local_grid + D_local(i, j) = D_local(i, j)**2 + D_local(i, j) = D_local(i, j)*d_vec_local(i)*d_vec_local(j) + D_local(j, i) = D_local(i, j) + END DO + END DO + !$OMP END PARALLEL DO + + CALL timestop(handle) + + END SUBROUTINE build_gram_jacobi_blas + +! ************************************************************************************************** +!> \brief Computes the Jacobi conditioning vector directly from phi for the distributed +!> (ScaLAPACK) Z_lP solve: d_l = 1 / Σ_μ Φ_μ(r_l)² = 1/sqrt(D_ll), without forming +!> the Gram matrix. +!> \param phi_local ... +!> \param n_local_grid ... +!> \param n_ao_total ... +!> \param d_vec_local ... +! ************************************************************************************************** + SUBROUTINE build_jacobi_diag_from_phi(phi_local, n_local_grid, n_ao_total, d_vec_local) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: phi_local + INTEGER, INTENT(IN) :: n_local_grid, n_ao_total + REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: d_vec_local + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_jacobi_diag_from_phi' + + INTEGER :: handle + + INTEGER :: i, j + + CALL timeset(routineN, handle) + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, n_ao_total, phi_local, d_vec_local) & + !$OMP PRIVATE(i, j) & + !$OMP SCHEDULE(STATIC) + DO i = 1, n_local_grid + d_vec_local(i) = 0.0_dp + DO j = 1, n_ao_total + d_vec_local(i) = d_vec_local(i) + phi_local(i, j)*phi_local(i, j) + END DO + d_vec_local(i) = 1.0_dp/MAX(d_vec_local(i), 1.0E-16_dp) + END DO + !$OMP END PARALLEL DO + + CALL timestop(handle) + + END SUBROUTINE build_jacobi_diag_from_phi + +! ************************************************************************************************** +!> \brief Scales every row of a matrix by the corresponding diagonal entry, +!> A(l, :) <- d_l * A(l, :). Used in Z_lP solve: to pre-scale the RHS +!> (D'_lP = d_l D_lP) and to undo the conditioning of the solution (Z_lP = d_l Z'_lP). +!> \param d_lp_local ... +!> \param d_vec_local ... +!> \param n_local_grid ... +!> \param n_loc_ri ... +! ************************************************************************************************** + SUBROUTINE scale_rows_by_diag(d_lp_local, d_vec_local, n_local_grid, n_loc_ri) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: d_lp_local + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: d_vec_local + INTEGER, INTENT(IN) :: n_local_grid, n_loc_ri + CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_rows_by_diag' + + INTEGER :: handle + + INTEGER :: i, j_ri + + CALL timeset(routineN, handle) + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_loc_ri, n_local_grid, d_lp_local, d_vec_local) & + !$OMP PRIVATE(j_ri, i) & + !$OMP SCHEDULE(STATIC) + DO j_ri = 1, n_loc_ri + DO i = 1, n_local_grid + d_lp_local(i, j_ri) = d_lp_local(i, j_ri)*d_vec_local(i) + END DO + END DO + !$OMP END PARALLEL DO + + CALL timestop(handle) + + END SUBROUTINE scale_rows_by_diag + +! ************************************************************************************************** +!> \brief Scatters the solved Z columns of one atom P from the dense sphere-local solution back +!> into the global sparse mat_Z_lP +!> \param mat_Z_lP ... +!> \param d_lp_local ... +!> \param local_grid_idx ... +!> \param n_local_grid ... +!> \param n_loc_ri ... +!> \param atom_P ... +!> \param r_blk_sizes ... +!> \param row_offset ... +!> \param eps_filter ... +! ************************************************************************************************** + SUBROUTINE scatter_z_columns(mat_Z_lP, d_lp_local, local_grid_idx, n_local_grid, n_loc_ri, & + atom_P, r_blk_sizes, row_offset, eps_filter) + + TYPE(dbcsr_type), INTENT(INOUT) :: mat_Z_lP + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: d_lp_local + INTEGER, DIMENSION(:), INTENT(IN) :: local_grid_idx + INTEGER, INTENT(IN) :: n_local_grid, n_loc_ri, atom_P + INTEGER, DIMENSION(:), INTENT(IN) :: r_blk_sizes, row_offset + REAL(KIND=dp), INTENT(IN) :: eps_filter + CHARACTER(LEN=*), PARAMETER :: routineN = 'scatter_z_columns' + INTEGER :: handle + + INTEGER :: current_chunk_size, g_pt, i_blk, & + loc_ptr, r_end, r_start + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Z_blk + + CALL timeset(routineN, handle) + + ALLOCATE (Z_blk(MAXVAL(r_blk_sizes), n_loc_ri)) + loc_ptr = 1 + + DO i_blk = 1, SIZE(r_blk_sizes) + r_start = row_offset(i_blk) + 1 + r_end = row_offset(i_blk) + r_blk_sizes(i_blk) + current_chunk_size = r_blk_sizes(i_blk) + + Z_blk = 0.0_dp + + ! Copy the sphere points whose global grid index falls inside this block + DO WHILE (loc_ptr <= n_local_grid) + g_pt = local_grid_idx(loc_ptr) + IF (g_pt > r_end) EXIT + Z_blk(g_pt - r_start + 1, 1:n_loc_ri) = d_lp_local(loc_ptr, 1:n_loc_ri) + loc_ptr = loc_ptr + 1 + END DO + + IF (MAXVAL(ABS(Z_blk(1:current_chunk_size, 1:n_loc_ri))) > eps_filter) THEN + CALL dbcsr_put_block(mat_Z_lP, row=i_blk, col=atom_P, & + block=Z_blk(1:current_chunk_size, 1:n_loc_ri)) + END IF + END DO + + DEALLOCATE (Z_blk) + + CALL timestop(handle) + + END SUBROUTINE scatter_z_columns + +! ************************************************************************************************** +!> \brief LPT (longest-processing-time) assignment of the Z_lP atoms to workers (MPI ranks in +!> Phase A, rank subgroups in Phase B): sort by estimated solve cost n_local_grid^3 +!> (the per-atom Cholesky dominates; the n^2 assembly terms order the atoms the same +!> way) and greedily give each atom to the least-loaded worker. +!> \param atom_list ... +!> \param n_atoms ... +!> \param n_local_grid_atom ... +!> \param n_workers ... +!> \param my_worker ... +!> \param my_atoms ... +!> \param max_over_mean ... +! ************************************************************************************************** + SUBROUTINE lpt_assign_atoms(atom_list, n_atoms, n_local_grid_atom, n_workers, my_worker, & + my_atoms, max_over_mean) + + INTEGER, DIMENSION(:), INTENT(IN) :: atom_list + INTEGER, INTENT(IN) :: n_atoms + INTEGER, DIMENSION(:), INTENT(IN) :: n_local_grid_atom + INTEGER, INTENT(IN) :: n_workers, my_worker + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: my_atoms + REAL(KIND=dp), INTENT(OUT) :: max_over_mean + CHARACTER(LEN=*), PARAMETER :: routineN = 'lpt_assign_atoms' + INTEGER :: handle + + INTEGER :: i, iw, n_mine, w_min + INTEGER, ALLOCATABLE, DIMENSION(:) :: mine_tmp, perm + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cost, load + + CALL timeset(routineN, handle) + + max_over_mean = 1.0_dp + IF (n_atoms <= 0) THEN + ALLOCATE (my_atoms(0)) + CALL timestop(handle) + RETURN + END IF + + ALLOCATE (cost(n_atoms), perm(n_atoms), mine_tmp(n_atoms), load(n_workers)) + DO i = 1, n_atoms + cost(i) = REAL(n_local_grid_atom(atom_list(i)), dp)**3 + END DO + CALL sort(cost, n_atoms, perm) ! ascending; walk backwards for largest-first + + load(:) = 0.0_dp + n_mine = 0 + DO i = n_atoms, 1, -1 + w_min = 1 + DO iw = 2, n_workers + IF (load(iw) < load(w_min)) w_min = iw + END DO + load(w_min) = load(w_min) + cost(i) + IF (w_min - 1 == my_worker) THEN + n_mine = n_mine + 1 + mine_tmp(n_mine) = atom_list(perm(i)) + END IF + END DO + + ALLOCATE (my_atoms(n_mine)) + my_atoms(:) = mine_tmp(1:n_mine) + IF (SUM(load) > 0.0_dp) max_over_mean = MAXVAL(load)*REAL(n_workers, dp)/SUM(load) + + CALL timestop(handle) + + END SUBROUTINE lpt_assign_atoms + ! ************************************************************************************************** !> \brief Computes the dense localized RHS d_lp(l,P) = Σ_{μν} Φ_μ(r_l)·Φ_ν(r_l)·(μν|P) for one !> RI atom P, OMP-threaded over (atom_j, atom_k) AO-pair blocks: per thread, build the 3c !> block, then contract grid-chunked pair densities into a private d_lp partial; partials !> are reduced into d_lp at the end. -!> Pair screening is handled inside build_3c_integral_block_ctx via the `screened` output, +!> Pair screening is handled inside build_3c_integral_block_ctx via the `screened` output. !> \param bs_env ... -!> \param ctx shared 3c-integral context (gw_3c_ctx_create) -!> \param phi_val Φ_μ(r_l) on the local-sphere grid (n_grid_total × n_ao) -!> \param d_lp output (n_grid_total × n_loc_ri), zeroed by the caller, accumulated here -!> \param n_grid_total number of local-sphere grid rows -!> \param n_loc_ri number of RI functions of atom_P +!> \param ctx ... +!> \param phi_val ... +!> \param d_lp ... +!> \param n_grid_total ... +!> \param n_loc_ri ... !> \param atom_P ... !> \param max_ao_size ... !> \param atom_j_mepos ... !> \param atom_j_stride ... ! ************************************************************************************************** - SUBROUTINE compute_d_lp(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, & max_ao_size, atom_j_mepos, atom_j_stride) @@ -1195,11 +1955,12 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_d_lp' INTEGER, PARAMETER :: grid_chunk = 1024 - INTEGER :: atom_j, atom_k, c, handle, j, jk_idx, & + INTEGER :: atom_j, atom_k, c, handle, & + handle_dgemm, j, jk_idx, & jsize, jstart, k, ksize, kstart, l, & l0, ri LOGICAL :: screened - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: int_2d_prv, rho_chunk + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: d_lp_prv, int_2d_prv, rho_chunk REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: int_3c_prv TYPE(gw_3c_ws_type) :: ws @@ -1208,20 +1969,20 @@ CONTAINS !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, max_ao_size, & !$OMP atom_j_mepos, atom_j_stride) & - !$OMP PRIVATE(atom_j, atom_k, c, j, jk_idx, jsize, jstart, k, ksize, kstart, l, l0, ri, & - !$OMP screened, int_2d_prv, rho_chunk, int_3c_prv, ws) + !$OMP PRIVATE(atom_j, atom_k, c, handle_dgemm, j, jk_idx, jsize, jstart, k, ksize, kstart, & + !$OMP l, l0, ri, screened, d_lp_prv, int_2d_prv, rho_chunk, int_3c_prv, ws) CALL gw_3c_ws_create(ws, ctx) ALLOCATE (int_3c_prv(max_ao_size, max_ao_size, n_loc_ri)) ALLOCATE (int_2d_prv(max_ao_size*max_ao_size, n_loc_ri)) ALLOCATE (rho_chunk(grid_chunk, max_ao_size*max_ao_size)) + ALLOCATE (d_lp_prv(n_grid_total, n_loc_ri)) + d_lp_prv(:, :) = 0.0_dp ! MPI-stride atom_j over the subgroup (atom_j_stride = 1 for the BLAS ! path, > 1 for the ScaLAPACK path). The OMP DO parallelizes the inner - ! atom_k while the outer atom_j carries the MPI stride. COLLAPSE(2) is - ! dropped because the outer stride is non-unit under ScaLAPACK; for - ! typical natom the inner loop has plenty of work for DYNAMIC. - !$OMP DO SCHEDULE(DYNAMIC) REDUCTION(+:d_lp) + ! atom_k while the outer atom_j carries the MPI stride. + !$OMP DO SCHEDULE(DYNAMIC) DO atom_j = atom_j_mepos + 1, SIZE(bs_env%i_ao_start_from_atom), atom_j_stride DO atom_k = 1, SIZE(bs_env%i_ao_start_from_atom) jstart = bs_env%i_ao_start_from_atom(atom_j) @@ -1262,16 +2023,23 @@ CONTAINS END DO END DO END DO + CALL timeset(routineN//"_dgemm", handle_dgemm) CALL dgemm("N", "N", c, n_loc_ri, jsize*ksize, & 1.0_dp, rho_chunk, grid_chunk, & int_2d_prv, max_ao_size*max_ao_size, & - 1.0_dp, d_lp(l0, 1), n_grid_total) + 1.0_dp, d_lp_prv(l0, 1), n_grid_total) + CALL timestop(handle_dgemm) END DO END DO END DO !$OMP END DO - DEALLOCATE (int_3c_prv, int_2d_prv, rho_chunk) + !$OMP CRITICAL (compute_d_lp_reduce) + d_lp(1:n_grid_total, 1:n_loc_ri) = d_lp(1:n_grid_total, 1:n_loc_ri) + & + d_lp_prv(1:n_grid_total, 1:n_loc_ri) + !$OMP END CRITICAL (compute_d_lp_reduce) + + DEALLOCATE (int_3c_prv, int_2d_prv, rho_chunk, d_lp_prv) CALL gw_3c_ws_release(ws) !$OMP END PARALLEL @@ -1282,29 +2050,28 @@ CONTAINS ! ************************************************************************************************** !> \brief Distributed pdpotrf/pdpotrs solve of D x = b for one atom of the -!> RI-RS Z_lP build. Called when N_PROCS_PER_ATOM_Z_LP > 1, with a -!> subgroup of cooperating ranks and an associated BLACS context. +!> RI-RS Z_lP build (Phase B, "big" atoms), called with a subgroup of +!> cooperating ranks and an associated BLACS context. !> Each rank in the subgroup holds the (replicated) phi_local and the !> (replicated) RHS d_lp; it builds its own block-cyclic slice of the !> squared+Jacobi-scaled Gram matrix D via tiled DGEMM, factorizes via !> cp_fm_cholesky_decompose (UPLO='U'), and solves with !> cp_fm_cholesky_solve. The replicated d_lp is updated in place via !> cp_fm_get_submatrix. -!> \param phi_local replicated (n_loc x n_ao) AO values on the sphere grid -!> \param d_vec replicated Jacobi diagonal = 1 / ||phi_i||^2 -!> \param d_lp replicated RHS in/out (n_loc x n_rhs); on input pre-scaled -!> by d_vec, on output also pre-scaled (caller post-scales) -!> \param n_loc number of sphere-local grid points -!> \param n_ao number of AO basis functions -!> \param n_rhs number of RI functions of this atom_P (RHS columns) -!> \param tikhonov regularisation added to the diagonal -!> \param para_env_sub sub-communicator of the atom-group -!> \param blacs_env_sub BLACS context on the sub-communicator +!> \param phi_local ... +!> \param d_vec ... +!> \param d_lp ... +!> \param n_loc ... +!> \param n_ao ... +!> \param n_rhs ... +!> \param tikhonov ... +!> \param para_env_sub ... +!> \param blacs_env_sub ... !> \param fm_struct_D ... !> \param fm_struct_b ... !> \param fm_D ... !> \param fm_b ... -!> \param info 0 on success, non-zero if pdpotrf or pdpotrs failed +!> \param info ... ! ************************************************************************************************** SUBROUTINE solve_D_lp_distributed(phi_local, d_vec, d_lp, n_loc, n_ao, n_rhs, & tikhonov, para_env_sub, blacs_env_sub, & @@ -1355,7 +2122,7 @@ CONTAINS IF (nrow_local > 0 .AND. ncol_local > 0) THEN BLOCK INTEGER, PARAMETER :: ntile = 1024 - INTEGER :: ib, ie, jb, je, mb, kb, ti, tj + INTEGER :: ib, ie, jb, je, mb, kb, ti, tj, handle_dgemm REAL(KIND=dp), ALLOCATABLE :: gram_t(:, :), phi_cols_t(:, :), phi_rows_t(:, :) ALLOCATE (phi_rows_t(ntile, n_ao), phi_cols_t(n_ao, ntile), gram_t(ntile, ntile)) DO ib = 1, nrow_local, ntile @@ -1382,9 +2149,11 @@ CONTAINS END DO END DO !$OMP END PARALLEL DO + CALL timeset(routineN//"_dgemm", handle_dgemm) CALL dgemm('N', 'N', mb, kb, n_ao, & 1.0_dp, phi_rows_t, ntile, phi_cols_t, n_ao, & 0.0_dp, gram_t, ntile) + CALL timestop(handle_dgemm) !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(mb, kb, gram_t, d_vec, row_indices, col_indices, ib, jb) & !$OMP SHARED(local_data, tikhonov) & @@ -1408,23 +2177,23 @@ CONTAINS END BLOCK END IF - ! ---- Load the replicated d_lp into the block-cyclic fm_b ----------- + ! Load the replicated d_lp into the block-cyclic fm_b CALL cp_fm_set_submatrix(fm_b, d_lp) - ! ---- pdpotrf (Cholesky factorisation; cp_fm_cholesky_decompose - ! factors with UPLO='U', so pdpotrs must match) + ! pdpotrf (Cholesky factorisation; cp_fm_cholesky_decompose + ! factors with UPLO='U', so pdpotrs must match) CALL cp_fm_cholesky_decompose(fm_D, n=n_loc, info_out=info) IF (info /= 0) THEN CPABORT("pdpotrf failed in solve_D_lp_distributed") END IF - ! ---- pdpotrs/dpotrs (solve in place on fm_b) ----------------------- + ! pdpotrs/dpotrs (solve in place on fm_b) CALL cp_fm_cholesky_solve(fm_D, fm_b, n=n_loc, info_out=info) IF (info /= 0) THEN CPABORT("pdpotrs failed in solve_D_lp_distributed") END IF - ! ---- Gather distributed solution back into the replicated d_lp ---- + ! Gather distributed solution back into the replicated d_lp CALL cp_fm_get_submatrix(fm_b, d_lp) CALL cp_fm_release(fm_D) @@ -1437,13 +2206,17 @@ CONTAINS END SUBROUTINE solve_D_lp_distributed ! ************************************************************************************************** -!> \brief Computes the χ(iτ) matrix +!> \brief Computes the polarizability matrix in the RI basis for every +!> imaginary-time point: +!> G^occ/vir_μν(i|τ|) = Σ_n C_μn e^(-|(ϵ_n-ϵ_F)τ|) C_νn (AO x AO, build_G_ao) +!> χ_ll'(iτ) = [Σ_μν Φ_μ(r_l) G^occ_μν Φ_ν(r_l')] ∘ [Σ_μν Φ_μ(r_l) G^vir_μν Φ_ν(r_l')] +!> χ_PQ(iτ) = g_s Σ_ll' Z_lP χ_ll'(iτ) Z_l'Q (g_s = spin degeneracy) +!> The grid (l) index is streamed in panels (contract_grid_panels). !> \param bs_env ... !> \param mat_chi_Gamma_tau ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... ! ************************************************************************************************** - SUBROUTINE get_mat_chi_Gamma_tau(bs_env, mat_chi_Gamma_tau, mat_phi_mu_l, mat_Z_lP) TYPE(post_scf_bandstructure_type), POINTER :: bs_env @@ -1452,82 +2225,71 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'get_mat_chi_Gamma_tau' - INTEGER :: handle, i, i_t, ispin, npcol - INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_ao, & - dist_col_grid, dist_row_grid - REAL(KIND=dp) :: t1, tau - TYPE(dbcsr_distribution_type) :: dist_grid_grid, dist_phi - TYPE(dbcsr_type) :: matrix_chi_grid, matrix_chi_grid_spin, & - matrix_G_occ_grid, matrix_G_vir_grid + INTEGER :: handle, i_t, ispin, n_panels + INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last + REAL(KIND=dp) :: grid_occ, t1, tau + TYPE(dbcsr_type) :: matrix_G_occ_ao, matrix_G_vir_ao CALL timeset(routineN, handle) - ! ========================================================================= - ! 1. SETUP CORE TOPOLOGIES - ! ========================================================================= - CALL dbcsr_get_info(mat_phi_mu_l, distribution=dist_phi, row_blk_size=blk_grid, col_blk_size=blk_ao) - CALL dbcsr_distribution_get(dist_phi, row_dist=dist_row_grid, col_dist=dist_col_ao) + ! Panel boundaries for the grid-streaming contraction. + ! The panels are identical for χ, Σ^x and Σ^c, so the count is reported once here for all three stages. - ! Determine number of MPI process columns - npcol = MAXVAL(dist_col_ao) + 1 + CALL resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) - ! Build a perfectly safe column distribution for the Grid dimension - ALLOCATE (dist_col_grid(SIZE(blk_grid))) - DO i = 1, SIZE(blk_grid) - dist_col_grid(i) = MOD(i - 1, npcol) - END DO - - CALL dbcsr_distribution_new(dist_grid_grid, template=dist_phi, & - row_dist=dist_row_grid, col_dist=dist_col_grid) - - CALL dbcsr_create(matrix_G_occ_grid, "G_occ_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - CALL dbcsr_create(matrix_G_vir_grid, "G_vir_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - CALL dbcsr_create(matrix_chi_grid, "chi_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - CALL dbcsr_create(matrix_chi_grid_spin, "chi_grid_spin", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + n_panels = SIZE(pan_first) + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,I44)') 'Number of batches for χ, Σ matrices', n_panels + CALL m_flush(bs_env%unit_nr) + END IF ! ========================================================================= - ! 2. MAIN IMAGINARY TIME LOOP + ! IMAGINARY TIME LOOP + ! χ_PQ(iτ) = Σ_s g_s · Z^T ( (φ G^occ_s φ^T) ∘ (φ G^vir_s φ^T) ) Z + ! (g_s = spin degeneracy) ! ========================================================================= DO i_t = 1, bs_env%num_time_freq_points t1 = m_walltime() - tau = bs_env%imag_time_points(i_t) - CALL dbcsr_set(matrix_chi_grid, 0.0_dp) - ! ---------------------------------------------------------------------- - ! A. SPIN LOOP (Allocations safely encapsulated in wrappers) - ! ---------------------------------------------------------------------- DO ispin = 1, bs_env%n_spin - ! G^occ_µλ(i|τ|) = sum_n^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - ! G^occ_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') - CALL build_G_grid(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, & - matrix_G_occ_grid, bs_env%eps_filter) + ! AO-space Green's functions G^occ_µν, G^vir_µν (dense AO x AO, small) + CALL build_G_ao(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_G_occ_ao) + CALL build_G_ao(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, matrix_G_vir_ao) - ! G^vir_µλ(i|τ|) = sum_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - ! G^vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^vir_µν Φ_ν(r_l') - CALL build_G_grid(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, & - matrix_G_vir_grid, bs_env%eps_filter) + ! χ_PQ += g_s · Z^T ( (φ G^occ φ^T) ∘ (φ G^vir φ^T) ) Z + CALL contract_grid_panels(L_A=mat_phi_mu_l, M_A=matrix_G_occ_ao, & + L_B=mat_phi_mu_l, M_B=matrix_G_vir_ao, & + L_out=mat_Z_lP, mat_out=mat_chi_Gamma_tau(i_t)%matrix, & + scale=bs_env%spin_degeneracy, eps=bs_env%eps_filter, & + para_env=bs_env%para_env, & + pan_first=pan_first, pan_last=pan_last, & + lb_eq_la=.TRUE., lout_eq_la=.FALSE., & + zero_out=(ispin == 1), & + keep_sparsity=bs_env%ri_rs%keep_sparsity_rirs, & + centroids=bs_env%ri_rs%chunk_centroids, & + cutoff=bs_env%ri_rs%cutoff_radius_v_w, & + grid_occupation=grid_occ) - ! ------------------------------------------------------------------- - ! B. ELEMENT-WISE HADAMARD PRODUCT - ! ------------------------------------------------------------------- - ! χ_ll'(iτ) = G^occ_ll'(i|τ|) * G^vir_ll'(i|τ|) - CALL hadamard_product(matrix_G_occ_grid, matrix_G_vir_grid, matrix_chi_grid_spin, bs_env%spin_degeneracy) - - ! Accumulate spin contributions - CALL dbcsr_add(matrix_chi_grid, matrix_chi_grid_spin, 1.0_dp, 1.0_dp) + CALL dbcsr_release(matrix_G_occ_ao) + CALL dbcsr_release(matrix_G_vir_ao) END DO ! ispin - ! ---------------------------------------------------------------------- - ! C. TRANSFORM TO AUXILIARY BASIS & EXPORT DIRECTLY - ! χ_aux = Z^T * χ_grid * Z - ! χ_PQ(iτ) = sum_ll' Z_lP χ_ll'(iτ) Z_l'Q - ! Result is dumped into the final array mat_chi_Gamma_tau! - ! ---------------------------------------------------------------------- - CALL contract_A_B_A("T", "N", mat_Z_lP, matrix_chi_grid, & - mat_chi_Gamma_tau(i_t)%matrix, bs_env%eps_filter) + ! Sparsity reports + IF (i_t == 1 .AND. bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(A)') ' ' + WRITE (bs_env%unit_nr, '(T2,A,F17.2,A)') & + 'Occupation of non-zero elements of G(l,l''), χ(l,l''), W(l,l'')', & + grid_occ*100.0_dp, ' %' + WRITE (bs_env%unit_nr, '(A)') ' ' + CALL m_flush(bs_env%unit_nr) + END IF + IF (i_t == 1) then + CALL print_matrix_occupation(mat_chi_Gamma_tau(i_t)%matrix, 'χ(P,Q)', & + bs_env%para_env, bs_env%unit_nr) + end if IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,I13,A,I3,A,F7.1,A)') & @@ -1537,16 +2299,6 @@ CONTAINS END DO ! i_t - ! ========================================================================= - ! 3. FINAL CLEANUP - ! ========================================================================= - CALL dbcsr_release(matrix_G_occ_grid) - CALL dbcsr_release(matrix_G_vir_grid) - CALL dbcsr_release(matrix_chi_grid) - CALL dbcsr_release(matrix_chi_grid_spin) - CALL dbcsr_distribution_release(dist_grid_grid) - DEALLOCATE (dist_col_grid) - IF (bs_env%unit_nr > 0) WRITE (bs_env%unit_nr, '(A)') ' ' CALL timestop(handle) @@ -1554,115 +2306,1488 @@ CONTAINS END SUBROUTINE get_mat_chi_Gamma_tau ! ************************************************************************************************** -!> \brief Computes Green's Function in grid basis +!> \brief Prints the non-zero occupation percentage of a DBCSR matrix on one line. +!> \param matrix ... +!> \param label ... +!> \param para_env ... +!> \param unit_nr ... +! ************************************************************************************************** + SUBROUTINE print_matrix_occupation(matrix, label, para_env, unit_nr) + + TYPE(dbcsr_type), INTENT(IN) :: matrix + CHARACTER(LEN=*), INTENT(IN) :: label + TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env + INTEGER, INTENT(IN) :: unit_nr + CHARACTER(LEN=*), PARAMETER :: routineN = 'print_matrix_occupation' + + INTEGER :: handle + + REAL(KIND=dp) :: frac_2p31, max_loc, occ + + CALL timeset(routineN, handle) + + occ = dbcsr_get_occupation(matrix) + max_loc = REAL(dbcsr_get_data_size(matrix), dp) + CALL para_env%max(max_loc) + + IF (unit_nr > 0) THEN + frac_2p31 = max_loc/REAL(dbcsr_msg_elem_limit, dp) + WRITE (unit_nr, '(A)') ' ' + WRITE (unit_nr, '(T2,A,F36.2,A)') & + 'Occupation of non-zero elements of '//TRIM(label), occ*100.0_dp, ' %' + IF (frac_2p31 > 0.5_dp) then + WRITE (unit_nr, '(T4,A)') '*** WARNING: max/rank approaching 2^31 -- DBCSR overflow risk ***' + end if + CALL m_flush(unit_nr) + END IF + + CALL timestop(handle) + + END SUBROUTINE print_matrix_occupation + +! ************************************************************************************************** +!> \brief Marks the grid blocks whose centroid lies within cutoff of the bounding box of the +!> panel [blk0, blk1]'s chunk centroids. +!> \param centroids ... +!> \param blk0 ... +!> \param blk1 ... +!> \param cutoff ... +!> \param used ... +! ************************************************************************************************** + SUBROUTINE mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, used) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centroids + INTEGER, INTENT(IN) :: blk0, blk1 + REAL(KIND=dp), INTENT(IN) :: cutoff + LOGICAL, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: used + CHARACTER(LEN=*), PARAMETER :: routineN = 'mask_grid_blocks_near_panel' + + INTEGER :: handle + INTEGER :: c, k + REAL(KIND=dp) :: cutoff2, d2, dx + REAL(KIND=dp), DIMENSION(3) :: hi, lo + + CALL timeset(routineN, handle) + + cutoff2 = cutoff**2 + lo(:) = MINVAL(centroids(:, blk0:blk1), DIM=2) + hi(:) = MAXVAL(centroids(:, blk0:blk1), DIM=2) + + ALLOCATE (used(SIZE(centroids, 2))) + DO c = 1, SIZE(centroids, 2) + d2 = 0.0_dp + DO k = 1, 3 + dx = MAX(0.0_dp, lo(k) - centroids(k, c), centroids(k, c) - hi(k)) + d2 = d2 + dx*dx + END DO + used(c) = (d2 <= cutoff2) + END DO + + CALL timestop(handle) + + END SUBROUTINE mask_grid_blocks_near_panel + +! ************************************************************************************************** +!> \brief Exact allocated-element count of the geo template of panel [blk0, blk1]: the very same +!> per-block-pair centroid test as build_geo_template_panel, so this is the true DBCSR +!> data size of A_pan/B_pan/C_pan (DBCSR stores whole blocks). +!> \param r_blk_sizes ... +!> \param centroids ... +!> \param used ... +!> \param blk0 ... +!> \param blk1 ... +!> \param cutoff ... +!> \param nze_tmpl ... +! ************************************************************************************************** + SUBROUTINE panel_template_elems(r_blk_sizes, centroids, used, blk0, blk1, cutoff, nze_tmpl) + + INTEGER, DIMENSION(:), INTENT(IN) :: r_blk_sizes + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centroids + LOGICAL, DIMENSION(:), INTENT(IN) :: used + INTEGER, INTENT(IN) :: blk0, blk1 + REAL(KIND=dp), INTENT(IN) :: cutoff + INTEGER(KIND=int_8), INTENT(OUT) :: nze_tmpl + CHARACTER(LEN=*), PARAMETER :: routineN = 'panel_template_elems' + + INTEGER :: handle + INTEGER :: c, ib, n_used + INTEGER, ALLOCATABLE, DIMENSION(:) :: used_idx + REAL(KIND=dp) :: cutoff2 + + CALL timeset(routineN, handle) + + ! Compress the near mask once so the pair loop only visits candidate columns. + n_used = COUNT(used) + ALLOCATE (used_idx(n_used)) + n_used = 0 + DO c = 1, SIZE(used) + IF (used(c)) THEN + n_used = n_used + 1 + used_idx(n_used) = c + END IF + END DO + + cutoff2 = cutoff**2 + nze_tmpl = 0_int_8 + !$OMP PARALLEL DO DEFAULT(NONE) SHARED(blk0, blk1, n_used, used_idx, centroids, cutoff2, & + !$OMP r_blk_sizes) PRIVATE(ib, c) REDUCTION(+:nze_tmpl) + DO ib = blk0, blk1 + DO c = 1, n_used + IF (SUM((centroids(:, ib) - centroids(:, used_idx(c)))**2) <= cutoff2) then + nze_tmpl = nze_tmpl + INT(r_blk_sizes(ib), int_8)*INT(r_blk_sizes(used_idx(c)), int_8) + end if + END DO + END DO + !$OMP END PARALLEL DO + + CALL timestop(handle) + + END SUBROUTINE panel_template_elems + +! ************************************************************************************************** +!> \brief Per-rank peak memory (GB) of one panel step of the neighborhood-restricted +!> contractions: three grid x grid panels of the template size (A_pan, B_pan, C_pan) +!> plus the grid x RI intermediates (tmp2 and the accumulation operand) and the +!> grid x AO intermediate (tmpA), whose column support is the panel's geometric +!> neighborhood fraction f_near = width/n_grid. Shared by the panel planner and +!> \param nze_tmpl ... +!> \param pan_rows ... +!> \param width ... +!> \param n_grid_total ... +!> \param n_RI ... +!> \param n_ao ... +!> \param n_procs ... +!> \param mem_GB ... +! ************************************************************************************************** + SUBROUTINE panel_mem_estimate_GB(nze_tmpl, pan_rows, width, n_grid_total, n_RI, n_ao, & + n_procs, mem_GB) + + INTEGER(KIND=int_8), INTENT(IN) :: nze_tmpl + INTEGER, INTENT(IN) :: pan_rows, width, n_grid_total, n_RI, & + n_ao, n_procs + REAL(KIND=dp), INTENT(OUT) :: mem_GB + + REAL(KIND=dp) :: f_near + + f_near = REAL(width, dp)/REAL(MAX(n_grid_total, 1), dp) + mem_GB = (3.0_dp*REAL(nze_tmpl, dp) + & + REAL(pan_rows, dp)*f_near*(2.0_dp*REAL(n_RI, dp) + REAL(n_ao, dp)))* & + 8.0_dp/REAL(MAX(n_procs, 1), dp)*1.0E-9_dp + + END SUBROUTINE panel_mem_estimate_GB + +! ************************************************************************************************** +!> \brief Plans the panel boundaries for the streaming contractions. Panels grow by whole grid +!> row-blocks towards ~panel_size rows. When the neighborhood restriction is active +!> (centroids+cutoff), each candidate panel is additionally checked against +!> (a) the 32-bit message bound with the panel's TRUE occupancy +!> (b) the per-rank memory budget: panel_mem_estimate_GB <= mem_budget_GB. +!> \param r_blk_sizes ... +!> \param panel_size ... +!> \param min_dim ... +!> \param pan_first ... +!> \param pan_last ... +!> \param centroids ... +!> \param cutoff ... +!> \param n_RI ... +!> \param n_ao ... +!> \param n_procs ... +!> \param mem_budget_GB ... +! ************************************************************************************************** + SUBROUTINE plan_grid_panels(r_blk_sizes, panel_size, min_dim, pan_first, pan_last, & + centroids, cutoff, n_RI, n_ao, n_procs, mem_budget_GB, & + honor_exact, unsafe) + + INTEGER, DIMENSION(:), INTENT(IN) :: r_blk_sizes + INTEGER, INTENT(IN) :: panel_size, min_dim + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: pan_first, pan_last + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), OPTIONAL :: centroids + REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff + INTEGER, INTENT(IN), OPTIONAL :: n_RI, n_ao, n_procs + REAL(KIND=dp), INTENT(IN), OPTIONAL :: mem_budget_GB + LOGICAL, INTENT(IN), OPTIONAL :: honor_exact + LOGICAL, INTENT(OUT), OPTIONAL :: unsafe + CHARACTER(LEN=*), PARAMETER :: routineN = 'plan_grid_panels' + + INTEGER :: blk0, blk1, ib, n_grid_blocks, & + n_grid_total, n_panels, rows_acc, & + target, width + INTEGER(KIND=int_8) :: msg, nze_tmpl, side + INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_first, tmp_last + LOGICAL :: fits, my_honor_exact, my_unsafe, & + use_cutoff + LOGICAL, ALLOCATABLE, DIMENSION(:) :: used + REAL(KIND=dp) :: f_near, mem_GB + INTEGER :: handle + + CALL timeset(routineN, handle) + + use_cutoff = PRESENT(centroids) .AND. PRESENT(cutoff) + IF (use_cutoff) use_cutoff = cutoff > 0.0_dp + IF (use_cutoff) THEN + CPASSERT(PRESENT(n_RI) .AND. PRESENT(n_ao) .AND. PRESENT(n_procs)) + END IF + + ! honor_exact: use N_PANELS as requested -- do NOT split a panel further even if it trips + ! the message-overflow / memory-budget check; instead flag `unsafe` so the caller can warn. + my_honor_exact = .FALSE. + IF (PRESENT(honor_exact)) my_honor_exact = honor_exact + my_unsafe = .FALSE. + + n_grid_blocks = SIZE(r_blk_sizes) + n_grid_total = SUM(r_blk_sizes) + ALLOCATE (tmp_first(n_grid_blocks), tmp_last(n_grid_blocks)) + + n_panels = 0 + blk0 = 1 + DO WHILE (blk0 <= n_grid_blocks) + target = panel_size + DO + rows_acc = 0 + blk1 = blk0 + DO ib = blk0, n_grid_blocks + rows_acc = rows_acc + r_blk_sizes(ib) + blk1 = ib + IF (rows_acc >= target) EXIT + END DO + IF (.NOT. use_cutoff .OR. blk1 == blk0) EXIT + CALL mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, used) + width = SUM(r_blk_sizes, MASK=used) + CALL panel_template_elems(r_blk_sizes, centroids, used, blk0, blk1, cutoff, nze_tmpl) + f_near = REAL(width, dp)/REAL(MAX(n_grid_total, 1), dp) + side = INT(REAL(rows_acc, dp)*f_near*REAL(MAX(n_RI, n_ao), dp), int_8) + msg = MAX(nze_tmpl, side)/INT(MAX(min_dim, 1), int_8) + fits = (msg <= dbcsr_msg_elem_limit/4) + IF (fits .AND. PRESENT(mem_budget_GB)) THEN + IF (mem_budget_GB > 0.0_dp) THEN + CALL panel_mem_estimate_GB(nze_tmpl, rows_acc, width, n_grid_total, & + n_RI, n_ao, n_procs, mem_GB) + fits = (mem_GB <= mem_budget_GB) + END IF + END IF + ! Panel size is bounded only by the message-overflow and memory checks above; there is + ! no neighborhood-width (f_near) cap. mp_waitall is dominated by the NUMBER of panel + ! multiplies, so fewer/larger panels are cheaper here -- panel count is driven DOWN by + ! the N_PANELS keyword (panel_size), not split up by a width heuristic. + IF (my_honor_exact) THEN + ! Keep exactly the requested grouping; just record if it exceeds a safety limit. + IF (.NOT. fits) my_unsafe = .TRUE. + EXIT + END IF + IF (fits) EXIT + target = MAX(1, MIN(target, rows_acc)/2) + END DO + n_panels = n_panels + 1 + tmp_first(n_panels) = blk0 + tmp_last(n_panels) = blk1 + blk0 = blk1 + 1 + END DO + + ALLOCATE (pan_first(n_panels), pan_last(n_panels)) + pan_first(:) = tmp_first(1:n_panels) + pan_last(:) = tmp_last(1:n_panels) + DEALLOCATE (tmp_first, tmp_last) + + IF (PRESENT(unsafe)) unsafe = my_unsafe + + CALL timestop(handle) + + END SUBROUTINE plan_grid_panels + +! ************************************************************************************************** +!> \brief Resolves the panel boundaries for the streaming contractions from the bs_env settings: +!> \param bs_env ... +!> \param mat_phi_mu_l ... +!> \param pan_first ... +!> \param pan_last ... +! ************************************************************************************************** + SUBROUTINE resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(dbcsr_type), INTENT(INOUT) :: mat_phi_mu_l + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: pan_first, pan_last + CHARACTER(LEN=*), PARAMETER :: routineN = 'resolve_grid_panels' + + INTEGER :: min_dim, n_grid_total, n_panels_req, & + npcols, nprows, panel_size, safe_max + INTEGER, DIMENSION(:), POINTER :: r_blk_sizes + LOGICAL :: honor_exact, panels_unsafe, use_cutoff + REAL(KIND=dp) :: mem_avail_GB, mem_budget_GB + TYPE(dbcsr_distribution_type) :: dist + INTEGER :: handle + + CALL timeset(routineN, handle) + + IF (ALLOCATED(bs_env%ri_rs%pan_first)) THEN + ALLOCATE (pan_first, SOURCE=bs_env%ri_rs%pan_first) + ALLOCATE (pan_last, SOURCE=bs_env%ri_rs%pan_last) + CALL timestop(handle) + RETURN + END IF + + use_cutoff = bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp .AND. & + ALLOCATED(bs_env%ri_rs%chunk_centroids) + + ! MIN(nprows, npcols) is the divisor that bounds the worst-rank Cannon message: a + ! P x n_grid panel is replicated into block row strips (P/nprows x n_grid) or column + ! strips (P x n_grid/npcols) during multiply_cannon, so the largest single-rank + ! message is ~ P*n_grid / MIN(nprows,npcols) elements. + CALL dbcsr_get_info(mat_phi_mu_l, nfullrows_total=n_grid_total, row_blk_size=r_blk_sizes, & + distribution=dist) + CALL dbcsr_distribution_get(dist, nprows=nprows, npcols=npcols) + min_dim = MAX(MIN(nprows, npcols), 1) + + ! Panel height such that NO per-rank DBCSR message can overflow the 32-bit length field + ! (see dbcsr_msg_elem_limit): requiring the worst-rank message to stay under + ! 0.5 * HUGE(int_4) gives the safe height P_safe = 0.5 * HUGE(int_4) * min_dim / n_grid. + IF (use_cutoff) THEN + safe_max = n_grid_total + ELSE + safe_max = INT(0.5_dp*REAL(dbcsr_msg_elem_limit, dp)*REAL(min_dim, dp)/ & + REAL(n_grid_total, dp)) + safe_max = MAX(1, MIN(safe_max, n_grid_total)) + END IF + + ! A user-set N_PANELS ( > 1 ) is honored EXACTLY: the planner produces that many panels + ! (up to grid-block granularity) and never force-splits them for the message/memory safety + ! limits -- if a limit is tripped it warns instead of silently changing the count. + n_panels_req = bs_env%ri_rs%n_panels + honor_exact = (n_panels_req > 1) + panels_unsafe = .FALSE. + IF (n_panels_req > 1) THEN + ! ceil(n_grid/n_panels_req) rows per panel => exactly n_panels_req panels. With the + ! cutoff active safe_max = n_grid_total (no clamp, honored exactly); without it, safe_max + ! is the int32-overflow ceiling and MUST still bound the panel (the non-cutoff planner + ! loop has no in-loop message-size check). + panel_size = MIN((n_grid_total + n_panels_req - 1)/n_panels_req, safe_max) + ELSE + ! Default (<= 1): a single whole-grid panel, clamped to the overflow-safe ceiling. + panel_size = safe_max + END IF + panel_size = MAX(1, panel_size) + + IF (use_cutoff) THEN + ! Half of the measured free memory as panel budget. + CALL ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) + mem_budget_GB = 0.5_dp*mem_avail_GB + CALL plan_grid_panels(r_blk_sizes, panel_size, min_dim, pan_first, pan_last, & + centroids=bs_env%ri_rs%chunk_centroids, & + cutoff=bs_env%ri_rs%cutoff_radius_v_w, & + n_RI=bs_env%n_RI, n_ao=bs_env%n_ao, & + n_procs=bs_env%para_env%num_pe, mem_budget_GB=mem_budget_GB, & + honor_exact=honor_exact, unsafe=panels_unsafe) + ELSE + CALL plan_grid_panels(r_blk_sizes, panel_size, min_dim, pan_first, pan_last) + END IF + + IF (honor_exact .AND. panels_unsafe .AND. bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,I0,A)') & + '*** WARNING: N_PANELS = ', n_panels_req, ' used as requested, but one or more '// & + 'panels exceed the DBCSR 32-bit message / memory-budget safety limit. The run may '// & + 'abort or swap; increase N_PANELS if it does. ***' + END IF + + ALLOCATE (bs_env%ri_rs%pan_first, SOURCE=pan_first) + ALLOCATE (bs_env%ri_rs%pan_last, SOURCE=pan_last) + + CALL timestop(handle) + + END SUBROUTINE resolve_grid_panels + +! ************************************************************************************************** +!> \brief Available memory per MPI process (GB). /proc/meminfo reports node-wide memory, so +!> every rank on a node reads the SAME MemLikelyFree; the per-process share is +!> node_free / ranks_per_node (ranks grouped by a hostname hash exchanged via allgather). +!> Returns the MIN across all ranks (most-constrained node) +!> \param bs_env ... +!> \param mem_avail_GB ... +! ************************************************************************************************** + SUBROUTINE ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp), INTENT(OUT) :: mem_avail_GB + CHARACTER(LEN=*), PARAMETER :: routineN = 'ri_rs_mem_avail_per_proc_GB' + + CHARACTER(LEN=default_string_length) :: hostname + INTEGER :: host_hash, ic, n_procs, ranks_per_node + INTEGER, ALLOCATABLE, DIMENSION(:) :: all_host_hashes + INTEGER(KIND=int_8) :: h8, mem_buffers, mem_cached, mem_free, & + mem_likely_free, mem_sreclaimable, & + mem_slab, mem_total + INTEGER :: handle + + CALL timeset(routineN, handle) + + n_procs = bs_env%para_env%num_pe + CALL m_hostnm(hostname) + h8 = 0_int_8 + DO ic = 1, LEN_TRIM(hostname) + h8 = MOD(h8*127_int_8 + INT(ICHAR(hostname(ic:ic)), int_8), 2147483647_int_8) + END DO + host_hash = INT(h8) + ALLOCATE (all_host_hashes(n_procs)) + CALL bs_env%para_env%allgather(host_hash, all_host_hashes) + ranks_per_node = MAX(COUNT(all_host_hashes == host_hash), 1) + DEALLOCATE (all_host_hashes) + + CALL m_memory_details(MemTotal=mem_total, MemFree=mem_free, Buffers=mem_buffers, & + Cached=mem_cached, Slab=mem_slab, SReclaimable=mem_sreclaimable, & + MemLikelyFree=mem_likely_free) + mem_avail_GB = REAL(mem_likely_free, dp)*1.0E-9_dp/REAL(ranks_per_node, dp) + CALL bs_env%para_env%min(mem_avail_GB) + + CALL timestop(handle) + + END SUBROUTINE ri_rs_mem_avail_per_proc_GB + +! ************************************************************************************************** +!> \brief Estimates and prints per-process memory requirements for the RI-RS GW calculation. +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE print_ri_rs_memory_estimate(qs_env, bs_env) + +!$ USE OMP_LIB, ONLY: omp_get_max_threads + + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'print_ri_rs_memory_estimate' + + INTEGER :: handle, iatom, ipan, l, & + max_n_local_grid, & + n_ao_total, n_grid_total, & + n_local_grid, n_loc_ri_max, n_procs, & + n_procs_per_atom, n_RI, n_threads, & + natom, pan_rows, pan_width + INTEGER(KIND=int_8) :: nze_tmpl + INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last + INTEGER, DIMENSION(:), POINTER :: r_blk_sizes + LOGICAL :: use_cutoff + LOGICAL, ALLOCATABLE, DIMENSION(:) :: grid_used + REAL(KIND=dp) :: cutoff_ri, mem_avail_GB, mem_D_local_GB, & + mem_dlp_GB, mem_pan_GB, mem_panels_GB, & + mem_phi_local_GB, mem_Z_lP_GB, & + mem_Zlp_peak_GB, pos_P(3) + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + + CALL timeset(routineN, handle) + + CALL dbcsr_get_info(bs_env%ri_rs%mat_phi_mu_l, nfullrows_total=n_grid_total, & + row_blk_size=r_blk_sizes) + n_RI = bs_env%n_RI + n_procs = bs_env%para_env%num_pe + + ! Z_lP upper bound: dense n_grid × n_RI, distributed evenly across all ranks. + ! The actual sparse Z_lP is smaller due to the per-atom locality cutoff. + mem_Z_lP_GB = REAL(n_grid_total, dp)*REAL(n_RI, dp)*8.0_dp/ & + REAL(n_procs, dp)*1.0E-9_dp + + ! Peak panel memory during Σ^c: two G panels (A_occ, A_vir) + one W panel plus the + ! grid × RI / grid × AO intermediates. With the CUTOFF_RADIUS_RL_W restriction the panel + ! matrices only allocate the geo-template blocks, so use the same nze-aware model as the + ! panel planner (panel_mem_estimate_GB); without the cutoff, dense panel_rows × n_grid. + ! Plus the n_RI × n_RI W_aux matrix. Distributed over n_procs ranks. + use_cutoff = bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp .AND. & + ALLOCATED(bs_env%ri_rs%chunk_centroids) + CALL resolve_grid_panels(bs_env, bs_env%ri_rs%mat_phi_mu_l, pan_first, pan_last) + mem_panels_GB = 0.0_dp + DO ipan = 1, SIZE(pan_first) + pan_rows = SUM(r_blk_sizes(pan_first(ipan):pan_last(ipan))) + IF (use_cutoff) THEN + CALL mask_grid_blocks_near_panel(bs_env%ri_rs%chunk_centroids, pan_first(ipan), & + pan_last(ipan), bs_env%ri_rs%cutoff_radius_v_w, & + grid_used) + pan_width = SUM(r_blk_sizes, MASK=grid_used) + CALL panel_template_elems(r_blk_sizes, bs_env%ri_rs%chunk_centroids, & + grid_used, pan_first(ipan), pan_last(ipan), & + bs_env%ri_rs%cutoff_radius_v_w, nze_tmpl) + CALL panel_mem_estimate_GB(nze_tmpl, pan_rows, pan_width, n_grid_total, & + n_RI, bs_env%n_ao, n_procs, mem_pan_GB) + ELSE + pan_width = n_grid_total + mem_pan_GB = (3.0_dp*REAL(pan_rows, dp)*REAL(pan_width, dp) + & + 2.0_dp*REAL(pan_rows, dp)*REAL(n_RI, dp))* & + 8.0_dp/REAL(n_procs, dp)*1.0E-9_dp + END IF + mem_panels_GB = MAX(mem_panels_GB, mem_pan_GB) + END DO + mem_panels_GB = mem_panels_GB + & + REAL(n_RI, dp)*REAL(n_RI, dp)*8.0_dp/REAL(n_procs, dp)*1.0E-9_dp + + ! Z_lP SOLVE peak (compute_coeff_Z_lP). For the atom P with the largest integration + ! sphere, one rank holds simultaneously: + ! D_local : n_local_grid x n_local_grid (dense Gram, BLAS path only; O(n_local_grid^2)) + ! phi_local: n_local_grid x n_ao_total + ! d_lp : n_local_grid x n_loc_ri, replicated once + one private copy per OMP thread + ! n_local_grid = # grid points within cutoff_ri(P) = CUTOFF_RADIUS_RL_RI (if > 0) else + ! r_c(RI metric) + r_RI(P). This is NOT evenly distributed: n_local_grid depends on the + ! local density of atoms/grid, so the rank owning the densest atom peaks well above the + ! average. We report the worst-case (max over atoms) as a per-rank upper bound. + CALL get_qs_env(qs_env, particle_set=particle_set) + natom = SIZE(particle_set) + n_ao_total = bs_env%i_ao_end_from_atom(natom) + + max_n_local_grid = 0 + n_loc_ri_max = 0 + DO iatom = 1, natom + IF (bs_env%ri_rs%cutoff_radius_ri_rs > 0.0_dp) THEN + cutoff_ri = bs_env%ri_rs%cutoff_radius_ri_rs + ELSE + cutoff_ri = bs_env%ri_metric%cutoff_radius + bs_env%ri_rs%radius_ri_per_atom(iatom) + END IF + pos_P(:) = particle_set(iatom)%r(:) + n_local_grid = 0 + DO l = 1, n_grid_total + IF (SUM((bs_env%ri_rs%grid_points(1:3, l) - pos_P(1:3))**2) <= cutoff_ri**2) then + n_local_grid = n_local_grid + 1 + end if + END DO + max_n_local_grid = MAX(max_n_local_grid, n_local_grid) + n_loc_ri_max = MAX(n_loc_ri_max, & + bs_env%i_RI_end_from_atom(iatom) - bs_env%i_RI_start_from_atom(iatom) + 1) + END DO + + n_procs_per_atom = MIN(MAX(bs_env%ri_rs%n_procs_per_atom_z_lp, 1), n_procs) + n_threads = 1 +!$ n_threads = omp_get_max_threads() + + ! D_local: dense on one rank for the BLAS path; block-cyclic over the subgroup (=> /G) for + ! the ScaLAPACK path (N_PROCS_PER_ATOM_Z_LP = G > 1). phi_local/d_lp stay per-rank either way. + IF (n_procs_per_atom > 1) THEN + mem_D_local_GB = REAL(max_n_local_grid, dp)**2*8.0_dp/REAL(n_procs_per_atom, dp)*1.0E-9_dp + ELSE + mem_D_local_GB = REAL(max_n_local_grid, dp)**2*8.0_dp*1.0E-9_dp + END IF + mem_phi_local_GB = REAL(max_n_local_grid, dp)*REAL(n_ao_total, dp)*8.0_dp*1.0E-9_dp + mem_dlp_GB = REAL(max_n_local_grid, dp)*REAL(n_loc_ri_max, dp)*8.0_dp* & + REAL(1 + n_threads, dp)*1.0E-9_dp + mem_Zlp_peak_GB = mem_D_local_GB + mem_phi_local_GB + mem_dlp_GB + + ! Available memory per process = node MemLikelyFree / ranks-per-node, min across ranks + ! (0 on non-Linux => warnings suppressed below). + CALL ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(A)') ' ' + WRITE (bs_env%unit_nr, '(T2,A)') 'RI-RS memory estimate per MPI process:' + WRITE (bs_env%unit_nr, '(T4,A,F37.2,A)') & + 'Available memory per process (system)', mem_avail_GB, ' GB' + WRITE (bs_env%unit_nr, '(T4,A,F18.2,A)') & + 'Required for Z_lP (dense upper bound; actual is sparser)', mem_Z_lP_GB, ' GB' + WRITE (bs_env%unit_nr, '(T4,A,F25.2,A)') & + 'Required for χ, W, Σ panels (peak per panel step)', mem_panels_GB, ' GB' + WRITE (bs_env%unit_nr, '(T4,A,F17.2,A)') & + 'Required for Z_lP solve peak (D_local+φ, worst-case atom)', mem_Zlp_peak_GB, ' GB' + WRITE (bs_env%unit_nr, '(T6,A,I21,A,F10.2,A)') & + 'worst-case n_local_grid', max_n_local_grid, ' points (D_local', mem_D_local_GB, ' GB)' + WRITE (bs_env%unit_nr, '(A)') ' ' + + IF (mem_avail_GB > 0.0_dp .AND. mem_Z_lP_GB > mem_avail_GB) THEN + WRITE (bs_env%unit_nr, '(T2,A)') & + '*** WARNING: Estimated Z_lP memory exceeds available memory per process ***' + WRITE (bs_env%unit_nr, '(T4,A,F6.2,A,F6.2,A)') & + 'Z_lP upper bound: ', mem_Z_lP_GB, ' GB > available: ', mem_avail_GB, ' GB' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'Z_lP (n_grid × n_RI) is distributed across all MPI ranks. To reduce per-rank' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'memory: add more nodes, use fewer MPI ranks per node, or increase' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'N_PROCS_PER_ATOM_Z_LP to distribute each atom block via ScaLAPACK (reduces' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'per-rank memory by ~1/G where G = N_PROCS_PER_ATOM_Z_LP).' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + IF (mem_avail_GB > 0.0_dp .AND. mem_panels_GB > mem_avail_GB) THEN + WRITE (bs_env%unit_nr, '(T2,A)') & + '*** WARNING: Estimated χ/W/Σ panel memory exceeds available memory per process ***' + WRITE (bs_env%unit_nr, '(T4,A,F6.2,A,F6.2,A)') & + 'Panel peak estimate: ', mem_panels_GB, ' GB > available: ', mem_avail_GB, ' GB' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'Panel memory scales as ~3×panel_size×n_grid / n_procs. Options:' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' - More nodes or fewer MPI ranks per node (increases n_procs, reduces share)' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' - Increase N_PANELS (more, smaller panels → less peak memory per step)' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + IF (mem_avail_GB > 0.0_dp .AND. mem_Zlp_peak_GB > mem_avail_GB) THEN + WRITE (bs_env%unit_nr, '(T2,A)') & + '*** WARNING: Estimated Z_lP solve peak exceeds available memory per process ***' + WRITE (bs_env%unit_nr, '(T4,A,F8.2,A,F8.2,A)') & + 'Z_lP solve peak: ', mem_Zlp_peak_GB, ' GB > available: ', mem_avail_GB, ' GB' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'The per-atom Gram matrix D_local(n_local_grid, n_local_grid) dominates and scales' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'as n_local_grid^2. It is NOT balanced across ranks (the rank owning the atom with' + WRITE (bs_env%unit_nr, '(T4,A)') & + 'the largest integration sphere peaks well above the average). Options:' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' - Increase N_PROCS_PER_ATOM_Z_LP=G to distribute D_local block-cyclic via' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' ScaLAPACK (reduces the D_local term by ~1/G; no accuracy loss)' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' - Reduce the RI-RS sphere cutoff (CUTOFF_RADIUS_RL_RI): D_local shrinks as' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' n_local_grid^2, but this trades accuracy' + WRITE (bs_env%unit_nr, '(T4,A)') & + ' - Fewer MPI ranks per node (more memory per rank for the peak atom)' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + END IF + + CALL timestop(handle) + + END SUBROUTINE print_ri_rs_memory_estimate + +! ************************************************************************************************** +!> \brief Creates an empty (panel_chunks x neighborhood_chunks) DBCSR matrix with zero blocks +!> pre-allocated only where |centroid(panel_row r) - centroid(column c)| <= cutoff. +!> Used with retain_sparsity=.TRUE. in the subsequent dbcsr_multiply so distant blocks +!> of the grid-basis panels (φ G φ^T, Z W Z^T, ...) are never computed at all. +!> \param L_pan ... +!> \param L_full ... +!> \param centroids ... +!> \param cutoff ... +!> \param blk0 ... +!> \param A_template ... +!> \param col_map ... +! ************************************************************************************************** + SUBROUTINE build_geo_template_panel(L_pan, L_full, centroids, cutoff, blk0, A_template, col_map) + TYPE(dbcsr_type), INTENT(IN) :: L_pan, L_full + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centroids + REAL(KIND=dp), INTENT(IN) :: cutoff + INTEGER, INTENT(IN) :: blk0 + TYPE(dbcsr_type), INTENT(OUT) :: A_template + INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: col_map + + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_geo_template_panel' + + INTEGER :: c, cg, cs, handle, my_pcol, my_prow, & + n_grid_blks, n_pan_blks, npcols, & + nprows, r, rs + INTEGER, DIMENSION(:), POINTER :: grid_blk_sizes, pan_blk_sizes + REAL(KIND=dp) :: cutoff2 + REAL(KIND=dp), ALLOCATABLE :: zero_blk(:, :) + TYPE(dbcsr_distribution_type) :: dist + + CALL timeset(routineN, handle) + + cutoff2 = cutoff**2 + CALL dbcsr_get_info(L_pan, nblkrows_total=n_pan_blks, row_blk_size=pan_blk_sizes) + CALL dbcsr_get_info(L_full, nblkrows_total=n_grid_blks, row_blk_size=grid_blk_sizes) + + ! create_product_matrix assigns row r to process MOD(r-1,nprows) and + ! col c to MOD(c-1,npcols), so we can determine local ownership analytically. + CALL create_product_matrix(L_pan, L_full, 'N', 'T', A_template) + CALL dbcsr_get_info(A_template, distribution=dist) + CALL dbcsr_distribution_get(dist, nprows=nprows, npcols=npcols, & + myprow=my_prow, mypcol=my_pcol) + + ALLOCATE (zero_blk(MAXVAL(pan_blk_sizes(1:n_pan_blks)), & + MAXVAL(grid_blk_sizes(1:n_grid_blks)))) + zero_blk(:, :) = 0.0_dp + + DO r = 1, n_pan_blks + IF (MOD(r - 1, nprows) /= my_prow) CYCLE + rs = pan_blk_sizes(r) + DO c = 1, n_grid_blks + IF (MOD(c - 1, npcols) /= my_pcol) CYCLE + cg = c + IF (PRESENT(col_map)) cg = col_map(c) + IF ((centroids(1, blk0 + r - 1) - centroids(1, cg))**2 + & + (centroids(2, blk0 + r - 1) - centroids(2, cg))**2 + & + (centroids(3, blk0 + r - 1) - centroids(3, cg))**2 <= cutoff2) THEN + cs = grid_blk_sizes(c) + CALL dbcsr_put_block(A_template, r, c, zero_blk(1:rs, 1:cs)) + END IF + END DO + END DO + CALL dbcsr_finalize(A_template) + + DEALLOCATE (zero_blk) + CALL timestop(handle) + + END SUBROUTINE build_geo_template_panel + +! ************************************************************************************************** +!> \brief Slices a contiguous range of grid row-blocks [blk0, blk1] out of a (grid x n) DBCSR +!> matrix into a new (P x n) panel matrix: iterate the source's local blocks, put the +!> in-range ones into the panel with a remapped row-block index, then finalize. Row-block +!> index i of the panel corresponds to source row-block blk0+i-1. +!> \param mat_full ... +!> \param blk0 ... +!> \param blk1 ... +!> \param mat_panel ... +! ************************************************************************************************** + SUBROUTINE extract_grid_panel(mat_full, blk0, blk1, mat_panel) + + TYPE(dbcsr_type), INTENT(INOUT) :: mat_full + INTEGER, INTENT(IN) :: blk0, blk1 + TYPE(dbcsr_type), INTENT(OUT) :: mat_panel + CHARACTER(LEN=*), PARAMETER :: routineN = 'extract_grid_panel' + + INTEGER :: ib, jb, npb + INTEGER, DIMENSION(:), POINTER :: col_blk_full, col_dist_full, & + row_blk_full, row_blk_pan, & + row_dist_full, row_dist_pan + REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk + TYPE(dbcsr_distribution_type) :: dist_full, dist_pan + TYPE(dbcsr_iterator_type) :: iter + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL dbcsr_get_info(mat_full, distribution=dist_full, & + row_blk_size=row_blk_full, col_blk_size=col_blk_full) + CALL dbcsr_distribution_get(dist_full, row_dist=row_dist_full, col_dist=col_dist_full) + + npb = blk1 - blk0 + 1 + ALLOCATE (row_dist_pan(npb), row_blk_pan(npb)) + row_dist_pan(:) = row_dist_full(blk0:blk1) + row_blk_pan(:) = row_blk_full(blk0:blk1) + + CALL dbcsr_distribution_new(dist_pan, template=dist_full, & + row_dist=row_dist_pan, col_dist=col_dist_full) + CALL dbcsr_create(mat_panel, name="grid_panel", dist=dist_pan, & + matrix_type=dbcsr_type_no_symmetry, & + row_blk_size=row_blk_pan, col_blk_size=col_blk_full) + + CALL dbcsr_iterator_start(iter, mat_full) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, ib, jb, blk) + IF (ib < blk0 .OR. ib > blk1) CYCLE + CALL dbcsr_put_block(mat_panel, ib - blk0 + 1, jb, blk) + END DO + CALL dbcsr_iterator_stop(iter) + CALL dbcsr_finalize(mat_panel) + + CALL dbcsr_distribution_release(dist_pan) + DEALLOCATE (row_dist_pan, row_blk_pan) + + CALL timestop(handle) + + END SUBROUTINE extract_grid_panel + +! ************************************************************************************************** +!> \brief Marks which column blocks of a DBCSR matrix carry at least one non-zero block anywhere +!> (global union). Used to restrict the inner index of the panel multiplies to the +!> AO/RI atoms that actually touch the panel (exact: dropped rows only meet zeros). +!> \param matrix ... +!> \param para_env ... +!> \param used ... +! ************************************************************************************************** + SUBROUTINE collect_used_col_blocks(matrix, para_env, used) + + TYPE(dbcsr_type), INTENT(INOUT) :: matrix + TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env + LOGICAL, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: used + CHARACTER(LEN=*), PARAMETER :: routineN = 'collect_used_col_blocks' + + INTEGER :: ib, jb, nblkcols + INTEGER, ALLOCATABLE, DIMENSION(:) :: iused + REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk + TYPE(dbcsr_iterator_type) :: iter + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL dbcsr_get_info(matrix, nblkcols_total=nblkcols) + ALLOCATE (iused(nblkcols)) + iused(:) = 0 + + CALL dbcsr_iterator_start(iter, matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, ib, jb, blk) + iused(jb) = 1 + END DO + CALL dbcsr_iterator_stop(iter) + + CALL para_env%sum(iused) + + ALLOCATE (used(nblkcols)) + used(:) = (iused(:) > 0) + DEALLOCATE (iused) + + CALL timestop(handle) + + END SUBROUTINE collect_used_col_blocks + +! ************************************************************************************************** +!> \brief Copies the flagged block rows (compress_rows=.TRUE.) or block columns (.FALSE.) of a +!> DBCSR matrix into a compressed matrix. The subset keeps the parent's process assignment +!> along the compressed dimension, so every block stays on its owning rank: the extraction +!> is purely local (zero communication), like extract_grid_panel. +!> \param mat_full ... +!> \param used ... +!> \param mat_out ... +!> \param compress_rows ... +!> \param blk_map ... +! ************************************************************************************************** + SUBROUTINE extract_masked_blocks(mat_full, used, mat_out, compress_rows, blk_map) + + TYPE(dbcsr_type), INTENT(INOUT) :: mat_full + LOGICAL, DIMENSION(:), INTENT(IN) :: used + TYPE(dbcsr_type), INTENT(OUT) :: mat_out + LOGICAL, INTENT(IN) :: compress_rows + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT), & + OPTIONAL :: blk_map + + CHARACTER(LEN=*), PARAMETER :: routineN = 'extract_masked_blocks' + + INTEGER :: ib, jb, n_blk, n_sub, r + INTEGER, ALLOCATABLE, DIMENSION(:) :: inv_map + INTEGER, DIMENSION(:), POINTER :: blk_full, blk_sub, col_blk_full, & + col_dist_full, dist_full_1d, & + dist_sub_1d, row_blk_full, & + row_dist_full + REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk + TYPE(dbcsr_distribution_type) :: dist_full, dist_sub + TYPE(dbcsr_iterator_type) :: iter + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL dbcsr_get_info(mat_full, distribution=dist_full, & + row_blk_size=row_blk_full, col_blk_size=col_blk_full) + CALL dbcsr_distribution_get(dist_full, row_dist=row_dist_full, col_dist=col_dist_full) + + IF (compress_rows) THEN + blk_full => row_blk_full + dist_full_1d => row_dist_full + ELSE + blk_full => col_blk_full + dist_full_1d => col_dist_full + END IF + n_blk = SIZE(blk_full) + + n_sub = COUNT(used) + CPASSERT(n_sub > 0) + ALLOCATE (inv_map(n_blk), blk_sub(n_sub), dist_sub_1d(n_sub)) + IF (PRESENT(blk_map)) ALLOCATE (blk_map(n_sub)) + inv_map(:) = 0 + r = 0 + DO ib = 1, n_blk + IF (used(ib)) THEN + r = r + 1 + inv_map(ib) = r + blk_sub(r) = blk_full(ib) + dist_sub_1d(r) = dist_full_1d(ib) + IF (PRESENT(blk_map)) blk_map(r) = ib + END IF + END DO + + IF (compress_rows) THEN + CALL dbcsr_distribution_new(dist_sub, template=dist_full, & + row_dist=dist_sub_1d, col_dist=col_dist_full) + CALL dbcsr_create(mat_out, name="row_subset", dist=dist_sub, & + matrix_type=dbcsr_type_no_symmetry, & + row_blk_size=blk_sub, col_blk_size=col_blk_full) + ELSE + CALL dbcsr_distribution_new(dist_sub, template=dist_full, & + row_dist=row_dist_full, col_dist=dist_sub_1d) + CALL dbcsr_create(mat_out, name="col_subset", dist=dist_sub, & + matrix_type=dbcsr_type_no_symmetry, & + row_blk_size=row_blk_full, col_blk_size=blk_sub) + END IF + + CALL dbcsr_iterator_start(iter, mat_full) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, ib, jb, blk) + IF (compress_rows) THEN + IF (inv_map(ib) > 0) CALL dbcsr_put_block(mat_out, inv_map(ib), jb, blk) + ELSE + IF (inv_map(jb) > 0) CALL dbcsr_put_block(mat_out, ib, inv_map(jb), blk) + END IF + END DO + CALL dbcsr_iterator_stop(iter) + CALL dbcsr_finalize(mat_out) + + CALL dbcsr_distribution_release(dist_sub) + DEALLOCATE (inv_map, blk_sub, dist_sub_1d) + + CALL timestop(handle) + + END SUBROUTINE extract_masked_blocks + +! ************************************************************************************************** +!> \brief Pre-seeds a square per-atom-blocked DBCSR matrix (G_munu, D_munu, V_PQ, W_PQ) with zero +!> blocks only for atom pairs within radius, for use with copy_fm_to_dbcsr(keep_sparsity=T): +!> the CUTOFF_RADIUS_G_W operator truncation. +!> \param matrix ... +!> \param centers ... +!> \param radius ... +! ************************************************************************************************** + SUBROUTINE reserve_blocks_within_radius(matrix, centers, radius) + + TYPE(dbcsr_type), INTENT(INOUT) :: matrix + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centers + REAL(KIND=dp), INTENT(IN) :: radius + + CHARACTER(LEN=*), PARAMETER :: routineN = 'reserve_blocks_within_radius' + + INTEGER :: handle, i, j, my_pcol, my_prow, & + nblkcols, nblkrows + INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist, row_blk, row_dist + REAL(KIND=dp) :: radius2 + REAL(KIND=dp), ALLOCATABLE :: zero_blk(:, :) + TYPE(dbcsr_distribution_type) :: dist + + CALL timeset(routineN, handle) + + CALL dbcsr_get_info(matrix, nblkrows_total=nblkrows, nblkcols_total=nblkcols, & + row_blk_size=row_blk, col_blk_size=col_blk, distribution=dist) + CALL dbcsr_distribution_get(dist, row_dist=row_dist, col_dist=col_dist, & + myprow=my_prow, mypcol=my_pcol) + CPASSERT(nblkrows == SIZE(centers, 2)) + CPASSERT(nblkcols == SIZE(centers, 2)) + + radius2 = radius**2 + ALLOCATE (zero_blk(MAXVAL(row_blk(1:nblkrows)), MAXVAL(col_blk(1:nblkcols)))) + zero_blk(:, :) = 0.0_dp + + DO i = 1, nblkrows + IF (row_dist(i) /= my_prow) CYCLE + DO j = 1, nblkcols + IF (col_dist(j) /= my_pcol) CYCLE + IF ((centers(1, i) - centers(1, j))**2 + (centers(2, i) - centers(2, j))**2 + & + (centers(3, i) - centers(3, j))**2 <= radius2) THEN + CALL dbcsr_put_block(matrix, i, j, zero_blk(1:row_blk(i), 1:col_blk(j))) + END IF + END DO + END DO + CALL dbcsr_finalize(matrix) + + DEALLOCATE (zero_blk) + CALL timestop(handle) + + END SUBROUTINE reserve_blocks_within_radius + +! ************************************************************************************************** +!> \brief Creates the (empty) result matrix of op(mat_left) * op(mat_right) with the correct block +!> structure and a distribution on the shared process grid, ready to be filled by +!> dbcsr_multiply. Row structure comes from op(left), column structure from op(right). +!> \param mat_left ... +!> \param mat_right ... +!> \param transa 'N' or 'T' applied to mat_left +!> \param transb 'N' or 'T' applied to mat_right +!> \param mat_out ... +! ************************************************************************************************** + SUBROUTINE create_product_matrix(mat_left, mat_right, transa, transb, mat_out) + + TYPE(dbcsr_type), INTENT(IN) :: mat_left, mat_right + CHARACTER(LEN=1), INTENT(IN) :: transa, transb + TYPE(dbcsr_type), INTENT(OUT) :: mat_out + CHARACTER(LEN=*), PARAMETER :: routineN = 'create_product_matrix' + + INTEGER :: i, npcols, nprows + INTEGER, DIMENSION(:), POINTER :: col_blk_l, col_blk_r, out_col_blk, & + out_col_dist, out_row_blk, out_row_dist, & + row_blk_l, row_blk_r + TYPE(dbcsr_distribution_type) :: dist_l, dist_out + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL dbcsr_get_info(mat_left, distribution=dist_l, row_blk_size=row_blk_l, col_blk_size=col_blk_l) + CALL dbcsr_get_info(mat_right, row_blk_size=row_blk_r, col_blk_size=col_blk_r) + CALL dbcsr_distribution_get(dist_l, nprows=nprows, npcols=npcols) + + ! block SIZES follow op(left)/op(right); DISTRIBUTIONS are freshly round-robined onto the + ! shared process grid (a transposed operand's row-dist is NOT a valid col-dist on a + ! non-square grid). dbcsr_multiply redistributes internally, so any valid mapping works. + IF (transa == 'N') THEN + out_row_blk => row_blk_l + ELSE + out_row_blk => col_blk_l + END IF + IF (transb == 'N') THEN + out_col_blk => col_blk_r + ELSE + out_col_blk => row_blk_r + END IF + + ALLOCATE (out_row_dist(SIZE(out_row_blk)), out_col_dist(SIZE(out_col_blk))) + DO i = 1, SIZE(out_row_blk) + out_row_dist(i) = MOD(i - 1, nprows) + END DO + DO i = 1, SIZE(out_col_blk) + out_col_dist(i) = MOD(i - 1, npcols) + END DO + + CALL dbcsr_distribution_new(dist_out, template=dist_l, & + row_dist=out_row_dist, col_dist=out_col_dist) + CALL dbcsr_create(mat_out, name="panel_product", dist=dist_out, & + matrix_type=dbcsr_type_no_symmetry, & + row_blk_size=out_row_blk, col_blk_size=out_col_blk) + CALL dbcsr_distribution_release(dist_out) + DEALLOCATE (out_row_dist, out_col_dist) + + CALL timestop(handle) + + END SUBROUTINE create_product_matrix + +! ************************************************************************************************** +!> \brief Builds the AO-space Green's function operator G^occ/vir_µν (AO x AO DBCSR) !> \param bs_env ... !> \param tau ... !> \param ispin ... !> \param occ ... !> \param vir ... -!> \param mat_phi_mu_l ... -!> \param matrix_G_grid ... -!> \param eps_filter ... +!> \param template ... +!> \param matrix_G_ao ... ! ************************************************************************************************** - - SUBROUTINE build_G_grid(bs_env, tau, ispin, occ, vir, mat_phi_mu_l, matrix_G_grid, eps_filter) + SUBROUTINE build_G_ao(bs_env, tau, ispin, occ, vir, template, matrix_G_ao) TYPE(post_scf_bandstructure_type), POINTER :: bs_env REAL(KIND=dp), INTENT(IN) :: tau INTEGER, INTENT(IN) :: ispin LOGICAL, INTENT(IN) :: occ, vir - TYPE(dbcsr_type), INTENT(INOUT) :: mat_phi_mu_l, matrix_G_grid - REAL(KIND=dp), INTENT(IN) :: eps_filter + TYPE(dbcsr_type), INTENT(INOUT) :: template + TYPE(dbcsr_type), INTENT(OUT) :: matrix_G_ao + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_G_ao' - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_G_grid' - - INTEGER :: handle INTEGER, DIMENSION(:), POINTER :: blk_ao, dist_row_ao TYPE(cp_fm_type), POINTER :: fm_G TYPE(dbcsr_distribution_type) :: dist_ao_ao - TYPE(dbcsr_type) :: matrix_G_ao + INTEGER :: handle CALL timeset(routineN, handle) - ! 1. Select the FM matrix based on occ/vir flags IF (occ) THEN fm_G => bs_env%fm_Gocc ELSE fm_G => bs_env%fm_Gvir END IF - ! 2. Compute Dense FM Green's Function - ! G^occ/vir_µλ(i|τ|) = sum_G^occ/vir_µλn^occ/vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn CALL G_occ_vir(bs_env, tau, fm_G, ispin, occ=occ, vir=vir) - ! 3. Setup AO DBCSR Topology and Create Matrix dynamically - CALL setup_square_topology(mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) - + CALL setup_square_topology(template, dist_ao_ao, blk_ao, dist_row_ao) CALL dbcsr_create(matrix_G_ao, name="G_ao", dist=dist_ao_ao, & matrix_type=dbcsr_type_no_symmetry, & row_blk_size=blk_ao, col_blk_size=blk_ao) - ! 4. Convert FM to Sparse DBCSR - CALL copy_fm_to_dbcsr(fm_G, matrix_G_ao, keep_sparsity=.FALSE.) + ! Optional CUTOFF_RADIUS_G_W operator truncation: only atom-pair blocks within the radius + ! are reserved and filled. + IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp .AND. & + ALLOCATED(bs_env%ri_rs%atom_centers)) THEN + CALL reserve_blocks_within_radius(matrix_G_ao, bs_env%ri_rs%atom_centers, & + bs_env%ri_rs%cutoff_radius_g_w) + CALL copy_fm_to_dbcsr(fm_G, matrix_G_ao, keep_sparsity=.TRUE.) + ELSE + CALL copy_fm_to_dbcsr(fm_G, matrix_G_ao, keep_sparsity=.FALSE.) + END IF + CALL dbcsr_filter(matrix_G_ao, bs_env%eps_filter) - ! 5. Transform to Grid Basis: G_grid = phi * G_ao * phi^T - ! G^occ/vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ/vir_µν Φ_ν(r_l') - CALL contract_A_B_A("N", "T", mat_phi_mu_l, matrix_G_ao, matrix_G_grid, eps_filter) - - ! 6. Release AO matrix and topology - CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, m1=matrix_G_ao) + ! release only the topology; keep matrix_G_ao for the caller + CALL release_square_topology(dist=dist_ao_ao, mapped_dist=dist_row_ao) CALL timestop(handle) - END SUBROUTINE build_G_grid + END SUBROUTINE build_G_ao ! ************************************************************************************************** -!> \brief Generalized routine to compute OUT = A * B * A^T OR OUT = A^T * B * A using DBCSR -!> \param transA_left ... -!> \param transA_right ... -!> \param matrix_A ... -!> \param matrix_B ... -!> \param matrix_out ... -!> \param eps_filter ... +!> \brief Panel-streaming evaluation of out += scale * L_out^T (A_grid ∘ B_grid) L_out, +!> where A_grid = L_A M_A L_A^T and B_grid = L_B M_B L_B^T, WITHOUT ever forming the full +!> grid x grid objects. The grid (row) index is processed in panels of ~panel_size rows; for +!> each panel only P x grid slabs are built, Hadamard-multiplied, and contracted into the +!> (small) output. Algebraically identical to L_out^T (A_grid ∘ B_grid) L_out summed over +!> grid rows, so the result matches the non-streamed path to eps_filter. +!> +!> Mapping (L in {phi (grid x AO), Z (grid x RI)}, M the AO/RI-space operator): +!> chi : L_A=L_B=phi, M_A=G_occ_ao, M_B=G_vir_ao, L_out=Z -> RI x RI +!> Sig : L_A=phi (M_A=D/G), L_B=Z (M_B=V/W), L_out=phi -> AO x AO +!> \param L_A ... +!> \param M_A ... +!> \param L_B ... +!> \param M_B ... +!> \param L_out ... +!> \param mat_out ... +!> \param scale ... +!> \param eps ... +!> \param para_env ... +!> \param pan_first ... +!> \param pan_last ... +!> \param lb_eq_la ... +!> \param lout_eq_la ... +!> \param zero_out ... +!> \param keep_sparsity ... +!> \param centroids ... +!> \param cutoff ... +!> \param grid_occupation ... ! ************************************************************************************************** + SUBROUTINE contract_grid_panels(L_A, M_A, L_B, M_B, L_out, mat_out, scale, eps, para_env, & + pan_first, pan_last, lb_eq_la, lout_eq_la, zero_out, & + keep_sparsity, centroids, cutoff, grid_occupation) - SUBROUTINE contract_A_B_A(transA_left, transA_right, matrix_A, matrix_B, matrix_out, eps_filter) + TYPE(dbcsr_type), INTENT(INOUT), TARGET :: L_A + TYPE(dbcsr_type), INTENT(INOUT) :: M_A + TYPE(dbcsr_type), INTENT(INOUT), TARGET :: L_B + TYPE(dbcsr_type), INTENT(INOUT) :: M_B + TYPE(dbcsr_type), INTENT(INOUT), TARGET :: L_out + TYPE(dbcsr_type), INTENT(INOUT) :: mat_out + REAL(KIND=dp), INTENT(IN) :: scale, eps + TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env + INTEGER, DIMENSION(:), INTENT(IN) :: pan_first, pan_last + LOGICAL, INTENT(IN) :: lb_eq_la, lout_eq_la, zero_out + LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), OPTIONAL :: centroids + REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff + REAL(KIND=dp), INTENT(OUT), OPTIONAL :: grid_occupation - CHARACTER(LEN=1), INTENT(IN) :: transA_left, transA_right - TYPE(dbcsr_type), INTENT(INOUT) :: matrix_A, matrix_B, matrix_out - REAL(KIND=dp), INTENT(IN) :: eps_filter + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_grid_panels' - CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_A_B_A' - - INTEGER :: handle - TYPE(dbcsr_type) :: matrix_tmp + INTEGER :: blk0, blk1, handle, ipan, & + n_grid_total, ncols_pan, nrows_pan + INTEGER, ALLOCATABLE, DIMENSION(:) :: gmap + LOGICAL :: my_keep_sparsity, use_cutoff + LOGICAL, ALLOCATABLE, DIMENSION(:) :: grid_used, usedA, usedB + TYPE(dbcsr_type) :: A_pan, B_pan, C_pan, LA_pan, LA_panC, & + LB_pan, LB_panC, Lout_pan, MA_sub, & + MB_sub, tmp2, tmpA, tmpB + TYPE(dbcsr_type), POINTER :: RB_A, RB_B, RB_out + TYPE(dbcsr_type), TARGET :: LA_near, LB_near, Lout_near CALL timeset(routineN, handle) - CALL dbcsr_create(matrix_tmp, template=matrix_A) + my_keep_sparsity = .FALSE. + IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity + use_cutoff = PRESENT(centroids) .AND. PRESENT(cutoff) + IF (use_cutoff) use_cutoff = cutoff > 0.0_dp + IF (PRESENT(grid_occupation)) grid_occupation = 0.0_dp - IF (transA_left == "N" .AND. transA_right == "T") THEN - ! Path 1: Out = A * B * A^T - CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_A, matrix_B, & - 0.0_dp, matrix_tmp, filter_eps=eps_filter) - CALL dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp, matrix_A, & - 0.0_dp, matrix_out, filter_eps=eps_filter) + CALL dbcsr_get_info(L_A, nfullrows_total=n_grid_total) - ELSE IF (transA_left == "T" .AND. transA_right == "N") THEN - ! Path 2: Out = A^T * B * A - CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_B, matrix_A, & - 0.0_dp, matrix_tmp, filter_eps=eps_filter) - CALL dbcsr_multiply("T", "N", 1.0_dp, matrix_A, matrix_tmp, & - 0.0_dp, matrix_out, filter_eps=eps_filter) - ELSE - CPABORT("Unsupported transposition pair in contract_A_B_A") - END IF + IF (zero_out) CALL dbcsr_set(mat_out, 0.0_dp) - CALL dbcsr_release(matrix_tmp) + DO ipan = 1, SIZE(pan_first) + blk0 = pan_first(ipan) + blk1 = pan_last(ipan) + + ! phi/Z panel slices (P x n) + CALL extract_grid_panel(L_A, blk0, blk1, LA_pan) + IF (.NOT. lb_eq_la) CALL extract_grid_panel(L_B, blk0, blk1, LB_pan) + IF (.NOT. lout_eq_la) CALL extract_grid_panel(L_out, blk0, blk1, Lout_pan) + + ! Which AO/RI atoms (column blocks) actually touch this panel: the inner index of + ! every multiply below is restricted to them, so only the matching rows of the + ! system-wide operators M_A/M_B ever enter Cannon (exact: dropped rows meet zeros). + CALL collect_used_col_blocks(LA_pan, para_env, usedA) + IF (.NOT. lb_eq_la) THEN + CALL collect_used_col_blocks(LB_pan, para_env, usedB) + ELSE + IF (ALLOCATED(usedB)) DEALLOCATE (usedB) + ALLOCATE (usedB, SOURCE=usedA) + END IF + IF (.NOT. (ANY(usedA) .AND. ANY(usedB))) THEN + ! empty panel slice: its Hadamard contribution is exactly zero on all ranks + CALL dbcsr_release(LA_pan) + IF (.NOT. lb_eq_la) CALL dbcsr_release(LB_pan) + IF (.NOT. lout_eq_la) CALL dbcsr_release(Lout_pan) + CYCLE + END IF + + ! Grid rows within reach of the panel: with the CUTOFF_RADIUS_RL_W truncation only + ! they can appear as columns of the panel products / inner rows of the L_out multiply, + ! so the system-wide phi/Z right operands are cut down to this neighborhood slice + ! (local extraction, zero communication; exact w.r.t. the geo template). + IF (use_cutoff) THEN + CALL mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, grid_used) + CALL extract_masked_blocks(L_A, grid_used, LA_near, compress_rows=.TRUE., blk_map=gmap) + IF (.NOT. lb_eq_la) CALL extract_masked_blocks(L_B, grid_used, LB_near, compress_rows=.TRUE.) + IF (.NOT. lout_eq_la) CALL extract_masked_blocks(L_out, grid_used, Lout_near, compress_rows=.TRUE.) + RB_A => LA_near + ELSE + RB_A => L_A + END IF + IF (lb_eq_la) THEN + RB_B => RB_A + ELSE IF (use_cutoff) THEN + RB_B => LB_near + ELSE + RB_B => L_B + END IF + IF (lout_eq_la) THEN + RB_out => RB_A + ELSE IF (use_cutoff) THEN + RB_out => Lout_near + ELSE + RB_out => L_out + END IF + + ! A_pan = LA_pan * M_A * L_A^T (P x grid_near). + ! When cutoff is active, A_pan is pre-seeded with only nearby blocks via + ! build_geo_template_panel, and the multiply uses retain_sparsity to skip + ! computing distant blocks entirely (exact: they are zero by locality). + CALL extract_masked_blocks(LA_pan, usedA, LA_panC, compress_rows=.FALSE.) + CALL extract_masked_blocks(M_A, usedA, MA_sub, compress_rows=.TRUE.) + CALL create_product_matrix(LA_panC, MA_sub, 'N', 'N', tmpA) + CALL dbcsr_multiply('N', 'N', 1.0_dp, LA_panC, MA_sub, 0.0_dp, tmpA, filter_eps=eps) + CALL dbcsr_release(MA_sub) + IF (use_cutoff) THEN + CALL build_geo_template_panel(LA_pan, LA_near, centroids, cutoff, blk0, A_pan, & + col_map=gmap) + ELSE + CALL create_product_matrix(tmpA, RB_A, 'N', 'T', A_pan) + END IF + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpA, RB_A, 0.0_dp, A_pan, & + filter_eps=eps, retain_sparsity=use_cutoff) + CALL dbcsr_release(tmpA) + + ! Grid-basis occupation of A_pan = φ G φ^T, accumulated over ALL panels into the + ! occupation of the (never formed) full grid x grid object: + ! sum_panels nnz(A_pan) / n_grid^2, with nnz = occ * pan_rows * pan_cols. + ! Panel-independent by construction -- a single-panel sample would instead report the + ! local neighbor count of whichever region happens to land in that panel. + IF (PRESENT(grid_occupation)) THEN + CALL dbcsr_get_info(A_pan, nfullrows_total=nrows_pan, nfullcols_total=ncols_pan) + grid_occupation = grid_occupation + dbcsr_get_occupation(A_pan)* & + REAL(ncols_pan, dp)*REAL(nrows_pan, dp)/ & + (REAL(n_grid_total, dp)*REAL(n_grid_total, dp)) + END IF + + ! B_pan = LB_pan * M_B * L_B^T (P x grid_near); reuse the L_A slices when L_B == L_A. + ! With keep_sparsity, B_pan is pre-populated with A_pan's block structure so that + ! retain_sparsity forces the final multiply to fill only those blocks (exact for ∘). + IF (lb_eq_la) THEN + CALL extract_masked_blocks(M_B, usedA, MB_sub, compress_rows=.TRUE.) + CALL create_product_matrix(LA_panC, MB_sub, 'N', 'N', tmpB) + CALL dbcsr_multiply('N', 'N', 1.0_dp, LA_panC, MB_sub, 0.0_dp, tmpB, filter_eps=eps) + ELSE + CALL extract_masked_blocks(LB_pan, usedB, LB_panC, compress_rows=.FALSE.) + CALL extract_masked_blocks(M_B, usedB, MB_sub, compress_rows=.TRUE.) + CALL create_product_matrix(LB_panC, MB_sub, 'N', 'N', tmpB) + CALL dbcsr_multiply('N', 'N', 1.0_dp, LB_panC, MB_sub, 0.0_dp, tmpB, filter_eps=eps) + CALL dbcsr_release(LB_panC) + END IF + CALL dbcsr_release(MB_sub) + IF (my_keep_sparsity) THEN + CALL dbcsr_create(B_pan, template=A_pan) + CALL dbcsr_copy(B_pan, A_pan) + CALL dbcsr_set(B_pan, 0.0_dp) + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_B, 0.0_dp, B_pan, & + filter_eps=eps, retain_sparsity=.TRUE.) + ELSE + CALL create_product_matrix(tmpB, RB_B, 'N', 'T', B_pan) + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_B, 0.0_dp, B_pan, filter_eps=eps) + END IF + CALL dbcsr_release(tmpB) + CALL dbcsr_release(LA_panC) + + ! C_pan = scale * (A_pan ∘ B_pan) (P x grid_near) + CALL dbcsr_create(C_pan, template=A_pan) + CALL hadamard_product(A_pan, B_pan, C_pan, scale) + CALL dbcsr_release(A_pan) + CALL dbcsr_release(B_pan) + + ! tmp2 = C_pan * L_out (P x n_out; inner index restricted to the neighborhood) + CALL create_product_matrix(C_pan, RB_out, 'N', 'N', tmp2) + CALL dbcsr_multiply('N', 'N', 1.0_dp, C_pan, RB_out, 0.0_dp, tmp2, filter_eps=eps) + CALL dbcsr_release(C_pan) + + ! mat_out += L_out_pan^T * tmp2 (accumulate: beta = 1) + IF (lout_eq_la) THEN + CALL dbcsr_multiply('T', 'N', 1.0_dp, LA_pan, tmp2, 1.0_dp, mat_out, filter_eps=eps) + ELSE + CALL dbcsr_multiply('T', 'N', 1.0_dp, Lout_pan, tmp2, 1.0_dp, mat_out, filter_eps=eps) + CALL dbcsr_release(Lout_pan) + END IF + CALL dbcsr_release(tmp2) + IF (.NOT. lb_eq_la) CALL dbcsr_release(LB_pan) + CALL dbcsr_release(LA_pan) + IF (use_cutoff) THEN + CALL dbcsr_release(LA_near) + IF (.NOT. lb_eq_la) CALL dbcsr_release(LB_near) + IF (.NOT. lout_eq_la) CALL dbcsr_release(Lout_near) + END IF + + END DO CALL timestop(handle) - END SUBROUTINE contract_A_B_A + END SUBROUTINE contract_grid_panels + +! ************************************************************************************************** +!> \brief Σ^c-specific panel loop: computes both the occupied (neg) and virtual (pos) contributions +!> in a single pass over grid panels, forming W_pan = Z_panel × W_aux × Z^T only ONCE per +!> panel and reusing it for both the G^occ and G^vir Hadamard contractions. +!> +!> Computes: +!> mat_Sigma_neg = φ^T ( (φ G^occ φ^T) ∘ (Z W^MIC Z^T) ) φ +!> mat_Sigma_pos = φ^T ( (φ G^vir φ^T) ∘ (Z W^MIC Z^T) ) φ +!> +!> \param mat_phi ... +!> \param mat_Z ... +!> \param mat_G_occ_ao ... +!> \param mat_G_vir_ao ... +!> \param mat_W_aux ... +!> \param mat_Sigma_neg ... +!> \param mat_Sigma_pos ... +!> \param eps ... +!> \param para_env ... +!> \param pan_first ... +!> \param pan_last ... +!> \param keep_sparsity ... +!> \param centroids ... +!> \param cutoff ... +! ************************************************************************************************** + SUBROUTINE contract_grid_panels_sigma_c(mat_phi, mat_Z, mat_G_occ_ao, mat_G_vir_ao, & + mat_W_aux, mat_Sigma_neg, mat_Sigma_pos, eps, para_env, & + pan_first, pan_last, keep_sparsity, centroids, cutoff) + + TYPE(dbcsr_type), INTENT(INOUT), TARGET :: mat_phi, mat_Z + TYPE(dbcsr_type), INTENT(INOUT) :: mat_G_occ_ao, mat_G_vir_ao, mat_W_aux + TYPE(dbcsr_type), INTENT(INOUT) :: mat_Sigma_neg, mat_Sigma_pos + REAL(KIND=dp), INTENT(IN) :: eps + TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env + INTEGER, DIMENSION(:), INTENT(IN) :: pan_first, pan_last + LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), OPTIONAL :: centroids + REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_grid_panels_sigma_c' + + INTEGER :: blk0, blk1, handle, ipan + INTEGER, ALLOCATABLE, DIMENSION(:) :: gmap + LOGICAL :: my_keep_sparsity, use_cutoff + LOGICAL, ALLOCATABLE, DIMENSION(:) :: grid_used, used_ao, used_ri + TYPE(dbcsr_type) :: A_occ, A_vir, C_pan, G_occ_sub, & + G_vir_sub, phi_pan, phi_panC, tmp2, & + tmpA, tmpB, W_pan, W_sub, Z_pan, & + Z_panC + TYPE(dbcsr_type), POINTER :: RB_phi, RB_Z + TYPE(dbcsr_type), TARGET :: phi_near, Z_near + + CALL timeset(routineN, handle) + + my_keep_sparsity = .FALSE. + IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity + use_cutoff = PRESENT(centroids) .AND. PRESENT(cutoff) + IF (use_cutoff) use_cutoff = cutoff > 0.0_dp + + CALL dbcsr_set(mat_Sigma_neg, 0.0_dp) + CALL dbcsr_set(mat_Sigma_pos, 0.0_dp) + + DO ipan = 1, SIZE(pan_first) + blk0 = pan_first(ipan) + blk1 = pan_last(ipan) + + CALL extract_grid_panel(mat_phi, blk0, blk1, phi_pan) + CALL extract_grid_panel(mat_Z, blk0, blk1, Z_pan) + + ! AO/RI atoms touching this panel: only the matching rows of G_occ/G_vir/W ever + ! enter the multiplies below (exact: dropped rows meet zero columns of the panel). + CALL collect_used_col_blocks(phi_pan, para_env, used_ao) + CALL collect_used_col_blocks(Z_pan, para_env, used_ri) + IF (.NOT. (ANY(used_ao) .AND. ANY(used_ri))) THEN + CALL dbcsr_release(phi_pan) + CALL dbcsr_release(Z_pan) + CYCLE + END IF + + ! Neighborhood slices of phi/Z (grid rows within cutoff of the panel): they replace + ! the system-wide right operands in every multiply (local extraction, zero comm). + IF (use_cutoff) THEN + CALL mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, grid_used) + CALL extract_masked_blocks(mat_phi, grid_used, phi_near, compress_rows=.TRUE., blk_map=gmap) + CALL extract_masked_blocks(mat_Z, grid_used, Z_near, compress_rows=.TRUE.) + RB_phi => phi_near + RB_Z => Z_near + ELSE + RB_phi => mat_phi + RB_Z => mat_Z + END IF + + CALL extract_masked_blocks(phi_pan, used_ao, phi_panC, compress_rows=.FALSE.) + CALL extract_masked_blocks(Z_pan, used_ri, Z_panC, compress_rows=.FALSE.) + CALL extract_masked_blocks(mat_G_occ_ao, used_ao, G_occ_sub, compress_rows=.TRUE.) + CALL extract_masked_blocks(mat_G_vir_ao, used_ao, G_vir_sub, compress_rows=.TRUE.) + CALL extract_masked_blocks(mat_W_aux, used_ri, W_sub, compress_rows=.TRUE.) + + ! A_occ = phi_pan × G_occ × phi^T (built first so W_pan can inherit its pattern). + ! With cutoff active, A_occ is pre-seeded with geo-local blocks so that the + ! phi^T multiply uses retain_sparsity and never computes distant blocks. + CALL create_product_matrix(phi_panC, G_occ_sub, 'N', 'N', tmpA) + CALL dbcsr_multiply('N', 'N', 1.0_dp, phi_panC, G_occ_sub, 0.0_dp, tmpA, filter_eps=eps) + IF (use_cutoff) THEN + CALL build_geo_template_panel(phi_pan, phi_near, centroids, cutoff, blk0, A_occ, & + col_map=gmap) + ELSE + CALL create_product_matrix(tmpA, RB_phi, 'N', 'T', A_occ) + END IF + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpA, RB_phi, 0.0_dp, A_occ, & + filter_eps=eps, retain_sparsity=use_cutoff) + CALL dbcsr_release(tmpA) + CALL dbcsr_release(G_occ_sub) + + ! A_vir = phi_pan × G_vir × phi^T (same pre-screen as A_occ) + CALL create_product_matrix(phi_panC, G_vir_sub, 'N', 'N', tmpA) + CALL dbcsr_multiply('N', 'N', 1.0_dp, phi_panC, G_vir_sub, 0.0_dp, tmpA, filter_eps=eps) + IF (use_cutoff) THEN + CALL build_geo_template_panel(phi_pan, phi_near, centroids, cutoff, blk0, A_vir, & + col_map=gmap) + ELSE + CALL create_product_matrix(tmpA, RB_phi, 'N', 'T', A_vir) + END IF + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpA, RB_phi, 0.0_dp, A_vir, & + filter_eps=eps, retain_sparsity=use_cutoff) + CALL dbcsr_release(tmpA) + CALL dbcsr_release(G_vir_sub) + + ! W_pan = Z_pan × W_aux × Z^T (computed once, reused for both Σ^c terms). + ! With keep_sparsity, W_pan is pre-seeded with the union of A_occ and A_vir block + ! patterns so that retain_sparsity forces the multiply to fill only those blocks: + ! exact since W outside G_occ∪G_vir is multiplied by zero in the Hadamard. + CALL create_product_matrix(Z_panC, W_sub, 'N', 'N', tmpB) + CALL dbcsr_multiply('N', 'N', 1.0_dp, Z_panC, W_sub, 0.0_dp, tmpB, filter_eps=eps) + IF (my_keep_sparsity) THEN + CALL dbcsr_create(W_pan, template=A_occ) + CALL dbcsr_copy(W_pan, A_occ) + CALL dbcsr_add(W_pan, A_vir, 1.0_dp, 1.0_dp) + CALL dbcsr_set(W_pan, 0.0_dp) + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_Z, 0.0_dp, W_pan, & + filter_eps=eps, retain_sparsity=.TRUE.) + ELSE + CALL create_product_matrix(tmpB, RB_Z, 'N', 'T', W_pan) + CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_Z, 0.0_dp, W_pan, filter_eps=eps) + END IF + CALL dbcsr_release(tmpB) + CALL dbcsr_release(W_sub) + CALL dbcsr_release(phi_panC) + CALL dbcsr_release(Z_panC) + + ! Σ^c_neg: φ^T ( A_occ ∘ W_pan ) φ + CALL dbcsr_create(C_pan, template=A_occ) + CALL hadamard_product(A_occ, W_pan, C_pan, 1.0_dp) + CALL dbcsr_release(A_occ) + CALL create_product_matrix(C_pan, RB_phi, 'N', 'N', tmp2) + CALL dbcsr_multiply('N', 'N', 1.0_dp, C_pan, RB_phi, 0.0_dp, tmp2, filter_eps=eps) + CALL dbcsr_release(C_pan) + CALL dbcsr_multiply('T', 'N', 1.0_dp, phi_pan, tmp2, 1.0_dp, mat_Sigma_neg, filter_eps=eps) + CALL dbcsr_release(tmp2) + + ! Σ^c_pos: φ^T ( A_vir ∘ W_pan ) φ — W_pan reused + CALL dbcsr_create(C_pan, template=A_vir) + CALL hadamard_product(A_vir, W_pan, C_pan, 1.0_dp) + CALL dbcsr_release(A_vir) + CALL create_product_matrix(C_pan, RB_phi, 'N', 'N', tmp2) + CALL dbcsr_multiply('N', 'N', 1.0_dp, C_pan, RB_phi, 0.0_dp, tmp2, filter_eps=eps) + CALL dbcsr_release(C_pan) + CALL dbcsr_multiply('T', 'N', 1.0_dp, phi_pan, tmp2, 1.0_dp, mat_Sigma_pos, filter_eps=eps) + CALL dbcsr_release(tmp2) + + CALL dbcsr_release(W_pan) + CALL dbcsr_release(Z_pan) + CALL dbcsr_release(phi_pan) + IF (use_cutoff) THEN + CALL dbcsr_release(phi_near) + CALL dbcsr_release(Z_near) + END IF + + END DO + + CALL timestop(handle) + + END SUBROUTINE contract_grid_panels_sigma_c ! ************************************************************************************************** !> \brief Computes C = A ◦ B (Element-wise Hadamard product) for sparse DBCSR matrices. @@ -1671,7 +3796,6 @@ CONTAINS !> \param matrix_C ... !> \param fac (Scaling factor applied to the product) ! ************************************************************************************************** - SUBROUTINE hadamard_product(matrix_A, matrix_B, matrix_C, fac) TYPE(dbcsr_type), INTENT(INOUT) :: matrix_A, matrix_B, matrix_C @@ -1708,13 +3832,19 @@ CONTAINS END SUBROUTINE hadamard_product ! ************************************************************************************************** -!> \brief Compute screened Coulomb interaction matrix +!> \brief Computes the screened Coulomb interaction on the imaginary-time grid, entirely in the +!> RI auxiliary (PQ) basis: +!> χ_PQ(iω) = Σ_τ w(ω,τ) cos(ωτ) χ_PQ(iτ) (cosine transform) +!> ε(iω) = Id - V^0.5 M^-1 χ(iω) M^-1 V^0.5 (dielectric function) +!> W(iω) = V^0.5 ( ε^-1(iω) - Id ) V^0.5 (correlation part only) +!> W(iτ) = Σ_ω w̃(τ,ω) cos(ωτ) W(iω) (back transform) +!> W(iτ) <- M^-1 W(iτ) M^-1 (fold in the RI metric) +!> where V is the bare Coulomb matrix and M the RI metric. !> \param bs_env ... !> \param qs_env ... !> \param mat_chi_Gamma_tau ... !> \param fm_W_time ... ! ************************************************************************************************** - SUBROUTINE compute_W(bs_env, qs_env, mat_chi_Gamma_tau, fm_W_time) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(qs_environment_type), POINTER :: qs_env @@ -1759,7 +3889,7 @@ CONTAINS CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_W_time) IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T55,A,F10.1,A)') & + WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & 'Computed W(iτ),', ' Execution time', m_walltime() - t1, ' s' END IF @@ -1786,7 +3916,7 @@ CONTAINS CALL fm_write(bs_env%fm_W_MIC_freq_zero, 0, "W_freq_rtp", qs_env) ! Report calculation IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T55,A,F10.1,A)') & + WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & 'Computed W(0),', ' Execution time', m_walltime() - t1, ' s' END IF END IF @@ -1798,14 +3928,15 @@ CONTAINS END SUBROUTINE compute_W ! ************************************************************************************************** -!> \brief Computes V, V^0.5, and M^-1 * V^0.5 +!> \brief Computes the static RI-basis Coulomb operators entering the dielectric function: +!> the bare Coulomb matrix V_PQ(k=0), its Cholesky/matrix square root V^0.5, and +!> M^-1 V^0.5 with M the RI metric (2c integrals of the RI_METRIC operator). !> \param bs_env ... !> \param qs_env ... !> \param fm_V ... !> \param fm_V_sqrt ... !> \param fm_Minv_Vsqrt ... ! ************************************************************************************************** - SUBROUTINE compute_V_MinvVsqrt(bs_env, qs_env, fm_V, fm_V_sqrt, fm_Minv_Vsqrt) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(qs_environment_type), POINTER :: qs_env @@ -1903,14 +4034,17 @@ CONTAINS END SUBROUTINE compute_V_MinvVsqrt ! ************************************************************************************************** -!> \brief Computes W(iω) from χ_PQ(iω_j) +!> \brief Computes the screened interaction at one imaginary frequency: +!> ε(iω_j) = Id - (M^-1 V^0.5)^T χ(iω_j) (M^-1 V^0.5) +!> W(iω_j) = V^0.5^T ( ε^-1(iω_j) - Id ) V^0.5 +!> ε is inverted via Cholesky; if that fails due to conditioning, via +!> eigendecomposition (cp_fm_power) with eigenvalue filtering. !> \param bs_env ... !> \param fm_chi_freq_j ... !> \param fm_V_sqrt ... !> \param fm_Minv_Vsqrt ... !> \param fm_W_freq_j ... ! ************************************************************************************************** - SUBROUTINE compute_fm_W_freq(bs_env, fm_chi_freq_j, fm_V_sqrt, fm_Minv_Vsqrt, fm_W_freq_j) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(cp_fm_type), INTENT(IN) :: fm_chi_freq_j, fm_V_sqrt, fm_Minv_Vsqrt @@ -1982,11 +4116,10 @@ CONTAINS END SUBROUTINE compute_fm_W_freq ! ************************************************************************************************** -!> \brief Adds a real scalar value to the diagonal of a real full matrix (fm) +!> \brief Adds a real scalar value to the diagonal of a real full matrix !> \param fm ... !> \param alpha ... ! ************************************************************************************************** - SUBROUTINE fm_add_on_diag(fm, alpha) TYPE(cp_fm_type), INTENT(INOUT) :: fm REAL(KIND=dp), INTENT(IN) :: alpha @@ -2050,14 +4183,16 @@ CONTAINS END SUBROUTINE clean_lower_part ! ************************************************************************************************** -!> \brief Computes the exact exchange part of the GW self-energy +!> \brief Computes the exact-exchange part of the GW self-energy: +!> D_μν = Σ_n^occ C_μn C_νn (density matrix = G^occ at τ=0) +!> V^tr_PQ = M^-1 (P|Q)_trunc M^-1 (truncated Coulomb, RI basis) +!> Σ^x_λσ(k=0) = -Σ_ll' Φ_λ(r_l) [ (φ D φ^T)_ll' ∘ (Z V^tr Z^T)_ll' ] Φ_σ(r_l') !> \param bs_env ... !> \param qs_env ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... !> \param fm_Sigma_x_Gamma ... ! ************************************************************************************************** - SUBROUTINE compute_Sigma_x(bs_env, qs_env, mat_phi_mu_l, mat_Z_lP, fm_Sigma_x_Gamma) TYPE(post_scf_bandstructure_type), POINTER :: bs_env @@ -2068,14 +4203,13 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Sigma_x' INTEGER :: handle, ispin - INTEGER, DIMENSION(:), POINTER :: blk_aux, blk_grid, dist_col_grid, & - dist_row_aux + INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last + INTEGER, DIMENSION(:), POINTER :: blk_aux, dist_row_aux REAL(KIND=dp) :: t1 TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma - TYPE(dbcsr_distribution_type) :: dist_aux_aux, dist_grid_grid - TYPE(dbcsr_type) :: mat_Sigma_x_Gamma, matrix_D_grid, & - matrix_Sigma_x_grid, matrix_V_aux, & - matrix_V_grid + TYPE(dbcsr_distribution_type) :: dist_aux_aux + TYPE(dbcsr_type) :: mat_Sigma_x_Gamma, matrix_D_ao, & + matrix_V_aux CALL timeset(routineN, handle) @@ -2088,15 +4222,13 @@ CONTAINS CALL dbcsr_create(mat_Sigma_x_Gamma, template=bs_env%mat_ao_ao%matrix) - ! ========================================================================= - ! 1. SETUP CORE TOPOLOGIES - ! ========================================================================= - CALL setup_square_topology(mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, dist_col_grid) - CALL setup_square_topology(mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) + CALL resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) ! ========================================================================= - ! 2. COMPUTE V^tr_ll' + ! 1. COMPUTE V^tr_PQ (RI x RI) ! ========================================================================= + CALL setup_square_topology(mat_Z_lP, dist_aux_aux, blk_aux, dist_row_aux) + CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & bs_env%trunc_coulomb, do_kpoints=.FALSE.) @@ -2104,38 +4236,40 @@ CONTAINS CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) CALL dbcsr_create(matrix_V_aux, "V_aux", dist_aux_aux, dbcsr_type_no_symmetry, blk_aux, blk_aux) - CALL dbcsr_create(matrix_V_grid, "V_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - - CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.FALSE.) - - ! V^tr_ll' = sum_PQ Z_lP V^trunc_PQ Z_l'Q - CALL contract_A_B_A("N", "T", mat_Z_lP, matrix_V_aux, matrix_V_grid, bs_env%eps_filter) - CALL dbcsr_release(matrix_V_aux) + ! Optional CUTOFF_RADIUS_G_W operator truncation + filter (see build_G_ao) + IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp .AND. & + ALLOCATED(bs_env%ri_rs%atom_centers)) THEN + CALL reserve_blocks_within_radius(matrix_V_aux, bs_env%ri_rs%atom_centers, & + bs_env%ri_rs%cutoff_radius_g_w) + CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.TRUE.) + ELSE + CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.FALSE.) + END IF + CALL dbcsr_filter(matrix_V_aux, bs_env%eps_filter) ! ========================================================================= - ! 3. SPIN LOOP FOR EXACT EXCHANGE + ! 2. SPIN LOOP FOR EXACT EXCHANGE + ! Σ^x_λσ = -Σ_ll' Φ_λ(r_l) ( D_ll' V^tr_ll' ) Φ_σ(r_l') + ! = -φ^T ( (φ D φ^T) ∘ (Z V^tr Z^T) ) φ ! ========================================================================= DO ispin = 1, bs_env%n_spin - ! Density matrix on grid is essentially G_occ at tau = 0.0 - ! D_µν = sum_n^occ C_µn C_νn - ! D_ll' = sum_µν Φ_µ(r_l) D_µν Φ_ν(r_l') - CALL dbcsr_create(matrix_D_grid, "D_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - CALL build_G_grid(bs_env, 0.0_dp, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_D_grid, bs_env%eps_filter) + ! AO-space density matrix D_µν = G^occ at τ = 0 + CALL build_G_ao(bs_env, 0.0_dp, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_D_ao) - ! Element-wise Hadamard product: Σ^x_grid = D_grid ◦ V_grid - ! Σ^x_ll' = D_ll' * V^tr_ll' - CALL dbcsr_create(matrix_Sigma_x_grid, template=matrix_V_grid) - CALL hadamard_product(matrix_D_grid, matrix_V_grid, matrix_Sigma_x_grid, 1.0_dp) - - CALL dbcsr_release(matrix_D_grid) - - ! Transform back to AO basis: Σ^x_ao = -1.0 * phi^T * Σ^x_grid * phi - ! Σ^x_λσ = -sum_ll' Φ_λ(r_l) Σ^x_ll' Φ_σ(r_l') - CALL contract_A_B_A("T", "N", mat_phi_mu_l, matrix_Sigma_x_grid, mat_Sigma_x_Gamma, bs_env%eps_filter) + CALL contract_grid_panels(L_A=mat_phi_mu_l, M_A=matrix_D_ao, & + L_B=mat_Z_lP, M_B=matrix_V_aux, & + L_out=mat_phi_mu_l, mat_out=mat_Sigma_x_Gamma, & + scale=1.0_dp, eps=bs_env%eps_filter, & + para_env=bs_env%para_env, & + pan_first=pan_first, pan_last=pan_last, & + lb_eq_la=.FALSE., lout_eq_la=.TRUE., zero_out=.TRUE., & + keep_sparsity=bs_env%ri_rs%keep_sparsity_rirs, & + centroids=bs_env%ri_rs%chunk_centroids, & + cutoff=bs_env%ri_rs%cutoff_radius_v_w) CALL dbcsr_scale(mat_Sigma_x_Gamma, -1.0_dp) - CALL dbcsr_release(matrix_Sigma_x_grid) + CALL dbcsr_release(matrix_D_ao) ! Data I/O and Export to CP2K Full Matrices CALL copy_dbcsr_to_fm(mat_Sigma_x_Gamma, fm_Sigma_x_Gamma(ispin)) @@ -2149,11 +4283,11 @@ CONTAINS END IF ! ========================================================================= - ! 4. CLEANUP + ! 3. CLEANUP ! ========================================================================= - CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid, & - m1=mat_Sigma_x_Gamma, m2=matrix_V_grid) - CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux) + CALL dbcsr_release(matrix_V_aux) + CALL dbcsr_release(mat_Sigma_x_Gamma) + CALL release_square_topology(dist=dist_aux_aux, mapped_dist=dist_row_aux) CALL cp_fm_release(fm_Vtr_Gamma) @@ -2162,14 +4296,15 @@ CONTAINS END SUBROUTINE compute_Sigma_x ! ************************************************************************************************** -!> \brief Computes the correlation part of the GW self-energy +!> \brief Computes the correlation part of the GW self-energy on the imaginary-time grid: +!> Σ^c_λσ(iτ<0) = -Σ_ll' Φ_λ(r_l) [ (φ G^occ φ^T)_ll' ∘ (Z W^MIC Z^T)_ll' ] Φ_σ(r_l') +!> Σ^c_λσ(iτ>0) = +Σ_ll' Φ_λ(r_l) [ (φ G^vir φ^T)_ll' ∘ (Z W^MIC Z^T)_ll' ] Φ_σ(r_l') !> \param bs_env ... !> \param fm_W_time ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... !> \param fm_Sigma_c_Gamma_time ... ! ************************************************************************************************** - SUBROUTINE compute_Sigma_c(bs_env, fm_W_time, mat_phi_mu_l, mat_Z_lP, fm_Sigma_c_Gamma_time) TYPE(post_scf_bandstructure_type), POINTER :: bs_env @@ -2180,21 +4315,22 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Sigma_c' INTEGER :: handle, i_t, ispin - INTEGER, DIMENSION(:), POINTER :: blk_aux, blk_grid, dist_col_grid, & - dist_row_aux + INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last + INTEGER, DIMENSION(:), POINTER :: blk_aux, dist_row_aux REAL(KIND=dp) :: t1, tau - TYPE(dbcsr_distribution_type) :: dist_aux_aux, dist_grid_grid + TYPE(dbcsr_distribution_type) :: dist_aux_aux TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_Sigma_neg_tau, mat_Sigma_pos_tau - TYPE(dbcsr_type) :: matrix_G_occ_grid, matrix_G_vir_grid, matrix_Sigma_neg_grid, & - matrix_Sigma_pos_grid, matrix_W_aux, matrix_W_grid + TYPE(dbcsr_type) :: matrix_G_occ_ao, matrix_G_vir_ao, & + matrix_W_aux CALL timeset(routineN, handle) ! ========================================================================= - ! 1. SETUP CORE TOPOLOGIES AND PRE-ALLOCATE OUTPUT ARRAYS + ! 1. SETUP AUXILIARY TOPOLOGY AND PRE-ALLOCATE OUTPUT ARRAYS ! ========================================================================= - CALL setup_square_topology(mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, dist_col_grid) - CALL setup_square_topology(mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) + CALL setup_square_topology(mat_Z_lP, dist_aux_aux, blk_aux, dist_row_aux) + + CALL resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) ! Pre-allocate local DBCSR matrices to act as targets for final output NULLIFY (mat_Sigma_neg_tau, mat_Sigma_pos_tau) @@ -2211,87 +4347,58 @@ CONTAINS END DO ! ========================================================================= - ! 2. MAIN IMAGINARY TIME LOOP + ! 2. IMAGINARY TIME LOOP + ! Σ^c_neg_λσ(iτ) = -φ^T ( (φ G^occ φ^T) ∘ (Z W^MIC Z^T) ) φ + ! Σ^c_pos_λσ(iτ) = φ^T ( (φ G^vir φ^T) ∘ (Z W^MIC Z^T) ) φ ! ========================================================================= DO i_t = 1, bs_env%num_time_freq_points tau = bs_env%imag_time_points(i_t) - ! ------------------------------------------------------------------- - ! Compute W_grid = Z * W_aux * Z^T - ! ------------------------------------------------------------------- CALL dbcsr_create(matrix_W_aux, "W_aux", dist_aux_aux, dbcsr_type_no_symmetry, blk_aux, blk_aux) - CALL dbcsr_create(matrix_W_grid, "W_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - - CALL copy_fm_to_dbcsr(fm_W_time(i_t), matrix_W_aux, keep_sparsity=.FALSE.) - - ! W^MIC_ll'(iτ,k=0) = sum_PQ Z_lP W^MIC_PQ(iτ) Z_l'Q - CALL contract_A_B_A("N", "T", mat_Z_lP, matrix_W_aux, matrix_W_grid, bs_env%eps_filter) - - CALL dbcsr_release(matrix_W_aux) ! Clean up aux basis immediately + IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp .AND. & + ALLOCATED(bs_env%ri_rs%atom_centers)) THEN + CALL reserve_blocks_within_radius(matrix_W_aux, bs_env%ri_rs%atom_centers, & + bs_env%ri_rs%cutoff_radius_g_w) + CALL copy_fm_to_dbcsr(fm_W_time(i_t), matrix_W_aux, keep_sparsity=.TRUE.) + ELSE + CALL copy_fm_to_dbcsr(fm_W_time(i_t), matrix_W_aux, keep_sparsity=.FALSE.) + END IF + CALL dbcsr_filter(matrix_W_aux, bs_env%eps_filter) DO ispin = 1, bs_env%n_spin t1 = m_walltime() - ! ------------------------------------------------------------------- - ! A. Transform Green's Functions to the Grid - ! ------------------------------------------------------------------- - CALL dbcsr_create(matrix_G_occ_grid, "G_occ_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - CALL dbcsr_create(matrix_G_vir_grid, "G_vir_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + ! AO-space Green's functions G^occ_µν, G^vir_µν (dense AO x AO, small) + CALL build_G_ao(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_G_occ_ao) + CALL build_G_ao(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, matrix_G_vir_ao) - ! G^occ_µλ(i|τ|) = sum_G^occ_µλn^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - ! G^occ_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') - CALL build_G_grid(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_G_occ_grid, bs_env%eps_filter) - - ! G^vir_µλ(i|τ|) = sum_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - ! G^vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^vir_µν Φ_ν(r_l') - CALL build_G_grid(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, matrix_G_vir_grid, bs_env%eps_filter) - - ! ------------------------------------------------------------------- - ! B. Element-wise Hadamard Products for Sigma_c on Grid - ! Σ_neg_grid = G_occ_grid ◦ W_grid - ! Σ_pos_grid = G_vir_grid ◦ W_grid - ! ------------------------------------------------------------------- - CALL dbcsr_create(matrix_Sigma_neg_grid, template=matrix_W_grid) - CALL dbcsr_create(matrix_Sigma_pos_grid, template=matrix_W_grid) - - ! Σ^c_ll'(iτ) = -G^occ_ll'(i|τ|) * W^MIC_ll'(iτ), for τ < 0 - CALL hadamard_product(matrix_G_occ_grid, matrix_W_grid, matrix_Sigma_neg_grid, 1.0_dp) - - ! Σ^c_ll'(iτ) = G^vir_ll'(i|τ|) * W^MIC_ll'(iτ), for τ > 0 - CALL hadamard_product(matrix_G_vir_grid, matrix_W_grid, matrix_Sigma_pos_grid, 1.0_dp) - - ! Instantly purge massive G_grid arrays to save memory - CALL dbcsr_release(matrix_G_occ_grid) - CALL dbcsr_release(matrix_G_vir_grid) - - ! ------------------------------------------------------------------- - ! C. Transform Sigma back to AO Basis - ! Σ_AO = phi^T * Σ_grid * phi - ! ------------------------------------------------------------------- - - ! Σ^c_λσ(iτ) = sum_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l'), for τ < 0 - CALL contract_A_B_A("T", "N", mat_phi_mu_l, matrix_Sigma_neg_grid, & - mat_Sigma_neg_tau(i_t, ispin)%matrix, bs_env%eps_filter) + ! Σ^c_neg and Σ^c_pos in a single panel loop: W_pan = Z_panel × W × Z^T built once + CALL contract_grid_panels_sigma_c(mat_phi=mat_phi_mu_l, mat_Z=mat_Z_lP, & + mat_G_occ_ao=matrix_G_occ_ao, & + mat_G_vir_ao=matrix_G_vir_ao, & + mat_W_aux=matrix_W_aux, & + mat_Sigma_neg=mat_Sigma_neg_tau(i_t, ispin)%matrix, & + mat_Sigma_pos=mat_Sigma_pos_tau(i_t, ispin)%matrix, & + eps=bs_env%eps_filter, & + para_env=bs_env%para_env, & + pan_first=pan_first, pan_last=pan_last, & + keep_sparsity=bs_env%ri_rs%keep_sparsity_rirs, & + centroids=bs_env%ri_rs%chunk_centroids, & + cutoff=bs_env%ri_rs%cutoff_radius_v_w) CALL dbcsr_scale(mat_Sigma_neg_tau(i_t, ispin)%matrix, -1.0_dp) - ! Σ^c_λσ(iτ) = sum_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l'), for τ > 0 - CALL contract_A_B_A("T", "N", mat_phi_mu_l, matrix_Sigma_pos_grid, & - mat_Sigma_pos_tau(i_t, ispin)%matrix, bs_env%eps_filter) - - ! Purge Grid Sigma arrays - CALL dbcsr_release(matrix_Sigma_neg_grid) - CALL dbcsr_release(matrix_Sigma_pos_grid) + CALL dbcsr_release(matrix_G_occ_ao) + CALL dbcsr_release(matrix_G_vir_ao) IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,I10,A,I3,A,F7.1,A)') & - 'Computed Σ^c(iτ) for time point ', i_t, ' /', bs_env%num_time_freq_points, & + WRITE (bs_env%unit_nr, '(T2,A,I15,A,I3,A,F7.1,A)') & + 'Computed Σ^c(iτ) for time point', i_t, ' /', bs_env%num_time_freq_points, & ', Execution time', m_walltime() - t1, ' s' END IF END DO ! ispin - ! Release the W_grid for this time point - CALL dbcsr_release(matrix_W_grid) + CALL dbcsr_release(matrix_W_aux) END DO ! i_t @@ -2308,8 +4415,7 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(mat_Sigma_neg_tau) CALL dbcsr_deallocate_matrix_set(mat_Sigma_pos_tau) - CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid) - CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux) + CALL release_square_topology(dist=dist_aux_aux, mapped_dist=dist_row_aux) CALL delete_unnecessary_files(bs_env) CALL timestop(handle) @@ -2317,84 +4423,57 @@ CONTAINS END SUBROUTINE compute_Sigma_c ! ************************************************************************************************** -!> \brief DBCSR Topology Generation +!> \brief Builds the DBCSR distribution. !> \param matrix_template ... -!> \param dim_type ... !> \param square_dist ... !> \param blk_sizes ... !> \param mapped_dist ... ! ************************************************************************************************** - - SUBROUTINE setup_square_topology(matrix_template, dim_type, square_dist, blk_sizes, mapped_dist) + SUBROUTINE setup_square_topology(matrix_template, square_dist, blk_sizes, mapped_dist) TYPE(dbcsr_type), INTENT(IN) :: matrix_template - CHARACTER(LEN=*), INTENT(IN) :: dim_type TYPE(dbcsr_distribution_type), INTENT(OUT) :: square_dist INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: blk_sizes, mapped_dist - INTEGER :: i, np - INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist, row_blk, row_dist + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_square_topology' + + INTEGER :: handle, i, nprows + INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist TYPE(dbcsr_distribution_type) :: dist_template - CALL dbcsr_get_info(matrix_template, distribution=dist_template, & - row_blk_size=row_blk, col_blk_size=col_blk) - CALL dbcsr_distribution_get(dist_template, row_dist=row_dist, col_dist=col_dist) + CALL timeset(routineN, handle) - IF (TRIM(dim_type) == 'ROW') THEN - ! Creates ROW x ROW (e.g., Grid x Grid from mat_phi_mu_l) - blk_sizes => row_blk - np = MAXVAL(col_dist) + 1 ! npcol - ALLOCATE (mapped_dist(SIZE(blk_sizes))) - DO i = 1, SIZE(blk_sizes) - mapped_dist(i) = MOD(i - 1, np) - END DO - CALL dbcsr_distribution_new(square_dist, template=dist_template, & - row_dist=row_dist, col_dist=mapped_dist) + CALL dbcsr_get_info(matrix_template, distribution=dist_template, col_blk_size=col_blk) + CALL dbcsr_distribution_get(dist_template, col_dist=col_dist, nprows=nprows) - ELSE IF (TRIM(dim_type) == 'COL') THEN - ! Creates COL x COL (e.g., Aux x Aux from mat_Z_lP) - blk_sizes => col_blk - np = MAXVAL(row_dist) + 1 ! nprow - ALLOCATE (mapped_dist(SIZE(blk_sizes))) - DO i = 1, SIZE(blk_sizes) - mapped_dist(i) = MOD(i - 1, np) - END DO - CALL dbcsr_distribution_new(square_dist, template=dist_template, & - row_dist=mapped_dist, col_dist=col_dist) - END IF + blk_sizes => col_blk + ALLOCATE (mapped_dist(SIZE(blk_sizes))) + DO i = 1, SIZE(blk_sizes) + mapped_dist(i) = MOD(i - 1, nprows) + END DO + CALL dbcsr_distribution_new(square_dist, template=dist_template, & + row_dist=mapped_dist, col_dist=col_dist) + + CALL timestop(handle) END SUBROUTINE setup_square_topology ! ************************************************************************************************** -!> \brief DBCSR matrices deallocation +!> \brief Releases a distribution created by setup_square_topology. !> \param dist ... -!> \param mapped_dist ... -!> \param m1 ... -!> \param m2 ... -!> \param m3 ... -!> \param m4 ... +!> \param mapped_dist ... ! ************************************************************************************************** + SUBROUTINE release_square_topology(dist, mapped_dist) - SUBROUTINE release_dbcsr_topology_and_matrices(dist, mapped_dist, m1, m2, m3, m4) + TYPE(dbcsr_distribution_type), INTENT(INOUT) :: dist + INTEGER, DIMENSION(:), INTENT(INOUT), POINTER :: mapped_dist - TYPE(dbcsr_distribution_type), INTENT(INOUT), & - OPTIONAL :: dist - INTEGER, DIMENSION(:), INTENT(INOUT), OPTIONAL, & - POINTER :: mapped_dist - TYPE(dbcsr_type), INTENT(INOUT), OPTIONAL :: m1, m2, m3, m4 - - IF (PRESENT(dist)) CALL dbcsr_distribution_release(dist) - IF (PRESENT(mapped_dist)) THEN - IF (ASSOCIATED(mapped_dist)) THEN - DEALLOCATE (mapped_dist) - NULLIFY (mapped_dist) - END IF + CALL dbcsr_distribution_release(dist) + IF (ASSOCIATED(mapped_dist)) THEN + DEALLOCATE (mapped_dist) + NULLIFY (mapped_dist) END IF - IF (PRESENT(m1)) CALL dbcsr_release(m1) - IF (PRESENT(m2)) CALL dbcsr_release(m2) - IF (PRESENT(m3)) CALL dbcsr_release(m3) - IF (PRESENT(m4)) CALL dbcsr_release(m4) - END SUBROUTINE release_dbcsr_topology_and_matrices + END SUBROUTINE release_square_topology END MODULE gw_non_periodic_ri_rs diff --git a/src/gw_utils.F b/src/gw_utils.F index a4206cac50..9caead6cee 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -296,8 +296,13 @@ CONTAINS CALL section_vals_val_get(gw_sec, "PRINT%PRINT_DBT_CONTRACT_VERBOSE", l_val=bs_env%print_contract_verbose) CALL section_vals_val_get(gw_sec, "TIKHONOV", r_val=bs_env%ri_rs%tikhonov) CALL section_vals_val_get(gw_sec, "GRID_SELECT", i_val=bs_env%ri_rs%grid_select) - CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RI_RS", r_val=bs_env%ri_rs%cutoff_radius_ri_rs) + CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_RI", r_val=bs_env%ri_rs%cutoff_radius_ri_rs) + CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_AO", r_val=bs_env%ri_rs%cutoff_radius_ri_ao) CALL section_vals_val_get(gw_sec, "N_PROCS_PER_ATOM_Z_LP", i_val=bs_env%ri_rs%n_procs_per_atom_z_lp) + CALL section_vals_val_get(gw_sec, "N_PANELS", i_val=bs_env%ri_rs%n_panels) + CALL section_vals_val_get(gw_sec, "KEEP_SPARSITY_RL", l_val=bs_env%ri_rs%keep_sparsity_rirs) + CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_W", r_val=bs_env%ri_rs%cutoff_radius_v_w) + CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_G_W", r_val=bs_env%ri_rs%cutoff_radius_g_w) IF (bs_env%print_contract) THEN bs_env%unit_nr_contract = bs_env%unit_nr @@ -1697,15 +1702,30 @@ CONTAINS WRITE (u, '(T2,A,F37.1,A)') 'Input: Available memory per MPI process', & bs_env%input_memory_per_proc_GB, ' GB' IF (bs_env%do_gw_ri_rs) THEN - WRITE (u, FMT="(T2,A,ES44.1)") " " - WRITE (u, FMT="(T2,A,ES37.1)") "INPUT: Regularization parameter for RI-RS ", bs_env%ri_rs%tikhonov - IF (bs_env%ri_rs%cutoff_radius_ri_rs /= -1.0_dp) THEN - WRITE (u, FMT="(T2,A,F31.1,A)") "INPUT: Cutoff radius for grid points in RI-RS ", & - bs_env%ri_rs%cutoff_radius_ri_rs*angstrom, " Å" + WRITE (u, '(A)') ' ' + WRITE (u, '(T2,A,ES43.2)') 'Input: RI-RS Tikhonov regularization', & + bs_env%ri_rs%tikhonov + IF (bs_env%ri_rs%cutoff_radius_ri_rs > 0.0_dp) THEN + WRITE (u, '(T2,A,F39.2,A)') 'Input: RI-RS integration sphere cutoff', & + bs_env%ri_rs%cutoff_radius_ri_rs*angstrom, ' Å' END IF - WRITE (u, FMT="(T2,A,I35)") "INPUT: Number of MPI ranks per atom in Z_lP solve ", & + IF (bs_env%ri_rs%cutoff_radius_ri_ao > 0.0_dp) THEN + WRITE (u, '(T2,A,F44.2,A)') 'Input: AO grid hard cutoff radius', & + bs_env%ri_rs%cutoff_radius_ri_ao*angstrom, ' Å' + END IF + WRITE (u, '(T2,A,I40)') 'Input: MPI ranks per atom in Z_lP solve', & bs_env%ri_rs%n_procs_per_atom_z_lp - WRITE (u, FMT="(T2,A,ES44.1)") " " + WRITE (u, '(T2,A,L43)') 'Input: Keep sparsity in χ/G/W panels', & + bs_env%ri_rs%keep_sparsity_rirs + IF (bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp) THEN + WRITE (u, '(T2,A,F43.2,A)') 'Input: G/W panel truncation radius', & + bs_env%ri_rs%cutoff_radius_v_w*angstrom, ' Å' + END IF + IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp) THEN + WRITE (u, '(T2,A,F40.2,A)') 'Input: G/W operator truncation radius', & + bs_env%ri_rs%cutoff_radius_g_w*angstrom, ' Å' + END IF + WRITE (u, '(A)') ' ' END IF END IF diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index 68a5a348e7..8dfc723158 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -2590,19 +2590,23 @@ CONTAINS CALL keyword_create(keyword, __LOCATION__, name="RI_RS", & description="Real-Space Resolution of Identity (RI-RS) method. This "// & - "approximation replaces the conventional 3-center RI integrals (μν|P) "// & - "by a factorized representation on an atom-centered real-space grid "// & - "{r_ℓ}: (μν|P) ≈ ∑_ℓ φ_μ(r_ℓ) φ_ν(r_ℓ) Z_ℓP. "// & - "The coefficients Z_ℓP combine the numerical integration weights and "// & - "the Coulomb potential of the auxiliary basis function P evaluated "// & - "at grid point r_ℓ. To reduce the computational cost, only grid points "// & - "within the sphere B^P are included, where "// & - "B^P = {r : |r - R_P| < Rc + r_P}. "// & - "Here, r_P is the effective Gaussian basis radius for atom P at which "// & - "the basis function magnitude falls below a threshold δ "// & + "approximation replaces the conventional 3-center RI integrals "// & + "$(\mu\nu|P)$ by a factorized representation on an atom-centered "// & + "real-space grid $\{\mathbf{r}_\ell\}$: "// & + "$(\mu\nu|P) \approx \sum_\ell \varphi_\mu(\mathbf{r}_\ell) "// & + "\varphi_\nu(\mathbf{r}_\ell) Z_{\ell P}$. "// & + "The coefficients $Z_{\ell P}$ combine the numerical integration "// & + "weights and the Coulomb potential of the auxiliary basis function "// & + "$P$ evaluated at grid point $\mathbf{r}_\ell$. To reduce the "// & + "computational cost, only grid points within the sphere $B^P$ are "// & + "included, where "// & + "$B^P = \{\mathbf{r} : |\mathbf{r} - \mathbf{R}_P| < R_c + r_P\}$. "// & + "Here, $r_P$ is the effective radius of the most diffuse RI "// & + "auxiliary Gaussian on atom $P$, at which the basis function "// & + "magnitude falls below a threshold $\delta$ "// & "(currently controlled through EPS_FILTER). "// & "This locality approximation yields a sparse representation of the "// & - "3-center integrals enables reduced computational cost. "// & + "3-center integrals and enables reduced computational cost. "// & "See details in https://doi.org/10.1063/1.5090605.", & usage="RI_RS", & default_l_val=.FALSE., & @@ -2611,35 +2615,44 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="TIKHONOV", & - description="Regularization parameter (α) used to stabilize "// & + description="Regularization parameter $\alpha$ used to stabilize "// & "the inversion of the grid-overlap matrix "// & - "D in the Real-Space RI (RI-RS) method. See Equation (9) in https://doi.org/10.1063/1.5090605.", & + "$D$ in the RI-RS method. "// & + "See Equation (9) in https://doi.org/10.1063/1.5090605.", & usage="TIKHONOV 1.0E-8", & default_r_val=1.0E-08_dp) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="GRID_SELECT", & - description="Selection of the atom-centeredgrid type used "// & + description="Selection of the atom-centered grid type used "// & "in RI-RS optimized by Duchemin and Blase. "// & - "(1) def2-TZVPP: Grid optimized by Duchemin and Blase, "// & - "available for elements up to the fourth row "// & + "(1) def2-TZVPP: Available for elements up to the fourth row "// & "of the periodic table (see https://doi.org/10.1021/acs.jctc.1c00101). "// & - "(2) cc-pVTZ: Optimized grids available for H, C, N, and O atoms "// & + "(2) cc-pVTZ: Available for H, C, N, and O atoms "// & "(see https://doi.org/10.1063/1.5090605).", & usage="GRID_SELECT 1", & default_i_val=1) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RI_RS", & - description="Override (in Angstrom) of the truncated-Coulomb cutoff radius Rc used "// & - "to size the per-atom RI-RS integration domain "// & - "B^P = {r : |r - R_P| < Rc + r_AO(P)}, where r_AO(P) is the spatial extent of the "// & - "most diffuse AO Gaussian on atom P. By default (-1.0) Rc falls back to "// & - "CUTOFF_RADIUS_RI from the GW section (the same Rc used to build the RI metric "// & - "integrals). Useful for convergence sweeps.", & - usage="CUTOFF_RADIUS_RI_RS 15.0", & + CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_RI", & + description="Real-space cutoff radius (in Angstrom) for evaluating "// & + "the RI-RS integration domain $B^P$. Overrides the default "// & + "$R_c + r_P$, where $R_c$ is the truncated-Coulomb cutoff of the "// & + "RI metric and $r_P$ the radius of the most diffuse RI auxiliary "// & + "Gaussian on atom $P$.", & + usage="CUTOFF_RADIUS_RL_RI 15.0", & + default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_AO", & + description="Real-space cutoff radius (in Angstrom) for evaluating "// & + "the AO basis functions on the RI-RS grid. Override the default radius "// & + "derived automatically from the most diffuse AO Gaussian on each atom. ", & + usage="CUTOFF_RADIUS_RL_AO 8.0", & default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & type_of_var=real_t, unit_str="angstrom") CALL section_add_keyword(section, keyword) @@ -2647,21 +2660,63 @@ CONTAINS CALL keyword_create(keyword, __LOCATION__, name="N_PROCS_PER_ATOM_Z_LP", & description="Number of MPI ranks that cooperate on one atom's "// & - "Cholesky factorisation in compute_coeff_Z_lP. Default 1 keeps "// & - "the single-rank LAPACK dpotrf path (BLAS, fastest when "// & - "D_local fits per rank). Setting > 1 enables a ScaLAPACK "// & - "pdpotrf path: ranks are split into atom-groups of this size, "// & - "D_local is block-cyclic distributed across each group (per-rank "// & - "memory ~1/G), the compute_d_lp build is also distributed across "// & - "the subgroup, and multiple groups process different atoms in "// & - "parallel. Use for systems where n_local_grid is large enough "// & - "that the dense (n_local_grid)^2 D_local does not fit in a "// & - "single rank's memory.", & - usage="N_PROCS_PER_ATOM_Z_LP 16", & + "Cholesky factorisation in computation of $Z_{\ell P}$ in RI-RS. "// & + "Default -1 = AUTO: "// & + "each atom is solved single-rank (fast BLAS) unless its dense "// & + "grid-overlap matrix would exceed the available memory per process, "// & + "in which case it is distributed across a rank subgroup sized "// & + "automatically (ScaLAPACK). Set to 1 to force single-rank for all "// & + "atoms, or > 1 to force that fixed subgroup size for all atoms.", & + usage="N_PROCS_PER_ATOM_Z_LP 2", & + default_i_val=-1) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="N_PANELS", & + description="Number of grid panels (batches) the real-space grid is "// & + "split into for the streaming chi/W/Sigma contractions in RI-RS. More "// & + "panels means lower peak memory per step but more overhead. Default 1 = a "// & + "single whole-grid panel. On large cells the number of panels is "// & + "automatically increased beyond the request to keep per-rank DBCSR "// & + "messages under the 32-bit length limit.", & + usage="N_PANELS 4", & default_i_val=1) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="KEEP_SPARSITY_RL", & + description="If `.TRUE.` (default), the W/V matrices in the "// & + "grid-basis contractions of RI-RSwill used the sparsity pattern of the "// & + "corresponding G/D matrices. "// & + "Set `.FALSE.` to build W/V fully dense.", & + usage="KEEP_SPARSITY_RL .FALSE.", & + default_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_W", & + description="Real-space truncation radius (Angstrom) for the grid-basis "// & + "G operators in the RI-RS GW self-energy. "// & + "Default -1.0 disables the truncation (exact grid-basis operators).", & + usage="CUTOFF_RADIUS_RL_W 20.0", & + default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_G_W", & + description="Atom-pair distance truncation radius (Angstrom) applied to "// & + "the AO/RI-space operator matrices G, D, V and W themselves in the RI-RS "// & + "GW contractions: matrix blocks between atoms further apart than this "// & + "radius are dropped. Physically consistent with CUTOFF_RADIUS_RL_W, "// & + "which truncates the grid-basis products at the same kind of range. "// & + "Default -1.0 disables the truncation (exact operators).", & + usage="CUTOFF_RADIUS_G_W 20.0", & + default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) CALL section_release(subsection) diff --git a/src/post_scf_bandstructure_types.F b/src/post_scf_bandstructure_types.F index db4c89bb24..30c859bc2d 100644 --- a/src/post_scf_bandstructure_types.F +++ b/src/post_scf_bandstructure_types.F @@ -69,15 +69,19 @@ MODULE post_scf_bandstructure_types ! Input parameters for RI-RS INTEGER :: grid_select = 1 REAL(KIND=dp) :: tikhonov = 1.0E-08_dp - REAL(KIND=dp) :: cutoff_radius_ri_rs = 30.0_dp + REAL(KIND=dp) :: cutoff_radius_ri_rs = -1.0_dp + REAL(KIND=dp) :: cutoff_radius_ri_ao = -1.0_dp + INTEGER :: n_procs_per_atom_z_lp = -1 + INTEGER :: n_panels = 1 + LOGICAL :: keep_sparsity_rirs = .TRUE. + REAL(KIND=dp) :: cutoff_radius_v_w = -1.0_dp + REAL(KIND=dp) :: cutoff_radius_g_w = -1.0_dp - ! Number of MPI ranks that cooperate on one atom's Cholesky solve via - ! distributed pdpotrf. Default 1 = single-rank dpotrf path (BLAS, fastest - ! when D_local fits per rank). > 1 enables ScaLAPACK: ranks are split into - ! atom-groups of this size, D_local is block-cyclic distributed across - ! each group (memory ~1/G per rank), and compute_d_lp is also split across - ! the subgroup so wall time matches the BLAS path. - INTEGER :: n_procs_per_atom_z_lp = 1 + ! Data types for cutoffs based DBCSR matrices + REAL(KIND=dp), ALLOCATABLE :: chunk_centroids(:, :) + REAL(KIND=dp), ALLOCATABLE :: atom_centers(:, :) + INTEGER, ALLOCATABLE :: grid_atom_boundaries(:) + INTEGER, ALLOCATABLE :: pan_first(:), pan_last(:) ! Data types for building grid points TYPE(rirs_grid_type), ALLOCATABLE :: grid_cache(:) @@ -524,6 +528,11 @@ CONTAINS IF (ALLOCATED(bs_env%ri_rs%grid_cache)) DEALLOCATE (bs_env%ri_rs%grid_cache) IF (ALLOCATED(bs_env%ri_rs%radius_ao_per_atom)) DEALLOCATE (bs_env%ri_rs%radius_ao_per_atom) IF (ALLOCATED(bs_env%ri_rs%radius_ri_per_atom)) DEALLOCATE (bs_env%ri_rs%radius_ri_per_atom) + IF (ALLOCATED(bs_env%ri_rs%chunk_centroids)) DEALLOCATE (bs_env%ri_rs%chunk_centroids) + IF (ALLOCATED(bs_env%ri_rs%atom_centers)) DEALLOCATE (bs_env%ri_rs%atom_centers) + IF (ALLOCATED(bs_env%ri_rs%grid_atom_boundaries)) DEALLOCATE (bs_env%ri_rs%grid_atom_boundaries) + IF (ALLOCATED(bs_env%ri_rs%pan_first)) DEALLOCATE (bs_env%ri_rs%pan_first) + IF (ALLOCATED(bs_env%ri_rs%pan_last)) DEALLOCATE (bs_env%ri_rs%pan_last) DEALLOCATE (bs_env) diff --git a/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp b/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp new file mode 100644 index 0000000000..a390c6e1a9 --- /dev/null +++ b/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp @@ -0,0 +1,83 @@ +&GLOBAL + PRINT_LEVEL SILENT + PROJECT RIRS-G0W0-PBE-H2O + RUN_TYPE ENERGY +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME REGTEST_BASIS + POTENTIAL_FILE_NAME POTENTIAL + &MGRID + CUTOFF 300 + REL_CUTOFF 30 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER MULTIPOLE + &END POISSON + &QS + METHOD GAPW + &END QS + &SCF + EPS_SCF 1E-6 + MAX_SCF 500 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING T + ALPHA 0.2 + BETA 1.5 + METHOD BROYDEN_MIXING + NBUFFER 8 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + CUTOFF_RADIUS_RL_AO 1 + CUTOFF_RADIUS_RL_RI 1 + CUTOFF_RADIUS_RL_W 1 + GRID_SELECT 1 + NUM_TIME_FREQ_POINTS 10 + N_PANELS 2 + N_PROCS_PER_ATOM_Z_LP 2 + RI_RS + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 5 5 5 + MULTIPLE_UNIT_CELL 1 1 1 + PERIODIC NONE + &END CELL + &COORD + O 0.0000 0.0000 0.0000 + H 0.7571 0.0000 0.5861 + H -0.7571 0.0000 0.5861 + &END COORD + &KIND H + BASIS_SET H_MINI + BASIS_SET RI_AUX RI_H_MINI + POTENTIAL ALL + &END KIND + &KIND O + BASIS_SET O_MINI + BASIS_SET RI_AUX RI_O_MINI + POTENTIAL ALL + &END KIND + &TOPOLOGY + MULTIPLE_UNIT_CELL 1 1 1 + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-gw-realspace/RIRS-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix b/tests/QS/regtest-gw-realspace/RIRS-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix index 6e19f1a2afcd5f619351e0413435ad1e1a5d7298..d13f131f6fc639c207c58fab6fe9c5f6d7efe92a 100644 GIT binary patch literal 103043 zcmd3tWmHvB*Y9bN5=BZ7m5@+SNduT06h#qHloF&v5ReoQLAtv^B&EAcScmRzLFo{c z5(Gr_9-sSsymyTI;r(#;82>TPUT5zWzj@9YE9SZ>bK{ZHOYO^om&|o-wV!C4Jvj3} zbloQ+ARr*di{Zca4Bq~~i0=RJ9L4`7jS8Pm`d{(mEy20}UEa*UFYwpDI*{N+hS$G5 zDDk4kix#hcb0Cd;%f9;j?(FdyIg<4G*XR58*7nL1*zG8t~Q)?=W3Fv{^h9LOfh) zJeU-`O<}=*#)Eu_hZKgl#jFGbm&pkTj-4VP7{FUAJTxmj4nD75{^P5ET>ts&pHKh!44>_P{Dy!1Kfe3- z_&@*QoAe(a9>v>#e#AHBKfa{L+kgK2_nZ6Y`~PYEt7i&c|2Y0*_>bQ|cK^8jWA=~N zKUV)Z{bTfx&wtq9x%^}DkHxjSuX$heJh}&Ok|`k(uD%Y zFH7e-3}Dkb_qe)*1#~8FRt5jCh3%fPqjFiEaL}eU*p%i9o<4s)Toqm6xuU^`PRt!@ zS`0mL7J*<)b5nkKEgtMHJ#u3H8VmtJ8M$iR?y!B4Ot);&AMQja`00O401eB#ksPa8 zu*Q2)!aXG$O7c{)zEY-vR5}0aQP~WDq~n$s7Gq$CdEaqII0iE8Dz}$NW8rKDk4?e( zNVv=T>wD(wa7aCQqwhyl3fKqWjMsG2fTW7}m|1TWoO;x9;tOc-s|f>uQTL0e(RJ>+0nP zfs#^mCnmy)S7hry3X(q*Kb>3OxvZ0V<7<8W*_$Jy=hSia6lo7Bxbpkz)de$r7c?sB zrFi6Qj)X7O8*o&{f8d^z8oJn%8uNBos>&dmvi8-_`q*PJC5CFd^^s;Ae(TGN^%0MA zFPLvv)^m2>si$=LBGs8z)}-OnUoUxwrqO0!0S;QPv@d1eK{8hvgW36Q>%UM}9C5xS z4z!vxLCJlDaLT0IRXvjy#W(4QuFEdg(|B}dv-ZzDWrrV!qGOj?HyXk`;x9m`*#MIL%b~#j}oMJ@gdJ`Ef zUrF)#C5L9xQ=7PBt|CM38!cvxQphMyiNkGI7U^e`2CAprNB%+I1291?46NKE{nyDUDI%P~*Bfw2hkVyv7RopQrdVu5OM*dP&Y?_dG|=AGh;U9bY4&JkH~LF)oPDNFek6A4{Yi z^jFt*#0xd@Gm-t;@kLhoD?1mtywQ>P_Yad)gV8B|IeE9s@=&*OFQ>!p0hrp#nKaW% z13_;=06Wc1Krd)1MfUFjiCafR!_CLgND=ERHK`8;1Hw5Dx!S^@ zbwTU4-lYepp2L^pp?WcE4p8s~$Bt|)fI*f*TlJV8IIfTM%zSoZJ)!=yVkZHwJxo8J)FjuogRl+PbBxFBLGSOx zsA;)1+>WaYX%Ml7>Y^d_tL+AWmpiy$gj`cf<2KJ-&H-N)+Ss?(*vkKR{9lE($NP^VhR zc)RAI(VYWvNZ9m?d{7J3S``uT$->dcAJUlzuP(KHr|= z6Ib?u6fxZ#(+E%K8U6T|cqt03lqq>!?8AU3|KrkRQaA)R*M>GLyF)Fm@TvWNAh3!J zT~E624+JhfKM6`*!0d!-hJ9o(v_2R)Hx=UsvAk(lOpFp>kL|4YUy(>~aOLfxV~GMM zd3w1s?E$cq7I8pm7Z2Q=N)?kvexUfcyo9KiV z^Bh!#cHNHeAwz=AV?moM*FaoM@2cQ00aV|ubKT{!B`nuZddM~!A+Nfd*$0ugP{%FV z_cY>4$OH6GoTm4OJlWy07Un<{Cq{=HpWQ~YlGlG|INn890_n5Y8*QQTai$kqo^V%p*It6v5w=G~D@+UA&_@r)x|r7sAn+OoN?(qzoGS^PQ}C+!`%a#M<15S(Y*<$m@OPBMrkI_r7U4 zDx&%ir%w4;d4UAOjFV@G6(Z!KliF`{L`2HJZExOmKy!?cZGFxMX*W9(25)(ymrpmd z?-IMB(1y@~9a1;MC0%onToZ||nk2FvNeV-U*Ib>n|IhXU+;cWta( zQF&Cyc}~9sq-bEL>+~W4ZM;_-lIV*>TV@Ypq;|s4DeHk}d3GV_a^)W}LE!+j{p2fe z?OrItK93pZ28N+R*1%~IH#ej-MeOBo+pJV1iXqHa{aFdBscUh?qAJ%ujIz*hhmpL3v*3{a|1|loOAwdk5$w)d7coa=5yG6o+*X67w zmlV(@iETCW3x`kBY2Tw=l0hu|Sl{gLFfg!^;!9?Vfe$q2K<8FCC|eSR5=k|~l`e0i z0#zK?hxol$`ql*OQIV&JOg;d47ke?8aU00o!~L13s|6kFqrdd)JHf`^Y1X`;0R;1B z3Qgr&L6&2T^9Hm6sZ6@Jb$t^oR{prBwa^F$9n+#+EI1gpBwC{!z=6^0Fqd$)Zg9DM z?s?JoW{A3J#m(@%0p6~ei##H1g`yJz{wG&zA*jRm%_w^}*tenQQv?lgAZK*+8Br^w z*5qz0%;Vq(BhD{4xEVsL7>Pum|_64yeYA?_53J1Zx|NRixL3fV?}@ve~#3 zcHFWJqn~!dA9acuFYbOg6<2IHNZACm8SlnUO(npRINQw2uTijD@Uz^PJQ2nNl828H zhr$n%EBDt8Q(#xv-EYY#2sAQL=|*QdjB)s;k`+fovFDvLI_KWQmE7WU6n+U%w%eZ8 z&l3-pVW}mpuVR6baVB$xG912yFC_h4ih!0TZO`faRG1}C`GZIj;n*Q=T%9@!=qfas z>RjFehqNtyW_uW@eEi9#Vx9#|L=u&pC-Y3j!cgms>!gaJnXpTo(Z5XH%YopM$*FPTO zLR>+j={*&-oF_U#GF#5!mj)#(l!G_mE!rz|zn#ey07XZnv#oqW5bq;`m)3<=(C6o( zzcTCvwpBj@W}ZvKM$R=L(R~ASHZt0E8g8ib>{M^TC12#0A(YT zmd+GT0=g~hWgW`xg?{3CcNS9PLAL7QcTUkHw68r{Gui(f=JJ$&7km*zvmz*@?`>I8etFhtM7iv2 zq53c#k^a7aRrpIXs@-|GL30p`oPIquqMuDgv6?6S*5|!Z2tlk(O>-{tYF}UPj0;6M zJ>{DMh1rO&sbYCy&=+xY*lX_2zenL-$0FVk2O;w|k@CL}@{xYWt&i2GgV8~`&oi&| zGSqQ|@VTSjJ2d<1F;P3dJQqI_TBlcGs49t`T`@cgEpmLx{F0OeE#s>ea|Dr~%ll() z&>$NgEqTU$35tfl>tUR`JO!Y2D6cU5AQliawA36egzO{no6$eR!7$Xtz??T1HbbA= zAp0n&UtO(kWJ?43PIEt9gB0*OqJ6$dyP`wv`KqM?oEvHUlVEFk^m`9dW-6{_E< zTHh>)1|ODY&DwLZ&^w*jaO*@I{9seP?m3YG6?rn7U-uF~rO@7&-6a+>DeI1pTuuVp zYai|)9VrFJ;WVfdPWp%1#0Qf0549t1Dx!qEb&0jRn(beV6u4G7GbSlUN>!Skr- zU-;M#20RjNyUHE#iFYUXY<@F*nTd1|x;qM#(E{fMo^`{Ol|QqRjeX!aMaCF2&^6q?K*o!V)1;4_EH?2r!4^6o!ZT`p>$w=q8m7IHXM?%or`hvP9V}s z=T-D03MHF00N)c6^lR`3%gDV9Xl8ow`&&>L7|yilQa}uHT>rLN-57wBHD6q?+Dm~& zu2L#j7dMz1?Z+KqNkg+Hs|>Y~PRRL-^Ivk3TWHKp{x3a^EGo-2d_l|P06Av-q%4mu zVAd{3N~_!*lyOhF{@8n?+#|dVhI@&isFJ8t`8*9p&kjo;`RfH!c^NW8K%G0I) zhN9zVbHdb<#ZW8HMaz4KDbTZN=G{7B15*z4uYB($p?2C{wi|~JQQD(BXYL(Mg}S3l z49&jjNUVNDO4>Ufs+BJ{X`G2fb9KCBn|i_M;l19LyDKrMk#=Lb_H!622)28u))I}f z@95~ibT3AHmo}*rA7!FT1}ffugc)c;JJEsUNiho7*Stw}F%HeT-C&CjOGISme54Db z3Fx~8*BV!6GO`W)s`bpw6Ip#Lp`qT4MpD{4=9$VlDCCMxLJDmj+S{U%?$nP!*Bk^S z81VhkRj*N#xB8`MUM!?D(X9|2^;wz_t_wmOkL&o4DZNMM#cv#Sc@}~)5375+latXj ziHq}Jl!7+R@6$tACc3tALg%4GD$+9cBR+jlh)$Ta1{S2JAeIZrU5YXdnaog8G_~ZQ z5375qKRO-hz0>8gmB<1EcAmPc_fz1`f@{xXy#hE&m(%#VFdkxEMDN!WRKV~`;IU+- zICxn}ozdc01QcJhrdBVffPqK8_sqvKxTtZKKKfNWkdoI>*zUJ2AX-%BJbVj=l^G2g3{Jh(;r^y}mOWH^}+&^T9+4QFv0 ziv+^CVB&c*t#q&o6wg(%d%Vhqr6dax(5?Xm&67@V$lpU);oH{B5>0SZ_{313PBKJO z4@SOa$3YEel>7VmblCgBycEDw29&*XhBOjFOeMgy?b?LT(1=`&Ebne+y~>VZ@G%cr|ECLv#xVS}{b6TGwY*7M0&0cP4z%^j&Z zNM!4d(l?p~yTf@6Zu14$Ql>cU=lcxYgT}msa`VudVe>BBdl6#P8mUz5KLQxt)7aw} zg+YEEt!es2XiK1ZV($DA{%B#ewK1#E*KT~IU2*{$2qq7^hQGkuyKcCXk)PopiD=8P zc@APu9ULozj}Xx|pqTc36l@>H$=`MR3=YkCuNH_)AWQt>Ycugu;D0XiNGKu;bn~+( zL^pGxr#V7bI4T!1?UXi+EbD>h(!+v!sT`0OD)*2Z%7-=3{Hx~7tHDIZXdW$-90B(ANy81cNFZucg1K_`75BoF>Q3s)B>aoItc zaQm$0O7XBaSaN=Nf_eL*H)_$YX8A_wc}IbhQgbmd3bM}<3?~3QaDFP8#9} z=xwl*szUcg2G}g$grPs31(no26=>;-NzF9zJJkE`thdF>dc+Z%U*g=Jimnx0lO_1s zg;ep=lgCY!D9Q4Qj@*}W^!1c(q;5SUGwMYNdy{SaiJ?dn0TUF>x+q*Bh86_xyHNs7tgpS^%l#mds1`Ba26*bRl zP<6|mrDn^7vR$T1%$KrNwYep!!8YKn5r&v03^k z6yfKSyJj1CRj@|QC=_-v3sh?fSf1n;0rwh@j!kt9uqm9YE*~w2)fM-KRmy6R5Z`Kh zK3fS_*(&p2YIK0<0cXW@RS8^_eI($0vKbutUL1qLwC_0mYZ&-_nQ|!1U7<&L_4L z@YuBVT*J#*xOvCn!tq~=5E?gO+OoS2oUEc}89ly2-{K9?<8rHzI+OimpJ*A#swI1s z#n-{Amtg9{qc89TCzef7y9rM&8Wodpe*=3qDe9!LRVWJFn)x%i42+R{SZ>D#RQHOn z^!qNsPer!f;P6d&|Lkil}{zt0;WRRh<`SW`4{8&3()!z($jkQY=40SLezTU_8q!T{Of0xR5 z-U?6Y24l3B8=)%FjOfs~0WSIY3iM8=!cv14t3^pO4VhExPu^7^jZ zlciumwm49Hp&e4|t#&N7>!6AL^_`)Yoe(^`7{sOB09v%S=DtObLV0H3yb)%JEDnEY z%9$F#n>}?wyY6VFv zSd$-TyKfYu@590+zkXG~nrf}VUB48x)^^Tsv!fHHC6*YN9a~YVi8pJ6LM2Skl^0*1 zDMp>vIrrb+(nR}0ak@ow?_qKyGfl!q zBS*fL*lP8uMQGQedo!DA3C|w$V)il$D)CHn^!X&Fvm61MVbeEtCGA~}M zv}W`(J-8?tWJ@l8pBa5BL?04q$Lw#{wbF4}-Fd`;|!OtJCC8$}mb% z8mDM@UW7KzF2{ zryHJTVn-0`d|jcJeF)B$)cF&!G{Dd39v;av-EdrzWPYH&DsLg5<;k>xIZ?K5*SBy;8Y}2#ForR)L0(+r6*-yL8!7^BG@+6S##DI%4;C16QucDVa&AHV(;A**lx8JgGw zsjjQ;0=u|pkkI`d*wQWj!2Mza?ySj{`#NpIHTTKm5@-GZo7kPaJlWQ#PlwRhSXRB}NQyb@*`AvgT>#_Navl$U zax9eg?+Y4-Phj>&@SeK`C6>6kZSN+r3p0Wo8L_vhu{EBvljI9M;PXt*B<;nWj$G`5 zXhK~fvw;jKZYgrV%hd*-uP4x6xnBTzuJ_;1wG6=X4PF&B)CP^GU9Xh{;nyb~Ll1}H zAWSMNPk%c*2#U$4egxFnDhFuclrw8Fdy9@!Yi^ZprvppVPL613=em?vWc=0o~(C5oi4d(KDy+d(7I!=$(B0dExn|NRRB=`iV=n zh-lpE)n#*eWFsZeD|0ms7F?}8FOL*KNq54pOMLaHS6Qbr$e7EMeXIuhG41LpIDu zA0EDLLW8B9$Glz+p!-?Tjg;yAh$!c<*?OZJgg%uHp2qc}`Yjg)3$_?!uCCo^HPDOp z-OCFeZ!5t`>NNTD_TA{nN<+ul_xOHvhgHq|$sjU%L~-$~a~(1;ki5riGKJKSoj7g1 zP=ubIOShJ+A4FDc2k|n$Q<1f6u43HXKBR2^bNR_x1H^go{aeJ{78LVvH|B3E87LW{y%Jj;S63r$^ygR-gDbWqtH#3V_94kRLYWNfh zT?b^2a`R^>bi;!P@x=P;_29y{$9j>r4S2<7JGj%@;e!VMy=O7w5KA~tHyO|hg*|R3 z`;Sk6B-vk|DBc#}H?V&HDyjtDcIQ~9Np=Bo!`TcyH96ElQP3muvjtX#pM0A>)d@3_ z*L_EQ+d)}dp1i1}2of&wNnX0r25~&Y_uL-M1Am3WEvoeqcuKx@{>3>Qd=`D)LA})n zVvkRsR-tx-{mg#mPd!EIK2n(WGV`X|rjIGUox;HWQ2kd8ULiBb>vGgrIzuc~F=x@>w zuDAXH`@7fN+xK=LPd8oT^CuE)~kX~h3#ZUV=`rZcolf^m%wZSrq~pC@j$t5&v*ht8Jl+ZB|Bm7 z#M=i_R5Or`tIXNUD22oP778hnRyc3IjP9-U!eb@kygavAkWeBeZ2r>^Ten}7r}A&W zj?RlGhUY7gPpzk^IBEwRZfO5EK3|<0dA9+!eV8F-NWT9(1^A^$A0Beezz_E;B9=3S zK&2R(OIyDIDNLE%iUKQeaO)mU@?HSDXdD=5*J3B;X{ z{R%Gytyynaw?S*f^+yjz77*^^<@Hg^Phj}=eZ;Ldz33LbT!pm84|pBXvh*SNJDRDx zYjd}19A-nDUfAufps|rft`S>X#33;us924l@crIRH;Qy5w8_C(^|~CEKl(5TJH~+h zCHdnNw-OP#Ra7$?u>%*Q%YjXt3+SVU9jx8tS0DT4B0`TFJci#K(fikXXe!GP>3dtd9?}QEUBT18xm$-o`^|56 z+PP8iVzNv3dbtM?K5=EaWgV!gP;~6~E)i~(;&!(f{WQ#ywLGCo--ch6iz1qr%FtyT zxnJg+M%XZv38xU8LKyeKpE}(>CKHKk1qw962QqI(M!c(iwgtrOF=uuIUaBJ&4440mN zbvy45`Z{&IXv3Hj^}8XhjbqD5B{1YytXD9wtC_Lcn0-UhiMtP9G>-u|^7M-ZQ=9VPx@E&`+=YJ7$kMf4nQw%nKib&0T6=*; z@4g?Y!WU4Q@ck}yd=;F?lyo$l=rGUowG%B%99V*LkfUB?H=LpHdL|sph1Iael+Ks; z0jY2K6)!7xY+LuZ5#1meM(TIUqbHjjdlw#E`n%!;rZ2D+`VdEtolQ)#*Kzy{H@eJ? zXkX}HoS!c_(3~K|a*zBHJld{-3BNbKviE`&i;SdXt3|i5h!CyLWVd6Ou+r5ILjrZo zu-bm+d>cQeE*$uv$oVv8mHtTkuv8oq{&V)P_V#rwZS zpuU7HEqBWJcuHY!lOsLeWs_pVMmfHWf%|Z4L?oAENCf+J)af99MHG`KvWQ+ewgVd} zQ!K)MEEwhE48JDD6>xq1x_32x0}{A|x!FFYz*G-Y%>D`iHpE)@b^dZGJhfzWRxY5 zS~CGXUlfpHs@sAq(dU}O$Tv~B?iD|q*>qIL5XM7FOoX!~UjJ@qoDOo#;aqS(A?LJwj6tvPInx`-TOx2-J;ux((f+**vapOfd{%{GQpG3 zTwBC_=@&5;kT#ZfVV4!7>IimmD&xlG?eN^w`67tbf7EZUTfK&JofuRv6)r~tdXjGf zg5u$$e>g>I+%F_?p6A>#;XOFJM9%#v`#pT5^q1y}nLrgrUlQQXZxFt{aZ=s(0NJ(P zF1{&Z36~`rZ|Cw7;!IuQ0s#w$yDsV+v9T05>E~j+n@`Nq*rl~Gf~5|i>{F3)onAy; zuMEXcVhzZqW@IP%hdXS_#ya!f5yf>9-sTe6$cCJ5rqD;P#c*ZUGX!rte1o&PW|a+1 z=W*g26t`maXFyG@^HS_@0o+Z6ch5L@_h9m;&jt0DB-jzjp{Fc+i8lTnCvdOs z=46b2C&x~-bW*&bV#L%x<%MAlggBEBx*W@}U&!*>S-Lreda$|{Q(;jQ2#g1opZL-@ z(3Ly_ZutZR<=aCz=W@CNXk0 zyqoZ5j9s(FJp%1oXw_wLG$20qgxDJSQLr~US+Yji1BoMoP1%m~sK%J{S@wq_4C_`GJaNy+S0^UKzTR**P7*G~ z#|N07Y-YTOy)I)|9|-!(|kRfxQynhZ|2%7{6O?~q7Sue=i!8IR_QuN6Dr@`n1A}64qGy|Wi?$rii-%{ zlD1dG)faw@Ny%GTpIH$*u+zIRD?p2BpYmop zp6!8~yjykV+!qWZSuf2dzSx;aG8N2VEa&uUpgqP-=W*TtGh^O9yduZ?xiGBCGIE#VIM&CfseG^DJVy58z?V`)5ob0Zt1*Ri zah%28Vi~k#nCdUN5b?cNxF+7D$fYk^AjlxbmXWQ9UEX|o{f7HIJbPs~WG!?H<9jGT zVr1a?*|w?r8?x(0UxVP+=`DBULxBw`mn_ zTgT;mq4C9e_6~4=E!hBKo%p*+KQ%GxBDGI>UOVu%RsM?Odme22Ti-7!BLS@5ATd2L zn+;2=HzqOseI27JC^d9D`2_RF20y7Z3S&OD+pjKWNMUI*=SDe6199$K7JPTPyl}I< zj(?2LlVHcg+_G47j^ToR^+JU8@i zL@^Tdme2BTV6(r67sH>=AZ4}{+glB{aSM~?C7drR!1;~ad?uj*R-R28tV!c)MA*_slj>FF|NBVvP#2*c0 zw`$5L-wMg3*dcAPeLNvdyVM}7zqm6%%1`Waw+ zmmY)^t9K&VFRWL8lZoIkQGU~^7dT*rlbz%S(n(;j?#{B-T2c}Jped`)K(xCDaT{HXW{n&SwzMy>+%hr8$*QVzjR)3QEdPI)}79}vJbBA6TtEwow&vKCoi`t;M#-GECGauFr z`svPyv9C#9F^y%#VUZT+63lMm%utc)Q&Cl%ircPyWj6t~e_Y6+kK;L}8s3Ucj?-cb zj?#rn863Ew(1j9&t%AdPHO0DwAx@d?+s!sbV%*(;x%`>O>bRW>8o8#)1C&BelSndu z2gl8oM5OnK2m37-6d@o{f~)zv@H)?*5p&QHHmRGi!Yz!}ztiU5g81|<pARi7M)n zKWG}m^mZ<^CAO$xvOk`>o>{*IbwVtOK0W&c{g>N|~l(Tj|Cie+ORXtUBajps5 z5q#)%=2{ZwePcqfyfqn9QmP$Vy#5InvTosjE}{jKf+P1Ip0dJig-^!C)$igagy;@# zS<~ZQZz;C_$k@bfNEChel|Lsli4*iTbtd&6gTuyh28Ur^+{w?h^fG*2C^AP=YXS?vRi7tf zApYl)d=v1Syuu;2*WIy+zL5H&ArAZ>jA$U#v#)VJ#xQ%Ra*#{B0wMJLNP13WN zUai`Cn$B^II_1n$)#VJV{L6$dA&&#DXvUdL&iX25%DBjLd|3vUNoP9M_Utmwt}}~a zM`s3O`%5SLRQ@9he;36NOz{e{=6?C4YIg>)vc4(ZoO8!ss&#!4vbluGY7}1U9jM0i zoLn6~Eel`;_C6PnHfCW?;uJFyC5qUCnQ!^)Nw2U!=wx!==n8J`LUYUs_F@zsCWBg%MjiQ)(cOYS=S}wNSAZ9+Tdl|c{ z63Ry8o`#VVu@dbUapBJYuEO`E^|<1bA`vPV&f-)(w0}L3FTmYBYbHM0{{lO4F=&Lr z*%2yuB~RTkX%BO(* zZTRI`l?GUFCTH`%-VASz%UUYV;^&b~)mDD3sP^B&&n*_SXT8q$9Ek)#Z zV-*UWZWo?AT!Dq3v41&K7U9ROKdvwK)8WyE&&8CQB9L=^WhtHU9*E|Hb=JI6p(fS; z)U)aoI4n7;_32kS3^XKcCDG>8)(|)^WlPt#Wx3P zg2TX;?EH~xuo@vW|I6M4Z1-=JU-E2+#v^*Q8)dB^%3?%z;&&IMDiZ~q-mHhd)ffFY zbt^z#oBEj5-7ZL9^E$uUQVzqFJmD5SBjEb7$v;P{3*w37p7mySLFd_hUEgcHFm2cw z!EM|H*RHmoyWIX5{gNZ3GTk-?%?k5&-=aoBsia&95p0gOmjXAjr#`(tL#??*{(z?R;( z)zZ!zmAfxE=>Cj>^Z+))hh=HtAE1&WZk3E4G!rz$j)$Y2XYRoq`2DckYX0wX5|ZKR zdwD`0ds{?JS1Gu5KOLptbS{=ojsOmUsB?B7+~6a9z;fzGFVy>0Rg(QzHfplPm0DtH0(4#x5)DbxCe;J!|#S zw7e$>JInBlxWprI5vH9ODg*HNDxVQb<_{@3o6K>puMy=5gSd5C8JAjy#3gIQsjr#1$^Kwpp)+fe%r<9cRK81VN^5)v1gqfcQH_kvsEIf*c1>u!57 z8%FHydJ}8MpFhCxY)P#Fzh2Hd?rc2~9Rl@rBRs)<`0?+(#h>PVN3rwtSBaHa4ng-d z<4A?Z7BqVO4%pA?fvW7)4}UDGfJTt!yf{lMhtVFtLU251+O_xg#+J>NMG> z6kBKEiC8byP}&Sk_hs}bInCnF8U4xP79zx64lD2W;P)LGBP1>}i2ed1zMs#&Eq?@g z^~9DI{b^unVWH=6G6YUjjp_%7KOms-`&Kq=+;b7bmX=Y2kBAoaej zzAr<~=tGdi5dw-)ILW0fZyfgpT3J0!6=k|m^3d#O?Y40=nCx4Zf3g<28NM68#qhg+ zdgqf~y+Q!6T>Kk5F`0$NKR>>!tN9r|TQWEqjkckysQ-=6Up+)r6+*PTS%P#VQXI`+ z#Demv;rbGDFTmXu@$cm-g(Ds&6~Cfh!@X(kxWDyT@L;su!z>{l%Du9>2nj+F!y-*# zUjG~9C`KyJ^KA^?&(6Eo@^{05tp7f#Wg`^b+4S-r?MHbTsXwavM?v;hZGZNe4=7t- zDkl5HC{XeEa6AzzLnLm#L)rmFuv<)bTkcZ@dgrP_-=LQXNkk=H5{s>9o@uV;b?6kZ zoK)Soo7sabI9{(5CJlk@Tyu>m$7fXP;N^Iec^N_qW#$6 zRT%`cQcm`oaq*DTdnIkrCL6JS^w@rOtOgZ4_OSo)q6aSfb6k$8>p)BwNBol_s)0bD znAi1b6cXYl8~83;i|lwLd#`-O_ruCRWt4&{KqZ3VnJNPg>{8?!gPFTQ#9E!O;9C_w zPPnB?`bRC2%TiwE$O{&WM{%OGOWrEzn#YTti;k~uCQSOaXwdDw}~*zn}T28mt4jigvuooI|;F? zl#M+U_pV@t`f*;S54bUb?-DyVwL~y^{oNxP-KR0_>Hx(*!~ED7*(rs3YYq&1s8r~_ zDub=+;3zLY5yaT`PM?gta~-2&Fqik3lEOHD>~m;K3S%u7h%E+0<*<{Yo`=@dzo7E` zC*^{>7`ClZqR4z?7>GJa$-Po9V5Oao1BvkqaKl1j`+F=a#w<4bb2w@a6w>l~>X#)k z4MFRwq1_o+Oc!1kA2q@h(mF#)v~{u5cETI{8$y`8%|0Dk(Z-~%UhU&B62}G>C=98i z55V^3!T)0DJlwJR!!Rx+D@61wdzMXESDU?UiAJ{X<-_CHzGMI3clOiR^#P9VQ4LZopzhF=|1K@&@1!%? zkU)kh^4IvKNef^)Umg6mDH$-UP``n-2^P#-;Qh3-3@1i9`Q~L$<5}!u>|49JA41qf z*RXA=K|fTpW8eN=WWziOv+QzdDI5qWgnFr;!g>t34W4aRgAc=_8=syX!bA6@RqeBl zaPgJy$rG%sSUdiq?G9%X)SdWF{iaqK6aFAR!FpC1(-@$%GNon44lmGqjY zn^MQIBQx5LYdVAQ+Gyy4+v8DG{57RCRHy;wrKcqxiS&YPp8XOf*K5RVAU*UzYZ%e- z$4TfV3;;K~_3=6PU(ijLO*yIGkN5@#uZiE9M^s^7C)(W^Ft^Lbi)8ozAeZp76fV<( znA=!!UW5ca-p%@HjK|If91T(WkF)F{mFp!5U57a~;> zn%@ZTJZrDa*(F1H_9Nc`nGrZJS@(!#u?11Ou>R7*2-NWYYt#UJC=%XQnfn;f0Tm8) zWv9;vLzDsa{u1>9LE_2O%ih$%M5i>I2CZc9H^?UzpPgKW62|*!cUSjel%JV-@LDv& zeyNQV(T*TBPxxh4wFx%F<|W(c$ZDHfLz}kH#;mih8=!pdc0*u zi?{3yFxn>UJy#|+R$EB^p%D47Fx7HeY@!)Q`VM~pc_k(0ANA-kF1CrF^NWXow=@^* z9^WVU6aTOVu@KH7lIQykwq_vMMvi!P;sk!oKjytG<$K6y$xwgD!hpT){^90zSd9En zt-Nkx`HtuY+30hdv*46lgjVs{FJMgmALV>f3TnI{!+Pv3CC1oSe=vu!Gh z@1PYd=3Z)g)y<>J-CX7rc6d0M$@JT8?>PREs@la2w{~b!lV9eL6T^o@^=R^Zxrxu> zA2k%NrN@&~e>*Q!$bmn4hEH5t>>=zoP4({%A~8|-93QSq6vFs${ZOXN?i9#gZU`*rq04cht1mU?`29&oQ(JGnRAyb-f}VlX|Hk<{htw zT_b0@^kG{H>uo*#S(~&HYijf{f8zcctJX|jzriC&xL$QG^vWzoU+U5*+y4fm#u2>1 z8$sCR^U-SDeyx~OmTy$1X?Auub9raQxF< z(B9nr)$&6G_RNxq>{eF+mf-bAVab3L+YUGusr{(~8&i9yTR5ML4cg`Z4Py?$ldE0H z4*xF^dwv1w=8C4^frjKtlW8$ldT{lhl~Wj=qjA9VoFfkVpki_rx6+LNq@b3k95jnL zwApo0=>EZytZv{x-^PF<;*J6_st zngM;EgOksG%ttdpC~ce`}*ZFSEZv}urRH@Ab~0nz_lt@*{wvKTx&PYTv9Ku@Zt?z$cn6u* zna~kFd`lbM>0?BJ*aBWJ_FbPRwh^-OS~HvhAG=U0n?6B{$%dIQ?zLeQBp1AX)n#!~YxoS(S@FU;gJ^eOo^ETs+5mn(hlm`MK`%*MEB$L!PYE^KMdX zGp|!+Rrw86@N{79K`S%$Gb~y zzuv_Ma*m2$ZS%qla8mF8H3-9B9mqOMwq}meYR2ChedmhbXP^jw%P5Ui84?NpGChOc zpwZ2E`@spnba#kW>AV|WXO8mL)k{K{V8OIQQZP5Br`xrW73q%uz@rm%TQUwmH*Si^ zE*;0(gr#0GRTbl128PwFl#}u5&SxGM7Q16hiV37p^8`PaTt;H^2RmwUc7wq4>2i@e!OYKk%M~hH~dWWLYgj!DJe|{PH$aj zRmv0BJU(5Vf{E74bsrz^!JeCysDJ!OtrS|TYIs7v9k1gzCiSD5SSi?WEP{`H7H^Ps zW@b2=TIrI?KAYXEee6zghCiRO8zx>&Om;jV9}9Wa_?wLV3)b!WV!|Tl3%-});fzxF zG?v9D^x*g6YrL{7k1RP;0oJ;=j5X^&#x&bvuI7)O!SXLYd7#B2jU}rq6lVtKV&-ei zewVy6v47lIOl5q5Sh;@uN?h(O{PZSy^u#errT%|^=nu$#V{ejVBWKDY?7`UA2lrEU@ju^xvtXK8z%S>Y zP7Y$S#s)aVpVl$N;C)OtuXEx1@xfj-p5xUc*fq`DUR+_lcyT`^|AhQTyzXpWdtCQR z5G}FPPB_*8+0}fHC1-2l<-{ciZvqEeR_0b7S6Tz!Die-d$qi7n(^J1ySPPf(mtz(6 zTVS{vSqaS}kWeQeZUQxspkLrGPmPCk`us1q2|Rz44u?erBZBxj*80ED06!c_v-oH` zAuKnnt>6D6$Qb&(xl=s=2q(v8S!t%zr$p;v2;xLUM9)J?6_?p3_ zckp#klq;!c2xwFKERL?e1EOyOjlEL+fHqEh&pw_75g9{{jlDhqqhzxr0*9;h-!o-j zkx|$@cj<(>`5f5hBvBjW^j-Nfp45`Z$Dl$%*Q3C=HZ)h^{nzzE+LhJSXc@YXi-wH*|J!FIBp(@-uH zdhZNxQA=Hb}?;dj14k0qxumr!-=7d5KdkD}v zA2A*xjSe0&*=zkWfX96Ig7REcLF&_rVQHQ+-~wD{nyy@d*%iq^nG_{BNZYbZzHuAg zNO3-A-H?Ioa9oZ1x(gh8F-g8vbrYW4qLS$3yoPkG%&gag)j+$fF)B{uK7o^Q?96gC zfDszG#cl@&P&%Eg`##klooijv>1T38MJH9pcbydxZfj>K?WP%61p6<|Khi)}Y6@l_ z^u0j0&M?yFvKu_mHBB8bdIA95UcW_@;rHlk9MOa(VwBE~88uHu3#ES+GkO`|fNJhA zSu_zfI0q;nd-niLnsh7g|4Txm;bNRGELB5SX$S_+tX@mO3r9SJAC zxCqWLgu@j-!J=iY5O}2LT#_*x3>l>J;-y7lKq>je_dR0>G%(S0guBLo$KzW(tWn9( z@pE-l+cE^ioz2B6uO&mi*sh(*{R|imJW$`$NCe>~C9-P5@Bb_&IHl~I0!AISp;C`) zLFh)JlRIx2jGkTy{XA3$JCRMp67N#rAk|IdbW0WVkD8?a87zSCX^w~d+4*q3H7tXL zwhY4dJs%YtmB8(inLWD0=fH6;_1}!aONfcs_8k0{3;a)|IXGo&;Pz9FZnu;wSpBWm zeZ+(Zsi&?dHmV7Jv(7{TO8-XC?_5Vt1U@x?n8W|S-eEY{SzEcRL(u7R$&Qs<%tC$; zvfnG3h3ge`zC{GzDrpAIGp@2((DcjKnZLCJyf@gl&hPKQ@1s<@RgGCNZB{69Jo_8& z@DMqLsqaG1$Ap?+#@k>%myI7DU5B);zyz|^pYU$O!HwQ+1r9b}C^00iL#On2fu|hH zU^?SJ`QB+AZn-m9g_+I6NOe~AiV(r~#k}QQ%Q6e6cNYw$gy^stwZz2}zW+d-ocZ5! z$#INU$SRxZ(iU6`;EP}SLy0jR44ZURQetX~DM1blWY|=P>vPphMGz)E<&#!Jg`FkW zV`27^#}c(AZ~0vASKoVL~*y0CCBl=nvgch8`lXZTbFO%ibK$KNUHg3r3t!?3;Xh~ zG()kj>AF2bHJGVDRxtPkAu;)+hzoCoi)sY0=iuP_sx|CoLJ8jACK z`#Wk?0=*E)&-5$5hwiLCMsnqrs0I17)QKk`=|z$2bqf)o+|+xGH97*Fnes5AdY6oD zt#!s!7Q3TXle80;W$b|`msY{~Weqa8Dq0iuvlgQ4uRpt4<_hUG^^+IQd7(Gnd)Ky^ zgOJHHa+Oxod_?Z(?yoSJ00E~vi#&Rt!LeS`*uX4jpc7Gi7zYI~Z5aFEZ$<^u9r{XX z(3*ra`8TqKj<=&=o5rKTs46sFE6^|bs}`hnG~?^LV<3;@ri;{85`3&QlS<;rMUIU3 zFjgKHv`Q{y?bmxA{&dV}vg9|Tl!7LW_=PqCXTGX0?-UPZY598Rm!3k#2}?UJY8N1$ z+{^zc7mdp5IQ30EBY=rpRpDZCIOrzrylD?sCHS0@6)&6%2Nu4pCugH8!9&icyjv_4 zohx`2|ME{3*h!JAaHzFHR#m#UkHTYM|4?dnthWw5B zrXG-o-qiZd{rgx3cKfoPv(vSxaWLep=%0EhB@;e(XXg!cU!KWWrtgJUF_APkkNF{s zL}OP=1EN!6ycCSZ!w7U@f^0?}omA4=s2oQSB3J1aXOzWwk*rd=~= zqRBs-9ThMbp?on)z5xz8aRFOTI^p~^uDeUcAE8Kts=A2a%ZlOuRouDo0X)fvTGJv4 z94yzaZK2i&m{=;ezNym-yZjcO#_|2|sY#u6Hmr-l1!tUIkbDCcDgmdB3%fx;ShlDt zxChSg=5b7DA+UCNEZqFI4|<>WRmhRIfqAZ}ET!QOpq}tD%fR=6oMYD8?kfvW!w}Vz zE8hj#M~rEUXTO2f?e6c)Gpo>b%8bNlbpep@N-(it5K#Hhsp7ep!KuKaG^b<@U~iA2 zLiZ3nzd^q)+b`gLH&NH(&4{s&hhAKF*o90nbw4qytIdT8`)YGh(_u>rix}oPaifY8 zBWqDGe|zFQmbOFsv#W|3b7h(`@EqgD+*#hz%}^gfRJK*$v?D7}Fg zX9rF{$)0s6X9e8TzBEAE8?%A;Nt_5gjVW51v zJ3+`>8g=d2-Gn-lq3@)_A0V62`l1-YR~tjBIG>Al;9CN}bkch&?8jg(6`M&Fd~b;u z9j~Rs#Mm3|Z&OagZuwS#fH!}ncDKjHLcy_T4XF?h<%=yf`&4~;54jo@Vug?v)3-z9qS z$kg=b@xn75@JnKyqhYKSY*sV^irMnvQ|F)3T$~A9;b&m9jd=wRITxcJt6QU)xPKCP zpBK^nzM4~aFAqXxrAbzt^fCO$8PoYNf?t9Yrx`7rKL>~X|4z~965;EP;8Ac<${czHsW_Y_8X$em-9 zv<#9yeKDy7{cQCQbcQ6dxDjEjmE4>gU zdMa6JmK1Z$CaNJWUWL=n2ZenOd*E;JfB@1^V6%fqsoA-UFd?D+9eI32c6!otxXA%1 z`5nKRg4>9hw(M=G{cetRW`2snanp36oFMv~Il~y0+4E(KUO-%W*4ylwR4xF|H z;OLXDA+W=Pb^P37V4|%7%MsH{=c(B7k@YJhtNMif?a>tF!Jst0{M)s0spT!ysw_aK z;W7&^sD8$W#(e~=dYz?=Y7@k56sd&@-h)}9#do|31$GT&i|N!mp>=lK)r5~0t1dE} zq`ce({lDv4#t{WZ%GE)+_A&>ISJj7gPMyT8?AmZnbvvMw6RC4voC#AX(HQQOA;BX1 z_~{{s8p{@3aX2kbjMeGBHI==+57C(!i{2kUf$ZKLYKtGgVQ9`GL2HfR*P0Y4tX`$Z z>==47PLEq?NF6b3GX5dYyp|;PtA0p#%sLGF zQzkBxW0i#$+&}Xh_bCSxd8_5Zd6bLKiCx2a5~zCK2d!^xnsP8Tll7Zd$4oHoNG<)j zcQV*1ywKZI8~NDz05YdK(KL+7GF_>JL>7~DT93bR)fHPXjik7>H;IM5+qfK>sDOR( z{k=Z3-h;7yijK4l>%g?R@QFLbDOh?=vBAgfSNME3hEk&HOG-sqb($OUkwQ5Zm@Pd!(p&6JIJ5FH3pw2>aC~6ZB>LF-GpR<4E;G9Q&@~HGN-=81tXg zDlw?`$2>0HoUG7v$MS+P>h>$Fn0aKQMDT5O%;bV?%$X)OjAG(j_WZwS zY^h_N2F8-G^SWk|E?Vw*OO+o3ua@2LOaWKw@4C_{z1*UFmQQ<1DZS7olK0;_R%oxx zU=;ZSTl#)7qv!-@jWm8{Nryn+iKsIInfp&c-mpW>TL%IoTIHz#&9pWA)^JU{+}bXOJ6-zkVtW`eB}YHa@xi4lt(59Y_l zd*>Px2d0@*V(sm;4MoXZ=WkO|;fb@-HWc@bG5xS7+}|#KfkfUBDBiq-?`ZuZ-0OP_ zYkJXo+iXPz+b_N9DM;&q{p`T*-oDs`F$sy|_;Ib5>5<%QizImYQ@>OnchTX~GJ16M&dB0> znH6ODImgk)V0*bg&0iqvydbc;PL0>2Ib%<1m4Fw>jPH`9y@%ELv*{&Xx`(GFX`~Qb zcffx9D$IX*?;0i{1omU~x3RZAt?YtAd+_gSd_|l9J3iyM!(r8?7PcB%(vCa0f|>B1 zP@s=rhRKi)N}=q_*cCF-C|$!C?7QpjuI!>CaOiu$pwV57k5jQcqmbi=FMkvwunB2+ z!wW_SRK^dm?}`kE+~i-dCWXY(rTcT(vEJy@%(i%JEas7=BL^O9ly~Fh5crM}PrH0k zqOHJOeykAhh;d_c$5H}YZpmO)DH~}*z9N`%{K+u~Mm9{qgZ_m6WeH4E|A~}|MK26l zb`DSw_V}N^2V_kg{el}uKUr4tBeCIXtG}kPK6oRN8zVPyUf31G4WFR^U%XL-$GB^y zE0$3GLtll*1H0aHb>5qt0dFMDL!nJLpTw~1yV`tk#|k->pHj}*V!9ZI!U+vhe6=U< z{ezl|`14^uLOqBovCMfcm&+ed;3qTLCQD9LVdD9Z=>9xS#hgU=y6c$}G2$yP12VM= z@vGv$Z_!tiD*Y(&arwe_TuGLTG%oMa9A+237M+Tp$MX54n~G-U@tJSeY1U;b@u#mJ zsh&0ag)Ir-BbCHH;mmcg;l55y5JaJVCI(fT(j-OO84I=b6CzEV#(h84ZZU( z@oDjzk}mJxVzz1R3L`grv6m^EbrOz^c(Rbon_-MC*usA=oTg)*ViD7mdbDM)FbyKM z_o_xCSYFE2dc!Z{_>2AC$9<*qFh6~gAR)y^Sc!v+%~4zxUgt!l`(tqvOtLOO5ToP5 zjG8Wsc%9C{+U~YX(>xBtUbDx^QMjdJ-0?TAl=RwRKhB-AjQ)VfGCU-rzD+e?t45Ar z?`OwiHtoH(ulFLbfL4CB7f~ztF=yaiLgNOSmKdfJ1TE0oa9?HS~?$!NPL? zO|Nt?yzy!vcKG}RTxP@fq?Mk4$@gQGHOm3OG{VXh5FQ0apEo@8;xj<@g2;2>lQHlz zr1)yqgFpzsB`MZ;E)oPeFHE2H&4fDjBWLBpQm7c~U*E7SgTzZuNS74yp;`O&JiQ>n ztzp6wC7+uLx46BwRjE@Uzd>ME_*E)+my$=>(}0%dYCuqD}VY86$2PcgN>eMJSl^;X;9nSTL)?K9#*uMUa_XQf9HtYLvsx}l@l z0pg#ryC+{X0;BKP32c%~zOuBopk1URqVIGEQmbNiIbRz= zy-TX{%GQ0zvn5)Zz3l{-&*u0{+xx-e?Ej|c9ld~A{?5y(V_wk5!#Uxd{Rna@lewof zL%=au6`AxT0e2;C>Y-;C6t&sC=8p4$&gjlr*iUg=T2}vA(3D3*+TcCI#0q(YyZVKwh0O<(( zS!&X!Ak8xK$u{;Gn9?g=9hk}niHu>N>bW?uA2^};F1wh(sRg%gs}{j6iE0L-zokI5 zo?)N$p$xR;M0|sO&mc5pmw z$r+lZrFss=9w138n$dL4TWF(iy@X;m42ZSnUyIsCLZcj~$bWS)=;(ft>>Novn(n$@ z<9Z3F$Qfp08=3w=@%y5e`Bv{oT+>oP8uPhVio-p>?IL1-<7ht*KYZy%4DL4_BCa!u z!Y4N}H9fA6iZ-_e=EFj_6<7W-;7nV15bo5u;}mv6sIBB%;~1YgGQY1S5^-4(!c90I zBmo7=eIQ1neSZemVNu^}Tr3L$`6Jrj?(E^lzJ;l7J~2lXOE@bNdk;X4?E6;~0+F+~ z<`%oS4mf<14Ds1hL&GCE?%pgnz%kyU#JWNWO{bfmr`S@q;fefU-5}JN)xF57oNn6HjWgi-cekJ zrbdp?=~YXlOM2LMQ`QbvhPPkaI4XhMT~f8wWeLQz=hg2nehpp9Ocl9jqztlGC0aLs zU4^tOtVul;s-Rx}yYc>(6cm|z#O2n?BJoR;D&+>oh%#Mne|XjcW!iJH21cqPqIY+> z4bHfuORZD?w*R@IGGsG-|CT-qZ4k&aJ!6CDM;@?Jc{MA}MEoQAW80*dk@oTJh*y`c)qYUle?;=yd6=N2XG@qPsyb=ZBacMS+Aw zmwl%^MbzGy^3ZnAlls~VdZ=Unw&4|e8#$e| zAKW<7M{HU_pLZA(p=Nq1!rL)b-5*@m20^;_x|eJO3W`5Ijnac#4V5FDB1q9f0mw7Os5g8Pt^OMD0aIe z+uME{=RhHN-#O_75?3ko6=m*HB8!Vtd0{qNNYN@-tgDc$K-%5y@$I+bjcKrV1Gfo3g-za^{yQrTxKYC({k6n1(4f1#)j_(5JLkcW|4fArGS04@ zA}Cw9m|jNDYY9{+rOZFJ%8?bBL|nZ0gy;k`h-W<|xhn?Wr@3@nY;_=^nqJ`Qj1C;R zeNtyWW((HSGv}wSb}Q~SyCu;!%-|e%bzf*QdMlFqh#NC!W#d%quWnP}x)mpr)&~V6 zJ}bs=k|u{R%;V~;lt|&%0?y7@r;Lm?Nm2V3{;a0k0#4&)vnTn;8G;U*y3ax-4nZ&O z4Q}=BD$3a&Gb5s>f}`fN>6m+GQ94O{tPtZRkR;J6khi*sjA%LS&N4BeL?K!p6$K8Y zmnllK^_&qx?Y#XC&;P(}l!<&Z=n_G>RDYWtzU<=qeMp64LOD_8uMKm-%zuhW2L_Ay z8&WX(eoyAD>#E{yim6Vco5Jue7?na7)sOeK zQ4F8?wvW#*oMeYVCH~qr?zUm{_OR12pf3&xbbWgYiYc?$kf=Ot*4=w_ZHxk`xKX`I z_xr7QBC1S0(2yJie^fE{6f45ZI4`Sfyk_W;HN(!*do!dnl&r*>sDvnLC9W8~5d-6P zER`F&r_a^5=c81c%VI!GgOLK>nK8`(U*kVn2ZZ-BumUy<`e} z=2Zu0x6(sjS=U1hd3o8D)M9A-t^M!v#af6JDwbw{Sqaz1&$^u;F9w#Ew%Uf=wV?Kt z{aA2VC7f~SjCrq751Jb18j5-d{VkUeX*0pc)p00U6!NID2lilid+%y2lFmpT3VCTqv5Ky^;+~B|gC5m4(j!<0&M6VT;)PekEK~@PgVz z@s#(a(U8(p5)wuI5awDd%^6kGkj-S;kV~vDTKC=OwMM;H^y6Dd`(?2A3m+%cY>=W(wB&_&waceIANhdB zS+n@?`4DuJsWd1fAPb4wjiI`ma_DK~sTf{{2neeZToK*MK*&X4KdLbisHlFs+DS9{-)4a|RcxsjcE03F!=8F zNc%)8`pSRamW=x$Xz4lLG(8MM|FO^=s9U+hM$et6w#W$9|3LPQYLiZ#WFJ_@4KC;|>eDUj(){qu@8KK+}S2 z9Mo0Fgs(DYp}TzP&+D1v5c7XO`rmV;p^CC|yfiZ5NI#_YM*5kD=uy;{$dC8{Q2mu8 zs7(=wyy#zP{;_ujeu^O!a54hc=|UNjjGzn7;jI!+FgXz8-J7{QJEcM5X7n$m%{uc*D%jcxngabbs)@_J|KEUx?ge z&I~{s0%VM+(hE3T9a9=w_+Z?`zCH zyl8ER9-e*?y4&IjM_C%SPe`~B;|)ERzZq7r*?(;oR~ZDTdqN~P@G(;KTn+Q3*;kxv z6K&16W`;jY2RDMQazI@7bm$wVQQVoD=X(s-l~F$FjJa8@2<(m+GVp9*NHuAg|MsvB z&?j_Px!;sWq+Cz3Y?NdG&({~sU#t%qyId)2p@xV{@(HJAo)Y?qZ*9QMI-(t#ZmRt@ zJ4iQ=`FkcqA4!K$NnN_)hES^+X=9@WxW8w7!ewa8E0|{sll;=-xr|%ZG@A&i^hSq3>vWrb+C-LqE_nWx2(;WrMB^>6o3rWq`N@ z3^I2yDag1ZHNN1j*9H@uja^}{N$_H6S_$4-G7k{c8=(_@64Rp0~17Xy(*wD(+w?qNWP9b z>w|`vE@cmNx*&l+FW*0?d4LSm<3wLd--Jt!?v0w9!NAIgX1#(;pv-D7L{-Qdq6Uc{ zBo7ki9{)-rfy0~7CGx_I-@*xT-wi(HM683JXWceaCbdLrmVuYf9C$#7i0jiKM^8AF zCE`P-tA}Ld8iuH@c@gsaxcTkM1EF}FP0;dj0EqqP&Gv`&Av#IXtCsxR2k!r?+E@k; zxa}O9S+V7c8n{;jjRG7|*v$3(y|4YaQ<}`a|6B|Z=!MPZ%mr;sHmB%6(X z+B8QNPCCzA0(4O2pM}+?Q9VfZ)h%@Pv4QsSF!syhk3mZ2_pIBR2bjpU`b~b+LBXtA z*o`kLh~z()pZ$+)K|rNCRD04D^=OeFCEfIbZ=d~!WpVcCKL5GDbu%7d_gljFm3k0T z?j&XSy%34S*x56$X+44G5?a^FdIFK{BAHn88-Gx3c@R!4_W-S*pwp?Xw?zz}JiMy6 zypU<7N2vK|ReM}3MH<#;Cs6}LY?p-o<|%&!L^Xf3L#IMOg?A%Ogc$BSXUf&Q{Bp3{Uj=`cbpoOu2*L5XLm}N#6tQ%@$k!)S?>TChcHer9=v(WQ~ zjpH@=48;j)kiCNN#9;R#(KooXAx}7E< zAIJHf*lvSA460@H$Lk^8!`zvU_9ZY(dC3N_w!`Wzo)FX0R`_@AOT{xs!Z{u^|wmtE#dcoa5pWav$qR|QI718e34GDh7`xmx3 zJ-Z;W??|a?s1=gb8aL`)>L6pluB7r!4Q!fU$w?8fgS$~v-@HO<;Esw5-J8>mz&!T{ zMgFXT?VKQwLf0mUW*VXSBU}r`%qg`LBeh_1DgOdR6=5#_MaPz=Uk@$xtQDsV>!2hc zb5)mczl|8DUvFz_;Zb>QMJ9VI@Q;@FnyuA=m-2%s{1Xu-MIq&f6Df+>pUbIZ+jC97+B>C$Tp<`mH zkmGX*@Vpe9J$kQ=%04yvR?d5)EjJ>TQQmB@?eb_P>3fER%0%R1rxSsqgKF_%O&S_K z`BAJxB?nx{*S~i*W}v`ytxM748Bp)kt3G0qf)aO6XvW?32b=Nj<4&wTa9I*vyq0PV zlj`$-#~hx3M9-(oZfj8pKc4p_@Nxue!lm(l&p}4i z=F>oUD#9&({;u8_0osa*`R%$PuuIcY;@WA5azh{gu<;8+H1U)cbDw;GZ>gzVr$gaXea)@Gs_I2pOO1s?WUn8jQkv{k>Lr1>61=9ay#a5wV
    TxT+=T??hxd!&955GF5)Oe|hcg2%=7mZ!;?#Hx=_PhS)>V+&y} zJFT=^t{DVpxt)%hDpMiwb>8G%7DB(Vaq1aSLeH(u{%p3Z1|dITLx4_hPY;O3#ciIJ z2BERY8#_`=&w#{SMYWjFr-nahZ|x3v4&oism|J5O;`e`iCq+69Mb&kMsix^Kh?ZKz?UWGOUQr)Sl7Q!x8w+fPJjDZk6L4NvE%tq2}&pQ z{R8LOKWcs`wrq3y%`-=oY<`WV_K6^oT)6n|FLx@$h&Wf;zg5kEYawwq*{_ zcXkslSE?xdJ$mtffBC5x3Lrr-$M_Wf8o!` zYvBh+i@DN41`kmm8=wB7=R;J;LrLpb762^8Jo`En)(~>~Xmd#HJ}8`D)c$cK0jjEu z>ertcB6aS`oQY9)M5)~z)BD>PEe$9C7g4VReZE5%?si*(Rv*SJHO33M?VC5>?-`)V zSo?5m8CPgsmJO<1b46w8?~g_HnZwr1w~Zxvd!!nY7h-(jF>3KUe%e&f23hbisYujB zf-I}Ee#zK9kSD7URbP7wa|O;^X}$&^AMrkH-Rv>c8xz+&$_#>Qy>DI0OhVvu?9?0L zM==mP@#tQD@*PC4d9gsY*aBIP7ApHQ2cTYBNwUv24^Y|I0`L1LUZ^9kMrJbI9cA7x zZ2fS}6%}7giuHJ7jU4A~u3xIQM!%Epb`3eWqYm2Fw7xYV=uZIcZhCJ3nm!YB#9(|I zMM`-FU9t8>^ZJ5jWJ3N(K7oBfu_OQqJew(^e;J5Qo-u8HK}6_5!G1$FshM@ zq*=v0A$}>l&7dzDefsxSoOL4{h3b|3C8R||xmZ}?85D%clNFG{B9qW(Xug+WjDq() z#XMqskdZ=pB)sO*TAx-;1YaR+7`E*@6_&rd)6>x0bD^I>waS2o6|z|`b(8RtWY zzgk+a#&QEGzWgC{PrwVE*&c9s-RcEKSCx;cl-eN)=kY|RtS}TLtJjBd1S2agqF06S zR^TZtZ!j4_*l$`;#aFzHLVw;S@)MQ&Ad;iov+tOr(YOD`x=q-E3HcSueqK7^Fu9j3 zuoD&wB$cljmI(ffC%$qIPMb#o?-l*kwdE&p!Dg2D!B`|bEUon)zTrp6mmNC@=ZOGk z{(f?aj6|TL?A2Gfnh2rI+A)#AQE0A|P|wJafEMbq|5Ph#p>q*>+U^A2lO!cTSbnve z(AQvd{lT%n%8I?)Zo#^@H`3oR`{CJ48l0zYSxy!Az@}J@SbSFxP@j>mReRL~=ii*Z zcaQuX&=6JV2-&{^9vin8lp*ine~QjKoXYY8-zqSL)79o07lG@l^;|NKv!B~&F6tGpxgT1%wjMCA(7+P$T+(J zN0aup&VLX{p51>lxH1S%7B}1}t_}mgqs{$?H-DK0$x!^T&7&6F0!NC8)3I26PwFsw9F^P&X}+!>)NJY@{amDQ!kI=;PMNZh zx!(rdq=U49k(6O~5p%S9LKFf!xuuYMNLh2<82@Jd$n%5wT_N zj-PGda4LQ1DOP`Xe0p7~|FRucRd|U+j2Z#2bz-J)p#_XOIOW$on}JXB+pmV*E+EEE z{D$|Rf%KuvKE7EOwCZymnMAZgkY>y_=l201n+T1L{@ee6^ubpSapx6_9td|Ncbh2b2m6acucfg3{KJ8lqS2j|!1}Oor|nS<5N197qmhbn z$EoDUiVDhMo%4a*Y!0Tc!#|gC zB?L79CtpIk=iFyl;2R4JY;J%&=cOGlo;Kj;9K(g^w*u|!PoqyiWB21n5rN`&Z6Gn9 zm~gJG1Lo=Tr2248aN%e=Zuwt06zzrybaaP8h!KIyU`ixfdvL#jRyY{#u*}fQZ$v@V z(rTGuKm?fBukPK63P9_D4$>OugHZMavCU6(fS- zC?OlKuIh#i@?(=sRws2g{^$?0X#z3Ju@Q)K?kC%e z&2R`9B-M~*iA4lfciNU}Jb?A4Rfe^LKg8N7QW1j>>g86oV*ULN4W&)V{pS!4vZ*1T zi>19`=fC~3lP|%@`O6%+RINSgRpNXnU77-I7<{i$Ee(BBIlZerkp_2cB;C70l952% z{m;X0k?@B`{-nLu5&hw6%@1_M@-EaWF32*6BC{+!a;ok~=u)}3EA1JKZnAu~FKYb& z)PdC_Au*B2$12Qbh&Bm`HSS(!ln+CaO8XhP$FZO}I-eu;H3H4kd@)J59}D5ZfBV{Y zLlIw>uj;qVc<54BQt(WVL_6*5PM00=#3}{TN61Un~Q_^ z%N1t@w4MPLjJeKan3RTqQl^p`p1wPF$H{Up!C zE72$~m{3L_HU&^7eL|@X#>rJ0$bV;=gl3r^SACI)L6=p^TDtRNfNyP_B~2k3u3eFn zwIK|L>bVTRMW+DxG;#fnRi87`{XQg+bi)l%Clc@RANrxG3$2@9Qv=Xo{o-ZUppWqE zo4VoTY8WU5vAtq9ih+rXkrE5h!7#C-EjHTb18Eu$_NnqCK=VZ8O9HPSIz4@bR_bC9 za`cd#;KJ&CH;F11#q40@JEzI0EaC>_vqF?r>f^Una_oyh<03l$HWMcld3+{8&@aA6QQ)E7b5k z5P>J}e@{bPP#f#5AA||saE~9coOFai6-QgN^!osGQ2ii1T09i#-3)#2H608_oqo$7 zCb*D_1DXDzp)ShQf4cyj25`?{WcZ$n2}%$CZ!D0&7R0P<8()g3BHcRHKIUIaup}uq zqQqd0lopp?wIUZ-%5E?e`V)Yh2|F&Pw|JpSir1qHA6THKNM^(`%m=!4nP*? zczGh_1CfI;m+6D|?y%g|CcA?@6J!2cxwpD$r_$N_GFO_pNP&X+fGA(28a1;WP~UwJ)^l?-$L&*>kG`= zLTD~Dh$FHO^Oc(A51J0>!lBb$E7M{uukh+ZT`Q*p5TBgo-TLhel6O`WzvoLK@x9X_ z-d#QroA{Q^@bzoZ(3`Ljz;i{}69v7tYMw|#s)Stlw-36ZRk*1X>5euzv?VgOLx8-4 zb(0D?K*gkCQ3{H%$ElV&GxHtZa4U5J_%WR8YglvaK>us%I` zB|_)kRcAEA9#7J&YmZ8-@6b$1g`rNCpM1(@UZ_Gk(t>g{5SwRkZP!QHApNL|-TkKi zaCmYvEU&>2Ih@@h85;>fn~_3&2cB-=&lvGqt|k;EpNO{TS%t$O75>Y!0WU!XR+NXV zEYKAbpCgg~UZbCnbzk1HR7R7&Wy<<3;b7nQB<0EZ2oyrJg};109Ca$4Q_c*D09>Uf z;qh}n82+pKM3PnqK6p($9X&Qey64%x-0QVLY)+zw{&Jy!XJ2$ilk@{x@`+?&5b=kv zYxU#u*TPWHW0PwKk%7{CoL=jSlaf4?vr50- z-J(LGT08Qoq;Jtd@-_qAu`R4pE(w)QK<;^tpjT` zBequV;%tSuX7Ba*Et(<4MFD*i$zNDYBprH{-yIdjN|w1?3`Olaw`tZ60??|G7zH_A z2nsgaBj~ps24YX^h$n9_4u`V@gVOh2NbTYH(~kKivh9b)iv)J`gWcR-c>g z0om@c6W=o(z^&lx_%y9L>#sz~^b>D8FE`4+_@7e%}g@oOHVc!m0dlhm? z!kr+MVMl={(+d{O41WX2I^e}qK37XDm(E>|kizfy3zjoVp5vo94!9u+{hM7Q;8+u+ zPS^AWjOwbN&|Vn@SMFi$2jas}!sDAL-8BlO;}O*O3p22&6)bW_WdH~~`HIiD^n-M8 zGrs8TFf6S8BYh0V7lC=>i2vMniX0GjOV6+`8}RgWBL%Nxm-*oeLe!J z?`={w=muaS_EJZ5N+%rOBe<+tjO7@9{B>}SvjfZnMkJL-+Ti2!r{9WLo4`w2d#fq3 z8JZn}N0XA9%Dis1w9WLS#DwZyqy1a@)EN9B6*X^c?J6SaCa%GR&U84c=5M1)LfmAOP0yI z8YVA96EzV}K!y3rzq+ei|BQslZ%aQ_e|n<&aOuyp7qI!Ww#p7?x;`vX;8BmC*rH2M zqP>g$Ss|%Vc@?2;3pD7zM@F2B@p|S-YO`--qfsZ6EQnDW7E7h--@Hmgp+S{42M8_dejX5dX%7P2*quVYrsp!#5zDIXBav`0VII--% zG}QVf;Zq%bHaJgBPFX6ZpaGSw(Q2tscw*0=uCb7cObC=GZ^gbww{Z&67o~%dQiRK` zkJ$fkQ8@j3^RW>0m0#n{S49b}I*K>NJE;`iT0kM=Frt zYOQ~hn1Y^aT$MDbPK66fOe&XxGmz+~Fb)Ohe3)HoZGFgIjEK5ZZ!dg!g>aHSv@x%4 zL2fVq-@Oz!$lR0_PqTFc9km~}QIrX=Ng4UKPaz+$)R@or$x=XM)qw6TaWaH%6+Lb5 zPeE(i5yo*M$;kX*O*mWw^U1%ybb%=>6HPmcWm1j#qiIIfyO(vIq5Qq=ib`^K`15OF zet%aMrDe^`qWDOtQ7VM*VxNG6Q!7S-=`GS)<5}{X@`phCCr4SPekd6)N9-z51SF52 zSD3`+q4S21*hhLyP(TLW3&bxS||N07NrBueW_ zhq#T?tRk8GvGdz>$=NIqB1SFApBTF%@6e~_k0Rrc&ixlD#vg(a$EM`-uBwmdzn2ZF z(!_qi?BjQE8q23P6gt!KJHi9Ww8l>uhw-3TmHmGgC9IG&;QE8=_wU!=ms0;7f`c=8 z|9!315eIseX}40kXc+J*tFzmRL^LyJ49g5%kdX;N-*B@l*3UC79*A3lKUL?0ZinYs zou_^6KMDo(-ykauO_d5d?)&aa#HWu^Uj1$0!1fsUj0~I3M0#Mn-E$yN_Ymx!&^qFx zguuEfxP_GEJ}^0}h*WC7g#9OJGX^J?D38Ee6{RDm?Zc*wMjYm3gofu37?(dyP!_-Im4YN=|8 zH29dr3Ax@N65q?q?>)WH-D}nz^u)fXI%J>ofZ!Qw+V}bwU2Tmj7YR$x$3>!h^b!mI zECSHqs<4LB{~XYI)80t|lOo35CU{j%9fX+E4aIMhg`?E$h+*55|MO_a`(p>9aCF)G8BOBemVq-*r{fg380iPd7< zG6tP79qVChOE~JCpVE*Cga>7sv8T2I5qT_^z->zxq#b#UR)fL|{&=ljU^o{5DsoG< zUM*p0HYGMF<%}On0Zx@XjW@tsy>*5Ax(1wlxzrdX=l~a)lRE!oYC#lj8!^)gF)-ZH zqAPe~12Uig$z@Fhp+VE9X*ymJ@V4w6r`k|5Qm^CrS)UaKwj!GWBpPw(-F2_I%WtC4 ztGj}{`Uz1`Ao!cZG3WylGl--M9>UItxh@m?Q6Kcal!)^2Z5arAMz6!OW)BvsR}ED7 zG$0`MzB7@OCkUrkyd$g5LT3n4Rx}?*qhnjPp(VXA^hxSs?z7$q#Nrag!*uICI-jO_ zO`g;P#2MTOv-1NXiT`lp(%J`5$|x%t?u*9e(QBm{7ofjG9Y|gZOn!AmOWGCEBn< zqkh7PE@s|9L^~hjy%B@T^*~i}%Q{{aM@DlVFrp2rUnvy#~UvTXvyM zDe&3NO7NZU7r0#dBJNi?#?33K{9`jc4|IXEyQ=}CK$`e?B+hpntdt(*TlCGq7@LUX zg7q>yKFQ!!(fSGwX18RSXcpm0_ZO3q#wAP#$lg@!HxJQ+K3AD6mH?;a#WKRM1pV>B z;~ncOKus9wYy4*!+P#<`56&$@Kd-vn8238N%DYQU^)G_?DbbmrGvB~+7H_&LWCco6 zeL0_%t$;V>ox3p?FuuZu`z^WT4lr%`p{+hQ3U`kO3!d;|oORpVRi-xM(EEMrlau@u zWXf{;%<+!GZ!h-F?C&c;gg0*!ll2_}Un=7Ze_Dh4f4YdNFD^s0?WLwMwto0t=XoF# zFa$}Zo|`v`CgE?L!Oe5ggRp&(f7X^}7+&}Olfb7N1NA^duk&(q;O>`w<7jpP*jrrw zidap-jp_Yi0hoo%-gB`BljG2KZs6UutDKqN<1DZYOhj8~n~_$H=7PAEMf*Lx9?E%Q6Y^XDPTU4`XW);w0{TK(RGRQ*X{n^qqLj>>0-4$5QTyCubyXg3K9p*n0GQeQwa{Y?Oc@hHSE?{E3u z8-lq~=BzEzQ7q3*m3tHGUtZ!G(?9$khk*GjCRd*Em$G+cJk$j{`YzEFEp@ zwf6j1UL6Oo%TC$HRwlu-#cydFmr_umne2s-yGe-lN}$sgHjg>b;Q1|x%~2u1y-l1q z4Eg*CJ>W2pK{1LEi&Xekm>&E1vBGRI>OIsmx4PT_YID=OM?S?UKBIg1)R`KLSK9bp zV7?la<-NDh#B#x9!niI~8kZm^?uGYdPw&CiK%wp&Z+n=|WodaqM-+OS_IL1)G(@I2J+!kPhB*E$ST0(`pyMjagKE~dC^hL#bE$SL z$Qj%Hc)OL1H2fu=Noxf{?YpT_Ii=_5mTq^0Mi~oO7ZFPTn6&~XV`6dmQ3fCEUtVMR zR*opnZnyZV6#(Bux098gV$|4tcXCD`2ewCI-pI5RqsoaCn&G+dzv!Ly?> zD-}^ttW)V?925ze-r~hRT%S<#TB?=#=QNZhlty+u5em9Rp9|;8Qb6FG6>oQ44(jiT zrd-#}L|4?M29kAL;RnB-9Zhc#{Cc^3Jzd2QF@3U>jSj|ih>ldP)7D|2NZ~XMGC@H3 zOVmZYJqZ=Ww@rsy6(TQ^_RBX61A($W7vGmK3g{Z~1H8Io5g)_Tiq!oKM8Y<`CtQ>d zKU3!P{pd4bou(pAmn|J79o1yge$PUG7jR)pUA`bv=}edR6}u1Q?i~tDe1srnd^@6!fY_Qn*wo z4PASraPUql6Z0Q`Rl6GS0?t|r7AXrw0G zgM|oW<2|G27Z6*fBDHwCStrz z{kE*C5aCtWwiz@;L2tJiLFIZba(yqI@|`Rdl=Csb_&-UwA>15z9o$gklPkt%x~Z`8 zb0fjuE)o?~qrlY4Ks4L^XUp;0J6LsHkx4WwKuh!5H$zxbAfZcPbS)zjJt~oRnPT^X z1=1--)ANex-9xFL+Yg_hE5^1i#7BOBfsS7PZr4YP|7c03M&Cl%nL~!HI(L*`<16c? zmkcbP%cZx6vrwVY?scQUG}M&&p+Ws}8mQ70FD4dzfV7^fDTY@ck+SAWnUv8}KO!JHIx~yiX+{8yef&!%LayRi{mb6GIaG%GrKd?-~8KgCPuiXtYNBmt4&w@XTq2GUeZBsBE zsWBPRR;7X^+EJSg7s7sbNs;Nq1HB+%{Q6qu+=(mv{>s>Ec%lS&V`dlS0|I~xKbQL_ zff@1%9TC__k3qS&o_u+AE(*0&&zQAgTo*NoF4E^daVYkYsP5L;93a-ZR*@m{2`EJh z8;&Gm!CC9k^YD%|;I(ejW!jDd;))zSyXI67%xrPOyPpl6;die5N1X$^$=_T4+(|~X zr>|%0IK(2q5@HSc!8G(INZDPMEEaJsFj(F^&OpZt`FnVHacHkrCnqyJ2D!XSo33t& zMEnA!B(q6RfQ?Q|=;MJUdh}#D+1CbZ_1ye`Vp#rYv>mu1yE$u*zY11p%DmzQ z@7r`_S4`o{SoQ&hiS;jZj-{bb`Vr4$_@mK&{?};3ks$PEK{KdPBn^tI3Nw64LP7kc z^XxIZKAf(y8a-`bgOaqb)#x<4p}3<;o!ehMz@YxvKuJ9vSuCf}*Qa88o#XC};GQ%j zH@uWZv>u5>7c>N=_p)K6cJy-go%d)+;>@-sTNZFjgtxPv3x?V%#S22U;Xr)mhtMXU z6PnUU`?#(89)BM_$mx64WK({0<}v{^NKNWQ~ZL zconW@7@?-fob1IMOGsq8ZrRu1h&+1&1^x+Ipvbh$i5|1(=s~R?eajUKaEXq8Ry$$= zd{w8s_N%-ApIhr?VWI$9HIe4kyqblKlq8$3?!=+Z+hVL$t3}9!`O2FXy+m|nylx{j zFAYWeg!I?*<)9$73zKb6l95`YQTKWkHeX;P?k_pf14AtjVkLGrNb0b--|-OhRn0po zeD3=Qn^c#YENC!&{}u9dt050)+0I?5zMBrc)M{}y)AX1Zg4)(}9rX zTmJ*sU*Nc|fuC`22WsPP;GMsU@tzlC_Kn{Bf?fUdMuR$YAQeD(jY0G`tXN9PZk`zi zs+d&m62f0FwJ3EMk-Y?M^Bm*E)2rY=9?*S#eF?}upE6FE+=u05i*99ypCHHUF@IZs z4>^SLasJA)N(u59*CzCBipu~IuJ`7P^Ob5Ccb%Vu$);f) z-k!Fk_F5ZSN=bGh5K>JSh9n zWE$AwMl~N`yqv-34_8e%W}u`x=v|5THb~EI(LBU>?5fN29%37tu*rANHAQk2`04k8 zcX!u81TSp1)~^|2E%VQlv0;3pj2jr%I2*dTTHI8pdVw zTsh{Qz#cMgXzH#4PjM8}n&Ld15*IQTQCGp!Jxck+1i>oG{=aIuVsRf12? zZ_~5)PT{<}n>WSN$KZLFd>GF|Je;12-xqPxZ{UEd;hr>IhCQl{-MYyEp!T)PQrP(l zN*8r+=1UI1orh&aGRohYFK@{z)H_+mj=Y<$D!TZ92ZCgV$ImSAUyG(MDN2u5!|<3q0P3HkrVBi{gBkCK;ry@%s&Q?|$dfV?1w@ z*^_#8H7vKw=7F!8`WIMznohKn+KuVe&NftCRd->3FrTR>405-}AV=;6tP7XBc2%8pd%D1C0MQk;esUa+!Vv#UqKfFa%9S9)<(IBT>gH>Xf?Df{uilRrEaU z5Oe;^AGHP_5Z$cc>Ir)d?DtQzZlq(D`VLV>?~oKQquAt>9Bf4evh#bQFQb6>@3@Xc zcQX?0;kPJPF96-<57iwH(vc?DjfZ&{m+uyZwAKgHRuup8&F?3Db-?2DNi)Wy4V_;P zFVD$qfY+Qlk#!D@NF9%ZM#LE7u4NCjiT`UrH=lJ5G3KcO8Ryry%CD`+VySqBun?O= zmIdnW>3N}xrVDI$uzljUri@pCB%bK);1%}3jvm;*CHj1KYaVe~OFy?MjfGnkIv5dt z4n4E$c23jR2R~NU3CYz3WEd5DW$0NM*b{9SiX6`)%|9QzB+p{{Zs+kfy|zR&63l(R zM@|N{s~8?m5E`M?7bO!{FujFtaHsjPb2HH0U%@exe1KcjQF3Q7ebjyKt27Zh>4^B) zf2bc`A?ec{vU>Kg8&m+%9_%%M1X#;lgN!@3$z`z|&t}{6-^s%Y zk%$nrYHdLc>a-yjP>gyH8jl$Va>#pNa=77dRi*;^5l=&QNvZ*&xIFoa-WwyHvA4#i z-t8!O@x_IL=fQ}jd9pIaxd){zluVSfBp~nc)NlSN8E~U3imLpMI`9b75pSE@BOxja zriD2h_)n?H`Z9hC*el)k`1H;Uejwo-j-*CpaO&3$_Hj=%F%nI?nv#c-OBvSr7b5`w zK!EwvbOVf-(n`Ct`vC@1X4s9&K@v(YDg-V4em-zS_K(xMQr3A|_il3v|`Pmtc@?Hv@G4M}A(sR!q?$XtRyE$EUOm!`+ zvp_g(j^#&PL2xoTHXHIv2gUV8KFa##23lgSD%5T6p!-H&;w9f_XgHO(p-fnh)^t0b zl>Z4sWZ>}6K5Y^nHU}il@4kR}u~UPM-D8OCu6d1dO&+?uQ7%n8+YOTUFUqpn)uLy; zX)Bj5mZ4sw-ng=vQm`RI`{jF|A>rglh%dJzh`QpxOJNCvpOP~>XMes1lEskqwHyA> zEF-{ca$o?{YA0zAHc}BM$q$Q39dmSSAFvU5I~6d|!P8E=S7@j8+_{~=5-2`U=R0mU(}( zX}S~{1{c|Gc!#0tU^RR3{Ct#7QQR`0oCg$He=f*k4~4TfgmDzVI#x@&^`7G}p^3|<5L zRz~BnKbDaBkM+Z;tyo}w&=hDv-iSK*U4%rRVDnl3UK*a-8nohEcAHxv8x_a7*ff-< zL9SKi_l@p!^fHT@;f8D@)GH>PS6>N($&Sx_2F^K<%X`iA$xH~iNW8Psx$6owpUSKT zUN}Ho<9o{NrY7X1Arh|){f{<9f~T;X*3os%Jph$>^lsQmxud3^T3PStGvRyqg(ni;M(ATOXJVMI z8I>P?l6Zwd+eZ>3^K^XYVY2IJ+35RA^f6}Msjwquj zGxpnf5pcGCA=ulD0>;vM%ASxWbp2zb<^D@+xNp!^PTE%Haig{N>9jZWvaSPy|+ta#zd;yQ$y7u*#4^b<_7D_erf z_CQqo{#Rp-Q@CgHS4RJ1Y643pS))gBV_>lN`_I|39XQ}e_u_x;!<7p^{l2^!0y$wR zuMoU8xEHTXGOu|I>B)mhm07>xl~dGWuf;l6=Y4(f_w08dG`}<=9{LCVOBGdQTswt( zY|TM^es~7Nr>HmHs9(c9IQy)67t@O}>#^5fHaUxP_V)U9WoQ82L?pLAJ%0}8`Mhc@ zI(q@`K9^hGpFM@s{+4piEqNO3lRiCczH$j?XM2Nt#&84ZIJFcK|1sg>%k~B?K3ap^ z;@mMi^#!o`)*SOD=KwU_d#Z)6@4yFL`_rJe2%)zgZ2U@Cfq>$waT$xBK%)KfUG;wl zKxuULum4&(1p8`-aaQ-jDP7Oqp~>%1Zn3D?aef;D1jxL_{o5d|)tjS+rWXDd@CUz` z*vB}aL{de9+c2)Iz-Q%*@sENsi_h}S!I6r_g*!}Gy)SUXptE%cW}-@`?q2&0N~5jP zc5PR2r?W}|?s1ia`mF*P`3VBtxykCW42o8u&V#NmI~&acn2U~ zrxY9YV*uEnwXFzxox|M-c%n6FJO*=1XNi|Iu>9ml_F2LB3s96}lIa{Y3ONj3M?cfH zAusUvvr86hpeN`VD;YKheUC#GygH^aj;s1qGuv07c$J`7M!yY_lRjAtcXQ!QI!k0H zaWh0T9tz%^S_BEUBd4amZ=i8MULwA>64I`1r}5$y0|7Ityq+K^*OT~3Xw?0YA1=+F(nm+lp_z$nV=Kc_9_w+PwGDw%6iQz%DRYpffa zV^5P&AGUAzpn-Zv2P*qcaPaZ}oX&^w3^$S}?PW9&hwK(ZnY=mDx?OU0)V2W3Zmq3` z6J>%i{lSo}oDUqHa$c2THU;m+(cGi_M$|fNHM`8vhWL`FMA+H1kN}nKaG5xkBREnV zepc)d9vzJ_1pfGo`F$kWJ-VV$GP8fDhhjgv9h!IN?KMjj^7BfA9M3YaJMvDli24HM zgUD;$xuYmdI>Kf`JRNx~=6|7>SOvV6)A83Cf5fp!+yCOA0KajV=|5bxlo9N^J6RH6m_oR7=(cyMF!b#k)M-o&AS4=1s2m>+ zLerBSo74kn!qjSmNjMQ2ga;!J&wfQ7a}RDNjJ3d1!(f&8x2GDbA5Pwk6R3y#w;kFY z|0M!De%X1Wh*F@Sx=eYMt`}~4-hRwQnu~1H>)AG=$`HrMpG;-ZHYDfoAp2H8vbE%&g!Tj#rPW39)XFrNH=SU8{`DOuaM$I6AkhhiPc!>f+STJ_c>t?4LG zKdzi}q3%KIT8lm&$C$Cj=i%VLXp#eOy}lAa?FX*Po6lXq6sHVPa87jC3#7lB2&MI`iHf zYRu>U zV7dG&95Z}Zp}83WeaA}-4M!_TKgMc2i=Y@xZhZPUOtOTi;GvLNO)^>%ayeA`v;*<< zug$jEn-MjYG>yRa7qrEv{_-HJ66Av@8KsB%k(2ns)KT3RRNJpbJ26lVcoH6au6-TQ zko+yAV6O@3X6F5E{!xss^3ulDH}$~~vq5mo-J4J@01_ESo}hV`=yJ$-4Auvv%MuMI zAb}f21C6EzXsVsQJAP0V@yZ3CZkA%yz&ytHlZs*P3l~4=R*~LJqaMvAE35W_( znpQyI*NzFJh)Re%uih*2zym6SsooINO#=P)a&x7b4vg(q5jk=%pl@j@U2*w#Xu#k7 zhFI$?)I0i!J=@6yEAqfR_P{YD!(cy{td@c1ZW`8qZrp@U&g3+n!XbE-_Kl|g7~>!Y zP|{set3c=7UR7`-zZk{X*zH&*>dc*@HeCF<| zKehmsa7$P5Hh1J}E;t@1P>Co4!{c--;-RSXeJvd;=HsO2$-Qvx2Wm5+)O_@02i>eG zW}nh2hOJYPJp(?3xE0CnN}r!bARM?x(a+n6`0y#~>uC+3k3QgYDs=~{4_Uv>v8e+k zBz1K^*?Q39Rk^3%$ipEhP-&_EK?F)<|M$Z!3f0PUBW!1gJ3)xE&AMqe8ni$Nx+Q5l&7s zwgKaOnCnd>P+ds_xL(F#YM6(TKIRM8zr~{Xu4XeolIuX0Iw@-Ncn+AZVD>cS^*$)8 z-l<}*G=@%A=SDM*A(R~T#NXV*8fL|%7cR(7peUNLnDw8jNRT6%!;P^Ra%-&SGVaDB zo#LHrlE+J+_?0w2%A*PPi$biOiu!>Qr#NXdQ;c}C8DAfsX+fLn5$YkM_12p!r;8)(U3gRk$%%SZy02bkbBl)Y<;4ZL`n3ZS)YGD`a zbIh$!xSCK;-SQ^l*xh+@R(}UQ&3GK*{i_A~cS|*Y%~+!^)b}++XUxGfTsdvVrvP5; zCh2ZszBin~qrQILC9tG1XZSE53vG-v_z_**sMWCH&WDl|s5X$MJ9^LqNvi#GXKL%A z!)-#q9)BGz-feKX6;=QO*}a*sXBlxH&^>r|rx79zH<)VOtA3=RR4DY=A7p297Ca@IKW;4;q9XD)d5 zm=#B^_fj%4{VxRk#Gl=bUBtfEh1ojXP2BOz?91ySw78s(=tGl=@6bTc6!7o|9!}@N ziCHoK7|J*;e&?#dMclxib0}eJIV8QtnTpub;!?WAX4Wp}gTA%;9`!Uij`Njy%)oy@d2joCGPZwj}Rxyo(z5b7-e8;LIL8 z8RY0mkDG*xjo)TumYHy8ZRobnXPm=1+_)Q7$-D?(=T=tTMh>7!*rEA+=sY4}h`jh( zn+nH5W-3ibm=7N_A}5at&f~lVXQVC@r9%)y>NoZfLY%-53)tq&!lxG;=59;{;JXv> zKq6rX9J;q{+H%K1=k{H-8;gs;`SVd>p|mWH&sO#Q?7RvQR9sM)89~D!q-&j^b?tTui;63IFB22FVZU= zIfDy1Z&&KcvW)IsP(1o|cz`k=8kR;Z?E>>_(lm?cUogaUM44W^4!g_(5(5iEz#>E1%(xIM(N)_fG6ZG z35>)A(7^EGuVF1wW7G;;bD;4y(jq2pRr<37R4+@P72U`B(Sz1FGHU!r2OZtzCC7Qx z$andp*u^8DTFtn47;zd$KDT1caFMXF*fn-sSR@;z#`}dRUhqWMx7AA%ohOjFSFq29 z_b8&=);uzQngCo}M)xF|Yr$(@>OSk^Nr*QRyPAO{_kJ{{WvHrIaI%=- zdgBmDeVYJR3fR}FQWj;`gMPci-ATz`C~LoW_)iLPbD_0z4qUQPpi=Mysm?jKNXCE z9*b}t7s58(&9M;dTxUxSHGfgo0}3hOPFii&@Vowrwhqrc#t&mVwLWBybn&)e-D?r0 zSFsG;!!LxU%f0=l60<EW%AiR!kz3uxaS5r{bye=x=k&z zyVr#jRlO{={P)n9S?W%PFm)r}wGm-$fhx4;q4eb1e~ZX{c55$UK3PCe?g+( zMQ3cU9yA6VucmaRqt^4^$*iAFBKgSYqW6}Iks{-nFLHEA5G zQ6zDi@&1lNq7RN~V@=WWtzB#8<53VVp=J7D&x;-kr*E&{$dLyhyHPCeYgz-cf)M$Yw&Or z6+C30y{H;T#DnX3vHqGe+mBWEWEaU%P2b#SB5Zt4EOB8*kq8&zI>}`HDi`heE#yhY zx&axL_V?XXY=3v7mG$XA-$Xr$7-Iu0ig!fc;Q(N=|eAD|$ z%KRwMR2AD`*UmJW(bf9uG<^z;h7~+{f=AI*_@lgJlPFlx(fWP(rwk?YcoJ$dM?tN( zKxFHgQpCRZzWPmr1$cxW&aGeLZp>t5xbZV97^!Mr?TyCHZz`e8Z&CT5K)Wnad3*d^ zqkdgr)w|3TWKvvcSZ;d_XM5+xYLE03IIyw??D;IBkcV6Sj{2mHcCD-L?=CXn$kFP3a z|D@+h6_pDDXQp13;HjW}UWt6Xd@TQg&(Af(sv1cXCn{zqPJlr~AWNF`1<;~V>3hn& z1t&t&Y^-3u zh_mw^GvltW#8NU({6x!wJna!^8xdw+Tynod(YW#{$9sx`w$aS}l6*tf7IIadvly2D zhxP{kqv-ua)mSg8aMFF9sj-ILu)#Yn67DU0{eC<5KKkdt6Qv{Hk1Q^i#Fc(6g?oQw zX?=x);q};S75p%FU~7B9JxKBaDFzUo&Q+O4YAV;8@E$)!9ZqHav8{(_`wlk)WwQbd zZ}LZLmaKzNpL@C$V>?JMMV3aJj>A;fx#`r$pHVYsg=>j_8`8kHTeacMKuJLbTDuga zjTY}0jO&`ykP1z3T}vx{quALwhRYEZ;D74$kyiyZZpU?YLT@+?2ol)8L zxu`G)%{8$a>2gb;(W&~O{`?kjQZYL{%Q=KQaT;&)Ip-0cSR?_B{vz_aG<7MjVHHKb z8;UFb{ttB?5Qesyr6b=mvcmq`At2*t9`9>c0m=3OOk}=INI|&~Cr9Or6nrY3C!!MI z#xY^yCT#`edzPsseOW~*XHWQSCAENjKIN^e%og0q>)3twP8sGT);Vtye1%D$j`2KR zFQi|Y6EWD{gc6!0eIE@(qaEFS`gu&}H8xm!=2b%)a6D%U-1oFpjcO+Q;jQFJ zhcZ*hD3)Ep;-q}z|Al;EGqC>!y_3rQKjy&cizHXr#T?y zki3q2XSU=hws{A~hh#jw*ST>qb~0P5qOTeSU)684I=VH^)=ymiA4BK;PxTkaahoqq zWR*l@BxDPnV=;3GnZNwa#cTG~n6IX%GkA>WG;_c&S zff-S^{UPC1XeVfRX2^ma77VKEnQ3xCrdARU#V1x+3GaV?Tqe)4ih?tNtCty}+030v z_bYlBXZgn2A<3(7X^Jc|L{lEKTs~r;w>brMc~?Y~Wc;wTc|6|yTt@iI{cjjqmm}7! zuBppqMGMcMp1qNr>+nD%K0-lX8fu8vd6p&*VQCUiUbOGBK#_MWxu`4-8=7llQ8^)l z1t%s9{#PGi0{M2`LwoxmE`sl8d#ovzDX7z?eO($FGUd4<9YH7`_s8@GHxHbSUc;A& z*MR0uUpNT9-GemE?CtV+((pl*m;l4QIP8|?2amzhNGwmaF8QfC4P+0kKGQNl30a6v zHM#Map|@)i9=q&y`2MA2%;O+4%+b#<;<1z)_SDFw{)XEnSXO+r-o+t}C6fL4ME3C# zw9Ihv_^T?1F?}i=_@}-LHa3Ty{1?5jj4w!2pMe@ij6C{f+-r^H^LqCdiC%=pYHsr~ z4kXan>$>ywo+M1HNnMeo>%s6VK6WK@UxwihK4sU)BC(j0alx$%gs}3Js+^sd7M7*Q zkaoZK4~UdSl6&9MgR0zZ{O4N#zwT37~Q7HoL(NpX4UFT_&fTHh}qf-U^_ z%<4oJH|L%<%Bf7%fwp5^dm<~xh`u{1iT$humh8TL<~G#`s1hDhZ@~3Nz5XHUUA|3) zxu3858K;(nJ*BODv^q-xUs8S4`Z-_@Ux;<^_OW<^SFVa5W<_Wq^=$Q7A9Dx9yqO8K zhH?Fmlh>z{N3UUTLjaChnwWw!DovS5>xTd?c}38V&`wzI{X5p_d=)GK<2^*vW6%yy>99fx(Dc z9@pDwnB~fx{ToeuPA6HxzX?h8GJPaVs=)otOs$Z6-0;r$#gVh*l-O@wF;C{2Fqkrc ze{SI>`rDL5zB8%w=ySET0Y8NaE%U#nACTscst#pG&`6&v65p zl)4DW3uwUc#8%Z5(*>N*ZT)6&3=4EKN}c{_whG3m1M5W+e6Wi`A$$jQd_(vj;HMPW zcnfEd!KWqrFzJh!A)}=!&oMR3Y0_dR7PyGvSl3$TJO!xvDAxTnnil&M9j84cJ_Pc- z%1ARfM!~bel3+1LA%zE|FEOrHl~i^ zF{I+v{g3yE7IT&*{1YOz3{G+xWHe%}F*WP4>&CAAfT6-exo2$#Wx3T$HtYtW(DIoz z#ltg@Vsx%&;(;|%@#JuDcA|iO#)9JgR@bo5X_c(rl{0Yqf?k+!!39{(S6v$(B#3>V z+tz24Dg{PX8r=f?gJ|i~klw)$bvV4I?##&W2)+my+TAc-1ox=kjaK^30KTaT53}KN z#GR46E-#C4-i?0QVF(JXG=y&-YQe0Eg`@it^`vgy-v3NO3?ThEekYt?rJtu2VxKW^H_wSi0P>F4k6+gl4bD4RLp2q3{ z-J}k!M%0a#+8^!&eAz}9M{_U4Z;k`Qsp&Sov=P9&ywFnnVGj71Q)*r`dJp{H^Z!kD zPeh?ZA-zbA8)K~^a82_8Fju6z#O*}@;EhTajj!lKq=@@Y=<^=n@KT$M^m7~dnSSGL z0H+KVZa8)BJ&!zQPfPcifVL1^^<2+t2=stvWvxFJAGM+oA!~8P8_QthNcxJcbrK?N z2&)qG6oTVlf31x#enpZwz0G2h!dS6aSN`U&3Z%}qyW2VY2M|BF>eR_Z2p3AsxqlHn z#Y*ZE&3j1uQBt{>%w=tQD6yQ0k-V)%%RMA4ypl37M&#DGR@i%#uUO@>ktYm4zW&U% zXwrwG``+INZ;zt52fGGM9J=bodW0^mISoA2nR1Dri8|N8Zr1Yls% zwRA~a0UJy0Eg#M+M*0{(;U^LWn9>w`*Mp=0Sdg=_UuJ{Y9adWf7TyK$DQb%vS!5uU z)yzj(#*=7-KU9nOIxXfK@K8|tX)k!sTYJ85JQwLNus{6AD~aVX?9fXYNJo>RJyBJcl}_#HaGpo7;LjTe=eFmZbZeC8Z-tYw6}K1w2rZt$$K>5aT9A>6AiZs!!K z2j*W2<&%%^U~=$Ldi;1ESl~!tVyNf9g0VJLpUeB`iORWiaPAlKdUkkg_~AZozEBd! za19T;mzrx3yn6&JQtcYF^L9WVoY8T2)xV>fPo|aNt#dzb_XsDMnUes+?!3L!QY) zIr__2_Yb3BF&C+$WN0+p?_SqR_j&`n#W^NycDJCwdU3Rm(-Qni?t%ARDh^WHv}%LV zMT}k$yWRCv8dk`F!{I%G7B1ZM#{HE#EWxUa+w(hM70U&kvKmEb>UZH%1zsaGp2`zw zWs-r*w?hrxb_y}_D}?o8J5rD);&O1?^Khu_f0s1xQ5e*C|9)MQ+aGegvGfjrf8aIW zdWnL6i?DN3_?Txf7D~{1+SXcp$7B;1at&JULgkm~NqFH$*i)IGijA>Ku#DA*o*=RX zZgltZaNx^96kKY!+fWNH$%HP6G2Vp>+d*F&lrynpanUKF7ZUIqwdXzGj4;Tf_DJCj zTM&%o3aKfj@P)}oA4L^4H{nAHm8$_N^KdpPsru^OXm~4vO4}f71dDp4EmLeU3PK<9 z43hs&feITdq7B`pfNfz_y1wxhc3?1(?SQul-1kjVu=yxB@G!gWX3$qOnMJU3eJuo| za>wF&{>}oLg2$&ri+(T~|EAJSF=nVbd8u=t{StgZo}pB#oPnjk)^fCd5DzQ7iK@=? z?1PAz{if^EPho*_oc@&dDXO*j)UIvQ2N@}^tw@Rzzy}^YB&MFJP|T{$&pPc8OdI-V zwq8z$-ybTr6$$SEdp*Uj;;&gyqxaPhzvRE5JW;>*nqM@$AKKzGZfS`3|*pg}mTcK@HOUvBCmsFOhNxbH{82LbYai+o>z zoG!(JXiylu5iG7!Dmjny*M2$Z;D3d=$~?0?`|A+(4c|R85OEb7<{gUA9881zS^MG)#0p>?+ zy&d*>2qdyNc+~YcLBbShDpZ4^P-U&|u~ieS$yIJ6>J&q-{`7SZ=mZipz%(J_x@f0oj`6loqF*;2#0q<{@=b_~WyL#8uD= z1(ciS>8nUElg#Hhgv}81WxDb%MC%{YysJBU^DTs%g*-o-t@jaGx@KH~wHr*ZEOj8* z+D4x-WoyG@9ms0bQG_iiVLuf4pVuD9VQ1c?eSePH;3i!(u|66K>nVb38boiT8izD?ltwKfJCb4oYX>rH`>d4|B>YjM!V zH}i!?KSJ7;3$A*;DcED4(5CmvgQ!KtB;=NIF!oz!{(SQnAt(_KC!`~IFXYP@{ZA)ZZ)x(c-1vPi#)*8xy?TwMv>d%)%K#}m5$ z4FcIw%E#rO27$s}G0lM801#GtS{Gn~^Exs`>ymNRf*pLp5SeQ;N8eRs%%yXbq4{ndev4o|5#rYb!a>o1$ z3qZg7rPo&o3ILZ>US;3(M<76`@-N4r6m*QAS958@<^4ws+5}8Lfv0l3ol|GKKw36a zGB;m4@M<@uZtBMMD^;j^N|~2}io<`G#mk$(v023mH_k`?`k|4BE?XzA2gZ=1z6b-C z^t(|d&eJ({HfbX7au*v*aoJZ%(U>{#DI6*kIN<2GeON2^|#Ji(SWh~oQR}a zBp`CB__rb!0SKRyeM}FC0iR?}62-ryfUg%dx9k4K0x!`qktf7B{!xo~e{3)ooS8j6 zyULsZZaN-P+DyFz%o<0u?@V)m_Y7qYwL}WA*Tq(R?P@{i!=!qQI1`K-O{VR8XMh*~ z^f=D+l!1ZbE%H#}_uyPd+~CcVdcg2mS~@na8F2lUvF04dzz#p_1hMc(K!4eEEx)`)XMK4MHJYnc6?rCy)SbSQ*08b08$954eA zb-%7TMhE<(7_DXUjVTE~M6}j*2d!dHfk_;}Dtx4h zR3&vfP1+RD-A5(ON4%oQ!<3EUSXmvc7J0skjMo4ba`wF;PxOFGoafl}VjV5eX_Zl4-2=zz6%#Kg;LF2H6dpBTI2gk1RxG&qCRf#CC_HX)@aV8m_1S>UAw_^IY0 zy=JTiMj6LepWQYBN?9DKg%?!7CBxWmVJ&%Zd4NCR%4Hc~%o{URxYTqTw#{e1=9gp#t08xp!-of~X zzyeQwU3~uMd=eZ1xvWDN1)&{i5hb~v(&-Csu33)OirohM6>=6Exj5g#tDp~7 z-EY94Qjb&2tzb~gQ8iU&76_IIrnnm@o&%}#xsQUDWWh|~%=~<32za&gN|JLx1N^#q zK%8_7*8|nV!}yQF0=bT?UT`PGad6_gc`q%TkawN!=@Cx^xSQ&)E%;R%DeU*Q#S}WB z_qS+vJ0%{X%NG)@+6Xn#uh%QLsyfur?ov{#sjn8|zIo%q<$5#pIC5U)x(?14_`-LA zEi)XwM%l}Un}#TV--#u{$N+`DN3T}HY|)c%`@KHTaK7cIa^Oym8S>BaQF6!&LM_Jz z3R}mf=tEf#V|k1@`omGI8Wiq~wEuowS(h_G$G-I`;oQ+Eb%lwC47NS*~~XR(PR-mJ&oqXcq*lwncV_nrXYjP2-H zea8m;H(1YB9`hids_nh{C5SXQo^g}vT>@3^ch~V!RDl%XNiq2YYNW5qI-C&5g?O(l zz4h7^0jY$9X&)&CkhW+w`8uT;5}O>TSNBmvBSW9ChAbWM;PvK-8iy!wbD1?WX3__4 zt%m-aDqg5CM2n|tT^pEXQ5Q+Rhd`X2m|(o_3DAg_-tT)X2w46t8TT~0p#ES>>Q>AY z$?)Wf{HLu8RDXVY`V;3F={KT{RM9a+v4Kf3KV@x^c;%FPSDibE8&Y6Z(04#3BD=#< zW-iEQhAW&d;R#|UEftcvf82cL?@yPrn^HIqjB1;ZiWTS_kJDNbUIL#Zx5)l7k)VSz zIvd6(EGTzaTHuE6eDn8d9ttwT+kj?~EP-6o80nBkfB9=Sbl3L5Y1qqtY7j_|`(rG= z0wM?U?v-dgL^LN>>p23VD8BQD@YQ$=5U!VTEdAmR@R=EX{4iDlIR1J*;!kgiDl8Se zaC1pu+h^fnvxScoLW_uW=A6LXn_nw(kzPQN%ACFLkvDqEdN8~GOhw0g0mCe2B4{Cv8prp@jOwvtPT)PEX)$sxb0Y9j+6wMPy#`ksKW_AeV}l{7#Z9#2@TCi#{#*g^c0P7JzC|bx@Ix68%|A*u8D&29nJ*IqvM> zfqf4F8Ctv7V3$d3^=L~6NU||gI2c7Bi5}A*zu8PtU*7pr#ZX6_7j`C6Ux6I0YaVg0 z#>ykvEXosUH)e$B>BYXixPX34x)fDG0u=xKVs4w!-rWcZ*ZE)e{Kz%+R#PGSEp)k- z@X`^j2ht~eab?<{6}3&NeP=$;4kmT8SA}mXp@EY$k$8cJXkFQ@VRRLu_yp3<%||Y1 z?VX;+?uI&Q=YAG>$w3FL5c%kcTezU<4}8qgGct&eSy&QI;Cj6H^~}u_ULxs#!`*@j zuaT{kx4^m0muT@)>eZoZxLj$5*$lL( zO=z!dH#7gc-|y?=hc5OM=sL7K1FHp51+;_#DD#!zQ{`Y0AV(Bo!T{MpvbD7j3(;c*AZ1Sh;{9#I5;B$&^gGN=Gn-tTBF(E)O1D`OlYdNE{iFymX&xHwB2%b!VkS1auh%KE07)hV$Ezey~1JMXV_y z<5X?(h%X=qR}0362>PZYHZ-09GQ+*ZFD*EK?+-o+^(IeHd39u0qS_dASgqX*nt2V> z?z(oJzb%gHh3dh7tJ(n7fK1({$7uH2OG@2U4e;l#2iMVtI|`b}@|-1k4OB$4pk;Le zus!+4`GnF7*zAT>y(J<+kvUKCDU5yqy5c*LE5G}}7Fl+1Yj_W?ul%22uyr^1{`ZQdIq;?IQO_{WyQ6StU`dGoEBL%PR_!D`1(qFtuzXs; zolE^Vj%Uuyfy~2mQ*tdhUPvU5xOHb9^CR5O69%Co&BB@FcG{8Id7ehNwp7V0Z2{s7P0_w!_Fmw^&W zNshGq1;{HiSKaEz!Lp&-nmTVMu+KQxDLmc^^ccR6$7Hks*HgZx2YQ1b@rlUnOj#GG zWzu4!(ryDX&`B~9=hvJH{mN2E`xVDgX|71H%z`TAY#|zoA)x+w(HhCmfY+7(Y~q9G zfyi`^%@ENvIGp?asP*CmDDAQP{3&__@DF#Bz8A#hkcSsPZyoo7Ino76BjQOQ`LJ9r zE_MjSl|J8%$Nvsq$mKj*#UBRQKbu6w#qeOW+LupOInyA(iXb8X;XYvh+;w|F<2P7Q zdVa=es|TEk<{IbNe*;`Uk=^%P*#(}p(pW{_5@38qf15IN4(Ks4G*yk@IEj{j>Eqr* zpfjE5+o5R-I1t(5bB+E8uAkaJ*^sXTcee~!n~OVu)7Ewa*Ea<2Bt&h;aMS_J<=k~j zoX@e|uh(__bQlOXid*k^O@I~6;@*lwT%JFR!-24C2p}g~xa2+!m~&2M6~B*xU#xK! zzYhCBVx)q=w0l3eAlch-(W({ay{E^g!EqC9^Y2Gr}tG_QMhrq{>=gS-XTOd(icI1u*j#GAbD4y8O2iLu3$+01*5 z5eZK8x2k6|^piMX9P(ReFmwTp8!=8kp{AgVelj@pdmvKRQ1K_Njt4}8bR}%kf#3=) zX^8zBRkVDMz1zYm72&y^kN$I#4_*nC`R8)FgT=c#a$2jefJx1tG%?;tG&y5Peh`=e zlHWh>X7+UkiD}N-k7ZNQtDGixnq*wB#BRzYE$+O-H}m;v#JzApW02r;@ z+uK}pIv_OKG|}#J3-C)SrM%@-haxWKFxl9A03ZI@6o06V0log3YCV&WfLUePp9D`A zAXhgsO?@*14E3{~AsveaVO`Y)CXb#1{(*z)qSY9XEAvDzBdH7&OP){@Zia(=Nnh|) zBMavdr>9&Ar~##bBhfi30o~?tkb<2N=ozeCj#N)Y)?%l>_VMCCn%nHT$a^`UwT7OU z`BE&vu|4Im*$ycRifUQxX9JsuKktS4n1N$|K~{sYVo>}*vw)=oLkVuDIvJN6fbe3B zGKTXQg(`;@dWI%~`w_Q_KM)!M7nP`EZ89R{$P%%56PLqlbg#Odw1l;0v9*^ra8fAIGl7WIFlWY)vDB?{LPDuR}fb=}n1<#p=BO%6r?We1u z2tT7(_FS1K@>cQK+1`AM%x!=Bd);#ZoKoMG*&}syO~L$t=!?defL<2D==C zd|}Dv_Yx=Mj3etmk2HY#!Pd1I`g#Nz7q5)SRHN4`ZejuFTEK`Xk^Q$GGjy|jR%U8^ zwz*^`xI6R5b3|JWV>M~bK~pWK=~9Uo2-z2lQ;Kpy!aE*gpTh-kTQcge}%3xu=G8JWfefwjMA z{vVzLh(BA=wKwnq_(v3*B+^C)Yzw+gP`?Dtb`=bMD_KH4tWe z_%$~!3>2`m41ZGc1bAY@Y`4lSK-z~X(w=r#AR;>@QYDiEKC)16#_Om6X6mz3+@Enh z!%;uNX!~BE>JCTKqv~MPV`RrZYnzD-e61XQ;9G*hwU&i1xv!8dk?k+fxinBFm%TN* zVTWvFh0}yi+>zR^)Az>dfgl|F=Eu}yhsNjFf_DsG0}(0OZ!MHLNN-j{LLRRY-FW9) zB#QHrnl8~-XW}>llFo7)LZfmZA{2|<&W$!FY|1y%MrI`XwV)>{(jPz0>< z9dq7IL;yv%qzYQxb7?Bcbm_fj6snTNSCIF10SQL;U%d^n1O;AF-p)da$bBjLSI2fF zVynNZLx$O+%G927=feC@JB9GUfxkKUuqCm`)E*5Mb_48%FXSVon90Yl^=nWq3Y?Q^ zdsn4f#J$kM6n}j&^AW6dHY^z+oeg zP*++UI`jN+GwU-$r9~}>PBfT>hp!TNoVL&0XHP@L zF6D$n+cx0U2%lzUc^Q2z?p1t$U-0{>omhHA(gco^%hH3tw4+17+ox3EbKsL(W&R z;D#mwbEuxAOMR6x+Bmww)^=*et_=5C+=2B1mSl}da^WGl(0Cb({ zBM8>>0Bv3QwGMtu^hsVBQ+$W(=Uz?7mj*_ta^|SidDRoVBuwJD{xuk__zxN`1vr7j zkXA85Aw6XCT4Zp#7smrA@2t^#W+D5VKAZ#Ld0=wIegVaLZdD!e7HOlM90_O+| zc}_YA;A7h*{WD3&fb+^WzR+a?DDr09Khca5N_Z~GFyV4kr-7?xO8acEQc0Jlr-mJl z`YepBgkFG8#B2+5j`-kd&!yM&RP%u5#6h-xi4$5i?A`6WiOYT7S*nY8OAQMfL6l{} zAeejGO=Y-B4C}-PZvEu=25950Ja`=0;d#EL%)!s2;JD_1dof-eejUE@amlSw zwb>KKButO^Iabx6x#9gA)*ty`0YmBfr~mdrwqXL56pp7ZWBo5{R{R(|2_J9t!pR7i zKUiU{(#^+~IbU4d1@=ic;Q-UH<3BZp7B z$H8h}ADe*uHaMQ><rQspIlSj0T8 zwnoJP^V9#$h0Wmnl}+N^j)ttz@7t&A#ECuNZiR1_y~tS@Ka7`e*M#dy(sE!W{eTC( z6cgSse;EZK9cJShH&~#M4uO`0Z66RRxOpc9DZ$T}G|i8q>sSJL$ebgiFlJ)pq|^99 z8CI99;j@3@fQn@3;le9E2`pjQe zCjV9NrrYCL1{(u(`Ys>RCVvQCGiJs}U!;LQ`ot@t+zQYa*z!5+_63>PXck!P;k=sE zANriwW)K~$Ets+V3Fe=+R=;7ShwTA&?`BfzA*VrJLLc)w&vClMV|;vX+CPu@dib!2@unnA*($%mDaiSaNDf zdj+~k?lYc>w1ETSiQ&FKa!^ymiCVCi4l}Tvvz!(bz#J(T$SCjMgRPuFG+ax}u&y)k z2kAyNVu|If@vr#^LeEPT{opD>Hb#PULpX1dy7PPoZv_TO=!0T>FLoenG7ooahYzUb zgZ?6-Z2@mQj*iPtT0oNp0aXjm+s-YggO4kELE>C&bXRKza6Qq^ycNOZSlUxbu0xYA zK%Y{8{7l_fv}GY0xBmJkFdSGI4*vHGO*)*ncX+i1M*m^N)A<$Pn)}BSt7}Ez#^XC( zS||gIxPIhat;JA2b)r@Q^aBFdyB|sQ;m#rK4Ad=35olAWiZM$q9H>0#EtJOh27SLN zGRVOQc+&66M#U|SDT#~L8Kyq;WY>ad z?<2s`40OqyajgD?NQe_ih6*4-!Km;##!m z`Z=ZR+&WV5o&0Tx<8gOCiBvavZX2%fppD>7@rjZa^hdOR_{6&aB;I)EZO%9YR6ajQKE>sD zdAqCc6#Pcy)HVv`2kw!m%xq`A6 z`YRhmVgZ{hYiV<$Kd5f$xNb76hyETax(0fb4K^MGB8y>ocf64 zJQkfz@fzoI!Nw)}CusH=3TWa?3Cb7;OEe;3*lG*#{H;P_SJ?uH_?vUf(mx>SLxUzZ z-2Fk!)KvdU><7>ltS>Vr9*MeS)f26}AAp$tBJmCPaP*esRJXq_9@!_q_K2yIL8Ol@ z6HU6mB9bk#*zCG>uzBt1=7q}e6|*YmJtyf)|6h5kApB$7#YAnvBc3sgc? zIF2Jja;4z`kSpswF*%w?t@HA_kKfgybE4*lvEe7^+udk$E&d;<*fXw|l)nSv)voZK z-T#QZ1*AVqH_xLRcO$)B)dm3l+_7BwOex6SlFl)+`hmpUW;OB_gVEEG4X-OL<>2{e z2rNWi19dg+I8m`8RC#IC_@kaJ`r^Hm+FAPrQ4#78xVPH_vll17E-8^?wJ%n#c3Ki) z4yv*4vWwK1?crsMXXLKnqGTEV=FSEf>vP!c>?{E>g9eT?yM>@YSTxHty8?_aB>R84 z(*~})uF{EhjDjznK2+D5ngKWa(zO$lHb9l&@m*)C0tn2t-fl4(1WbH3w$ut3il6*T zH4u*>D`)rR-Mn%XpjbnV6H+0l5z9U${S}qGQm+Z)83h!9=We9k9RbeLYI!f;Pa%7u z*XPbG;^t4Sg6g6H1%UUY{#N>b`N-ag?b8jZr)bOlU2TqC1333zo$iBc(V%uqR7sei z5Nunv-s&8T1NRB({26dwA^XRpxAuwLP>`)eoAUK_R6i3r)3Wp*wkH18X_|8i@pfdB zZA>hoE)w0^tEPm|hlG4%ULp!zqr4w0>s*LBl_<*!n);4#|5>?);FkuU%ga?9Q*YbzYU=KS@rSUa)0pAdnT+!QM#II@R<@@Or z2pyz2yi=lszEvxabsY%c0NBW%>b(nFmD0FlSuQ{}_Pr}}3Yt)IpsMO{4!}wF4n_Mv z8c{3o`D`NZo=b2~!%n>T$4u#b2~nq#Rz; ze=v6Ilo{Sa&loPIb-{0i7FF&q5q#=$luGvUJ?!&oi#&6q0M;xNFdGe~W6Me3_wE~g zgC2dQri|uI81{o~y-n~tjQ{qbitqLsmipf#&X%QBxJ@@>5^qZ?)ge*ZLc4JRE~I~S zBvv~D%Q#$XkM9oD?y&Fs{f!j9R(I~aZtwt-&A-sl;S++4_c3w8@)V=dnD8hK~g&i|}{8h4GJY0x3A~(Zqp{6h2c}jGw`s)8)uj9kz&s zpg9LgUGxQf_>cM}fs^2UX!x_NIN~}tlsnZZ7g)FlX@^F}x+BbB+ElVgzFso4O?<=a z^)v;$zx-cd@qj;cB$IBtof(1|FMlPf@>PJkRjG8%Wg<{~E%~@wIsn>nE}I8c`akj=C4YZCj6uY<-0w0rf(A*x*fyHJXlPV3=P`x#mkAM_G?@u-nv9IeO zy$9>p>cUL8EPL*-Lp}?VPA{419z|exC`8(9M@C>{z$rfCX&z?zh=oV8eFSPX1=7nl zOkulPJ1JU^=HSBLBw4BO6ZinzNVWYri%jVnSJi`O0KOP^Fa0$_xVX0x65YFizK-(F z&mGhP>N>_~xkv&mbL)H(quc^;Y_BL%E4l&kjIZ{-xXBJ(S7oPcq8u=5z9#O0scX$Q^oK13Kr8Dbx>gD5%ID=zL` zg1@*abmRJ&VU-QN+XxtEXy7IXh;P9mH&vdn+#)SmJOB5cMBtb%WKeHM1m3el% zPvAEEw{+{JCbJg&htuFEzA}fsE_P+-)8Ap?BOLfyLG7x}oqBk2hGI*p=NaVT zx9UmIj)g4IR*DZUE}$aqg`Pi56UcXNPbYtu1dHvb?iwEZjfNW48D3%pknk~n-F-J& z$kV6Evu{cQ3(NBo>>P!m>a@S2r=t#>%AN1pq_u!O>;a67)hy7fYu26hj5^eC5Pz7? zy9m?*zmnt0(PLu0hL0|Z%EM+)3Q@G849l!(QQ^5fq`K`JrCren2+)Q6!vtlx*YY#} z6O|QAivPG|@ZS*l&v`I+_nj~F%av+J&F(O}nskNe=RFuMDLsb$FoFlFC)-LFA4B1` z6qwW%1Qp_QnMPZ);g7fGRNf|UA*~^^dsloXG~(?n_O;4}r!|QpLGKVOm<9?-8()FL zX6gQYl~$0$+;V2;bOwdSk1GuX@ZJj>v&|)>ef}GW z3_rRNJ{g0xTgO>6Ncv$LY$nbFM-te~;EQrC5*JK>c17-m!Ap313;!}PUoMRP8az#S zI}+2h8hQvzav<5g<^HjO2J9q;CzXMx790CZ(s%S@7;ExgTykQ-d1z>jNy{$xfrL@~ ziGI-*q*7WYqt!SJzRRjM>8mxNv%3qeE9`hM%R6t9)MEuH1r1l|Pjg_-Yve!b32Cvr zQasukwfazc;g1Ws@eTOWLgDs?+(k^01K$Ptjer3g-xWM-ayY(T^ey@)3wF(c^rvRP zI-)e4wK;zA2Sr*Xg3p9hu$$yX0`Ck5Mm`1~@oLCo%=(u{9VV+mj+aZ1+KeGqj~CZb zTki^2z6L7<%bkUyn=K)iiY{Z{4LSbaEn$UMQ$WGmq$T`LcM$R%q+%oO;}?rbmEZ># z6+O-MDtKh67M|bcizOJih2txxV(M7~X%erifoRLw-|ZfgsNt9XR7Kec2*2&gA07M~ zM9I!K&|3AQgVN;jlf6-3R;_sb<-JMdnEsZ?{Qd}-x!3lKnt~kDh%OChShT_{|LUsc zi*rM%*%dE!Z)ZqB(A+HXejYe>5lJ5KF=7khpPqRHGh&nf#dr7rBE`5HWdAYWD+e1U z)@4O=O(29eDYll36^q(hPu1%J7`NT+iRxt+pp;D+H}vHpHt%M^C!!z?-|&wWmNh6s z+D3|zfhz=J1(_96Y`+=|z?`>L74?xT#MAcc-`jA8Y~AEv zPpDqPRxu`Nibodk!WXS`98#}f``*ya^H1Mk%dS~*vhDd$HEd(*Kq4Qby8UndRZ2Vd z{0@h_VbuVVz|XWU5@uh^g%#mPxSWXnRWEC^}`a8!XI?4_{Zp% zkWFNQCtVo(gaKnb6ZI)IS`pjc@hUYsYl-cw4(L3>{eD+fuNrR!t7G1Q7jy9_2S9B- zMH{yuIkx=wS{+NT5H>(D;Uvs2h-G=E7%zOAMShiU3xen^fX9;?{xg)~7$wQFovwur z#+Ci=F-uMp%87jb;mU7E%aSr{~)OO zp*R&PHi#y9pKge}!N-pO`_~>uI*e|4-@4L4N&-`)X*h$G$gnTd__P#$lyI)1d+nk7 zIaqy3K5$kVKrKq2z~xmXEJwfv#z-4zI zBcu=kH%3zXHVI#1SJzAk`-r?SMdq}ZE;ItL%3Hs%;pj2s!l}SlM_*wJ7P(8Fy588; z^Gn8oy&+I)ZnEZ)Od9rv;P6kKZaEyri%Kqg+Yf))W}KDTp_5XUv^7zGP9kN_vggg& z`UdX(diF8LvlLPqACi*q5lFdTXqR-jw+~z9_ICOQH(}04HrDL4ek_dryOG)imDDxi zw@k%9@TC|}KkJ)6_J@N6c_H4v@*&U=TW+YrlTvaFW8xUvgB`|ox+c9V(C9AS(>6Je(?g;O;M7`&08-yns$mekof_@P!E2X<)aHLZGtGLo* zn4bTLh45Du)SQf7iu;iPi`&9?mpO9a2ZgTrqn#X>NwIv!pLibo=V3VLG&_VT4A1c~ ztf)cdkkjf-Yfmgc<$>Jm-42ZStjU+A{&&zuLrCihc|DdhJxShZ69Ffsebem8im^`r zb8PSH(lKYI*~})UKZra(X>b3Y43=|Mk{P7=!Xy*(K)Uo)D9=DjO&siwk?p<`RJXN) zskX#9{CIiTOowzv(w`V?GG)C~rt28E*z<=K_ua+(`<0XctuRdp*$za7buIqc8cGxSin_Zs8MeyNO zF)u08PjDi+LZQDi87mkP96j%o1Z(u08a=Er%qGF~_pfIq*nR13SewlQZEvEEA}1~E zoE>RWgnJS8Rrkfi2&y=&ZrV(}bv^<6B>(5tT30ew)qShM@Zxt!j{h<*?N$#=n$7qq z#i9VOY0_;F3A({GBi;ERx>{^S&68wVUD*;>{Pu$m>;@0{HVobPX5I;+wE8aL}B+ylOXX?^{=|0)_l8qT4_k~#pc zN$I{3Tf^<^>#WYzR(u1EK~Kilapx3qlB->%ABMo&w{N3f=H`L-gK;7DPg4PY$3md3 zWirruFS9p+5T8oR9JRM!st zcqppK4jTbU(_WS3*>*tVdci8mxDafrt@I3(VL)$Ut6tH(7S}WV$Cv0+C3tn$JCQ)F z2@tV$y=B*~2f23y`S}&f0fjX||L~a+ATu3d1Io%l;4QvD=dDhVZb(f+_OS(6+j0F) zr5yt__I-Va_^rU}{KoIYiY`F#q?v+fDjob=4j3c6gzJNDX{1>E9SQymEm$aZ3-?2&}R``CMAlaWZqS9U_#d+(j> zO?LL@T3JydyNqm+l~T&@{{FiE+&|9aoO{mweBS5vdOm~W(qh1%N?WU9I1%2MhrUu< zc?q81rDUx8BjMhKt{UZtmk`PS{73j@yysqpJc86C13GB;ygLhH;oUwywQ7_FGQuxZ zo_=hF*4w6$d*5oH(c4Y(IHU=V%9}v+UJfLcf1EfTtp{I9$x^O`*U(?tsm#t$1UCQ8 z&c2|og*R3^&Osk4VO4WT*-axK^u9Nkx>OCo@}{|pBzXZ~Bs;_!7dqfE^?Pz!ssFGV7CP zt(DQ8tm#V^Nq8V_;S&F|d<{q+O=gg`m4e*QRWk0+)KQ3!($MQV4dCYGI3sRw8cszL zlz6<9LHT@fQ=fk*qo503!mf(|(~~cH$5;%IW?Zehd7=&S+SBS7uQdaDrA@j9DRnT_ zLD({fIr8M8mDg4bfj$zYfA{{A23Di#aDBxVam zl;7;d2t*B0!SI-%|!-p;LFV(q({#x-6sL52~IQJnzTo{T0z?5MY1M^441m)OX5TI(9tZ@TxwOU8fNcFuaRBJevST z^#5_qEcOoVc* z;T-$j)jk4U;NZG%9!#ePtYYH3BCeXS|AErinpXo-U)pYc1=WrEAp!#}n1sM1 zg0B`3KT08dYas!;2>xK)@}clr_2jp2RMAivq}cP+=`q|C6r%8KiUr?asRAiKJRsNb zrSn;HM@U|>`JJHV2mIETue+=T0*Yw&IJPx~J6m0=5-Yh7@VO48MJ>TNWM!(uA{(OZ ze#TQ)`GcbFeYUi{QuriwgG-an6*|tIHx$uK1&>YV_6J2`u+gh<*~3*5F^X4Fybu;f zzw?Fij=TBMN|^x@OFc8Z#C;UI^HdZ(o&ziW5(_LaCyIl#i0FHy`e z!$9tjcncSGRQTm%XL9@OI#hv&Yneq;{Y%DY!mp8@qK|`?(ghRO97kwbG>Dm2T0rbuQSI*2NXamUSHX10S1g= zs6p2RY>9Qt7w4?eQMI#pxK<#r|JZRBpfd+Ki-G5dBEjgmIHqk!!vWEc1ZigqyTWU8 zQW{|u2e7!@9q(}@gdBP6`t##&BH5(l^QxB*+jNpH)_*_szHPBS{%qOCT3e?K+rH}z zCGw8wKWA~82E{Xtj+X8JZmV^wCaVl#h2SYZvQE~ki2M7*mmTpl$Tnr_Me}t5_$UWr zx=aE{!ivWQdoJ{w>qD5uB@u8dPtqgT<3=}D=_~6#86$7LDuIa{ zO=yFk`|ZEvf3Obug|p>M3be~(TBi4ro? z4Jf#w9Y;fhFZkc__=qp9Rh=SO?5G$Tevrj`bo8H5;Fq5)W#yM1H;KWssj7BgB4MEW z%M)S?^dL_oW#X-%4DKDOIZ4Xu5XC?6=!cIKd~fO&e$%WACi-YhSjqr$*dK;fGV#Nu zak6^`&*dQ5SIRFWK_1Qot$l$BYdBV>cbt5K&*z=&c<;mN0_mi8ue{p1iGKEpd#f00 zgD7A86kp;+C>{Rk@}IE{=-ZjM(~XEBwd#@=4@fM4sH`_LbH*Iz&BYFHm^?(E6MiN4 z*;(WL#zY+(VlJqy_s6}IZXNXKS4F0CNf4s2+$ix8zJrv#nYnxxb$~n6mY=Iq7IGNh z)ieL)0F{y>#UQuq>>mT1&Zps*l0Ap$$&}5Nf7}96 zt;bate0C-7-jc6lXrP7^URg`la#?5`ACAnrr3}QqdE6RaOejV@(ck}q00hX?`B}ws zAX?4MU&1b4aJ%Z?pA!mCU|NNqXzOhdq%P)M>H#Hm_C~(I@QyvKZP@$l@;*R(n&>!4 z`Vmm4HSPF2TcJrg-Jd=u9pH}RFUd6nQ`nyv8X7tg3km;*yq8NYAYj-o#c(zp*r{4= z+5;TW5n*o++c_UteMLTS^4$Y;lG-WhQ&KQ24Ol$RvM{aCN;{OMp9Wy+Zg(oWH8ItG(aEO)?3}0pg zzK{ljq7V8IZqWKp;T$a-7pC8&ce)4W1!R8WrnjK^Y9gQSt`Lm>xN+~CsT~9^*Rv!Z z=>6Yk`r`AA2jEyiELwKQ2)xS9_L^NX2kxKVpLa_%AyShjkl{!S{WI|@j`(H@wm%|f zC7$A+JGOK}-d_K~%9ZC#hM(Mk-K^>Em<2+uZ{b5ee<$dcs$2=MO$3q+ z{&$am1c2^;Qqs|xkAPX$NZQB#Bgki-y8BY)EetykZ*?&5O?7YaW7H#i0*xcHE4iVc|AmN(k* zSipO6{^dp%;Qdb;5^LvwufeSlYvF0KWuSl7`E{>n1~S!;=jk3V0DZ`pdb7A`(9F27 zJZLZmQO#iwMJGSQ>4zICYWTSk88PGca<6IFv3N|N@DHCaBDw!s^281pupAEgQyhU2 z_2}nQZ}41GS|JSzeE-|t-R8rEFaj*}gHmp$-~lLHWAHpfR{)}n>oq1hgqTO#tf%fi z5q9m{#EFyi{rKDye`DBaGfdh1Tb=wd0MGs~mCFGByqqwJ^7+~aZ>n{qFH7S&=a#m{ zg&O!g_mbPW?-xJd&yQ$9rNR=-dX7A9CjJOh*ZzeO%+AA+;w*8w)<>{k=x0yppMwv9 zx+*s#zXJV=;XvUoo{x6C7Z~z!7&cyf_AwNnf~tkQ^S)0^Q^q%V8Z&1`4do$H`1pIdvb?+E;0H3bR z{krK&XfNGQuA%INyXudH%Bct7J{Cl90>A%w`k}M1>!=)P+@jc0!x~{Yyuo<_-y?OA zW~0w+{Q?3E>)Qu-KB2@K&CQHk;}D+bZZyQz2Druy=fwu z{2pdTBN=>O{(wMknoSjfaX9$Gaj`RX9UK+B4l`CK;pTD06^)5~=umT|VQ$$12kMN& zuE{wF$k8IzGRg+ki#3Mj%6q_WmH)^vcpv;}zSj)C;)das8!8XE)FIn{meXiO6L~nu z;hiK(s7UG{NhvoFiSm1q+su0bU)22BuQ*Rsz(Xe|aVrMT(Z&S0A$7WL{ zRsxy1!TrvrYA_k^BERlkj~XN#E8jneg~)t~jQ3;KXu7Sn;Fn7lx@+CR=y6j6jpffA zKisH5*ZcT`_{3}Bl=0@)y?$r#SS38c_$CB)WK{I!)lxv&6T=i-vLQfiZMyjretsGj zw-Hk52Q)97&grd00*>J*%H?|jTx(O3yOSIbhFaq4Hn&P(B3+j0%w=mRR!{0b-&g{! zIZuKdta8z$NQ%-6yjRfrn)z5PyBlggyyz%9nFT{3x?2Ps51@SQE;XlFHmq#Rs^JAP z;PqbN6WbVm-&uCC>rHei+@46e_OZklB>BP~bIrA($a4bI>%?e3x{0}PfyE1M<9-{l^Sq*4qf-n zY6Nr=;Pr8gPMT#koJ*%a)LniI!6cRRRa`mnEz$o~Nc{u!vtFkC0Dm3b97pg3<5rOR z^;)Y?w*>U=c1WHliv{CC%4*h?+rchMcfzZ@Is>kIBa9=(M$0{ zc_Al)g2jt~VNxKDaikZp^aqca3F~0^>fR9TS}Qz#nPE+1(gERK^zVZ{_CeJR_qsdK z0(C9NRvtt6eA6NULpyr_6r6P`l$w4EDY<`oQ^osWQ15f&rwAb=VJy8gSfB~LOhNA_ zvlNg@K%{buqzDMTU{w(q3q|YyL;{Aqg23;ZtQVzWBx=}@;Ik$12a6Ox-GpI#^k!mb z|B1Oe?A<&%8T_CO1$unF`{Jk;4(^eP7#n(kcEn*;5#AeoRWdT{gNHAYJ+O`ViuY=o zta>`A?L>knfx$-t{QfvrgmqfxVk%_L2@Rg8l5zdzur|`3o%dZ`<;8GP-8wR`&lH81`9g~4-(bk)>HoJzj^o3dX-Gy z?9dhTZHC%!DeVzTkb9)P84>^|%!h7#CCx@tY5crQGiHeKArYqSWeR-4Tx#4)crVyO z_@#=6d1$2CLpx#hKK_3Hj$H^*L084Cna!^#q9;W$gLx$ih|T$CWTKQ5vQ_TyBhyev z+l2#Te5Vt^B=-n&Zb^jgsGFp*W(8>2CS~F5ls|eONB+@G#uxaW6~t@Y&W8BjES2i! zV02(>{;_2}7P@!m3 zuos{=*EJNgeJi1eQ9{!Dmj~kARy}p0S^>FDrVhxsIU>=qTwn8nKrpzevFP3JfpDe| zK!Ag)#hoz4k@9CBlVIj(4UB1T;~b8LlP^=O0};+{k8Z#OZGq)2e5P$1_%&I6U} z>$NKnQ;?eO_`jqVDsVrPYTVtx2h|4KE%eY=LxRdO*mtC$@n3T~QfUz=FF`xD<5eOe zJL<{Bxr71z*0L>jJqFdf@+&L(1wgLIRf-8YZY)=rokA&>e!<3M-BfASYY9 zHuwHNc}4#}y(Ci$f9CpI$$M+or_wc7|FI#wD3Bz|4rOvkfYl-aka| z|2kV`wRi!+(sv{8BK&=j_ay)3k1QD75V>$G1n*Dtc)eVDHv|sOWQpvae~#*Z+I|a- zc7?mmB)mhS0m!Co{Ci$y9{gR^8A`(MTiH&RrT<*af|X;26~1TB;KA!FoL=5laQxgcXM-LM&e{gs&pZ&ZuP#{!*k$Vf*tOD;^+jFyoLMBX#qBd zg@c1-4oL29`m4#esmSV^NkO;423*RiWzuF^gO4`O;v2nG7+;u=bOQc8-uj{Q{Q)61 zj7-yo)7zB*J7=4qu|dI#?dElvaA>VU0u2+<-ET~I577*ZvBO(1x>OlJhpuB|g&rGw zUru9D$It42bg^MKF9p`}>d|7=wA@VxewQ)H`>6`1b)BHu5M8| zSjmZNd2*(0pb-&B*fI(2Ka~Z7b%3W-1Sk#4v6fQ>8*djbDHuGNH8T*tOu?#wf$Iu%bqTDl$94T z=Z)i2?W^rD?e@e~JeLuheUWa(8`}z79oSvwXAGG8SxSDYJv>jR-2zkgge9NI!TL0&)O$+sc6s3oGl-4wbJLq-*m%| zXKepjxkRC2eQB%xgG`U&BgJ;Jp_p;~ zIBKf{{ysbsKW}1=0?OMgm7es%8bQ;815$I8n9dQZD)0-O)5Z9|-$+AsuA=je>f$(j zF4fwCjS3r45ovkP(FQ|qh4U})en=y4qMuaxeGvaKTK!L0HG~U}y*#4B_o*K2-C7`P zMlq8oWA@FO0A{#;KWuD8qnteMhZ^6|4rL=WP1T@_RDW{X8pe<=Z-z{oQat*4_KwcN z`YQ-tyGQbSED(9zPCU)NT8RF8<5a6dUj;U<1nI)c+eqDfw#t&b7(G(S``euJ0n&Le z?w|O1M#OvVu!yDx_(r{P{>#k{w8uCl9mTl;U-Z>}|1%2$s#r?BFU#YgGkWh-{KFD> zTVR_Y*6T8xMjpUzY-p^+g6H&7uo3f*9RT;p4XX^_ zN$^!>@$7EjN0&GBM875A*ZaD$D?f7WAnJ>tdq}`1;L+lI$12tje6-KLhh=O7b6~{n zXWSFuchUIexzsi2GNa>Hy;Ta@W-DiWr8j`_`po4JmpBN^e6;-j?*?>bTy6Z}I|`bc zEyrp0Pmwz#UdAx}5i05DLnQF|fFmS6dt#{{B`e-`+Tlw^um73&2wp8jKg+L9*guRPxn0CUn=Wx--3xILqancm+k zpt4jXT{pUj9#GfwPz~beC&R+qTm2L0eRiLo$;B!lX1;Rc&w3piWq8a~;28ux`<3U< zDi5PWlV@$W>k-yM-XGf)n=*$x}0*QvP2>_AEE%-}fIkDf+p zoSW8t3H}~8yL3x$<7{5lU9ica#De79EQ4MwfRYrf-ftTQlYDtk%lNkdXSL$)uGb)j ziu*wf{#KA6?WRkM??H-uN+>9)$bs8!EQRYmL-2>4mqz=69UmOGSGgP^) zjaw*gJHJ>7jY8Zzj}SfLIJCe_V$X^~(Jj|f8uAo+xRvx$r^m4sQ8RhnO7#qe9=nw# z8`30jDIq#!p3g*%5f`6#V9()Jj1QCgYdv7`Zp=)*Jq@-?Jl}2~`vTRo-xlZW2ymWi zj|MFxKjS@^?+Ga_*PuR}X{^3?27TrI;>Pf|yF zf5FZ+Ai(Y94pg_*n$`+dKy+>OV4j*iBsq$Yy~(Xa#S;U2EJy7~gmHK!8*4y+2xOL4 z0y>fPs`tfR-A~9PheEI%SAoXyo6Nq)AJMctkr_>36e?wlUsc2NM|ZYh*{M=$) zC}43OIxk6WEN(<1>2&g|xOY8h&X|mznqdGwGzuEkaejq+f)z|puf?E$QlmE0g-ysI zaJKc~t8(ZW>TnBX?L!*P&%UHfx}#HPsnC>lB6@yG;H%NaSkxP_|C5KU6Md6h_dm05 zie6YO43%?HU>!F$9!MOqp%Lq(Q?vNoC>3$wz|_qNw5ppHr(xd?xlMMp&qlYAT)ddK zrD-bqLY!^$kGd3@800_yMp_4_n`kT>VsNn2=|AVJHvl^OwE6Lg!$5VD?MmNa2`c|I zw&ghI2@!X1H>M6;0;%7$4O4xJps%Fx($ydhbpK3|{K5A)3x7_v@W^!{V+PAW-Lyh< zY-Ql2J~|Hqc)XDN@)X?0Eg$=4bfQmW%8mH)C^B?k3v}Hqg-*3^3zmWS=T9Q<+KbH3 zNK4Cp`#%Ur!?I0wGv_`7*Bz4!gTpm&UNvYm;!F?x5!y*mEwP1E<*5kGZZ_;FTqtfL z=nMpP-1~I>BMFXDwO}HDaSHeihm-_!C~*b9jq zEcW3q6-=0>%-;@T(#Sq$tam*tW|`iAf7V^cdP4PqzqX+rX73k?k(ncY;xOri>X2z3t*AHJJncX~+tTmA6)n&FtM_x9Pa zcC{@&s>Qb$nf6lx2+v_8v+tltis;7OI-f~X-G4)Jq;E`g`VqUN*>AQg zUq@oe&2I+v!%ZZT>(%sU@fBUkD%Rw-+?sr>*QKS{iV(vD@3vXxypzS|$WjvhFnNsh z`h=XD3MWQX!rtuDq=3CN`$IjHyaV+;EL!~Un6cRg#@dK5W~{_CNU&BZ3%kDHa)<1D z5{~vZI7>T#?$!9Mku+|uc z{iI}HtYfWrzDSl9lcD3j6|bm+$+ACUIrXv&d%biy$=m4)CaPm}a-S53724a~`yo_@ zsfna8MkeNB#(yJrCJY*Igr_wBHhra+eCr^8*(2ea2rIb5sd?oTPV3tKbHTwy{Ck|gDJIcG*qP{Gf4NT) z;7o^T^!F^^g4UIs-kG99n6dEf=cpsYl^*g%ZZ4n0@)dHXEaMz-!GnISrWdbc|4rV# zGV9=iJ)S!mvnI%dG2YFL*VHD#C8Z9oxc$cadPBsz6Jqv&>~p5uNljMlL|6J_<&)R2 zHj0UI_ILQf=3q~9s}dQ;&rWNRkwqtZxW0+%}`a5e5r z`5!4vHsyM!{UdEmR#tCNmD76PUy^a>>`ZwO9qmt0P*?dhCPxN8b7CZ!vV$fn-E35}P%* zkx~Cdfq87!Nk$VLK{la)Y7+}BHhgbj)6d`%F0@BzU4Hf~7EN=ZRLQaqF$C!6s;2KE z4x@{7oJ9D1gk_MkJa+a6P?9C&~+-&#@RQ}@6%Q-qiYs~KSL!*>@_ z9_nHP^ID6%CKqvL41PxXtY(>#yT>+Q#DF%%Z3Ym zch=M)CK3DE;VQ5HbsOPlWdU-oaahbS5#fCsZ>&S*PkQ=@3pU~ZwIHlD3)jxiA)oE@ z9qXp6qpUuM=QjTt3wt-*kEQrYR7@wl!va)~r_2W@aGsqvivmd$aq9He-F$&KbmR2? zd$m6lI8!o93L^I@@S^*iF0A<#J-^1Y>f3M5m+5Zrh?e^%>&l9+Iou3Xn7UM7_D4w`@;S2bZo70ul5#nzAYUNKAy^9kx z6)#D?)B)^27oxcLAL4eut<*A)OJbJf^~Ls#GMF%3jJv>vhnU=l2=X+hNL*4ZG0Q4t z5>7$|muJ8I1SiMNZxVarF;3T^9tLbTxVd^H)D-JT8E`qk`wcH|2_CyoY@oy|vV4Eara*opyQf%) z7)Rk}^(mx_0%IC>7XV^H?0bIq$unQ8U~WC9$L>@eIF9KAYj#LtH}3}defmEiqmVB9 zs7M?8nl)x6HG^SHGuA4<0u?ZYoNrWZz82U|OGCX{&rGaG%C}B=ECW;L#xeb}cEb!* z)g5kFcwkg)vqIFxE?AjBDOEC~EDnpHo}Qrog*t6hmY#$VVPU^+3@gt5#ILUsDAfk0 z(60gRSO(B zVp2B7ebTru7a#k!;kh&>n=7O(WebRuLndVFzffHLx2K7>nETKy6=wZu-Vh5Mn_+){ z!vsfC>|8JuY>o-^IvW|#2VsFn|9$LHn8)#tU&{*lJdZn|h`#h>wGBt;;d0zaj>Ea7 za&}$jc!h14;FtQL0=RJVtw>jqX`sp&TApRzg;PY<%v0{ua9V$U@4Ndp=u1nQ*1nuW zd+#Mm<;QD*o4GajpVd76{ZyWHUwjD=yNH{U@!rPH`G)hp)wISgi2hnyD-p#yIdpIJ ze{jJlO`ltiE#Af^HP18jUBfUeE9U+bwu*e^RL!FQ5@E6Ai$y;L?qW+2?|7bz54+tw z_tA9WBm8N1&yCtxL4mAuBUG#|*vaV5(DK`FL7+ZFB!0sh6S->561Js_#n)JOvk6LL z0-xWmKdX+z9Cw6m`ToAc#6%p^Gd~YvkoZB(U`ey;9QfOj`s_yO+m|{ugkZf|4$qZ)?!3 z2r2Ck!x4Or^*V9H#u4gQNqRsTX@j#Szj$H(y$Y_>U;hS&jWo7(Bc+5`$`GgA>?}k6 zS_AuDi3RG=h+`R7OU?}|Q{o0E(#rY`e!}U0XPZ(}wJ}lSaTNJL0qc&FEG7$z2Y<6K zYt)w~VJFV9>%-eIs z{?;PaLv*t>hiVvCNBURwe$@x8MDSlZRcbOeq+Mg&>p&`LpnO`-CVU?w2_&#AXXSI@m$#|S8YK41#i#lnna-s@;}U}O%0@)GY!Y8jtiOuY>73vUDAFpcc1|bbatV=GYJjAl~v_Aur&x`cVQaQUI6#OAmRw7zdJG>ox^xE&s?zSist@B!&D)xgOHCurz8?* zDwJ~lcsCWdd0Qh-`#%?qqloKi0IdY>aiqM!m+S&eJDcXpkx&YjmASl7p!FPMxbWBE z>d7#yR^RqGu-h4@RL*7G^~Du;_qs`FgK$HAR!Rfnx;9(>f&8-mu72Vpu zCS{TfnF|Z>n$N;$bK3LSX7@Ewo9*d3@LmzFC zL;orhi)<~H@AM6I)UfRWpgfF5letGiJlv!k#P`x zB}+uh9G{<0IAP^(oQvO2zaE;;NrboZogyW|6=1=}4Msi7F!!WU0@Qom@D4Uhrhqh^{L)BhmkjSjbf5cAeC!V@}2GxTxDG* zeOF=t>2)g`JxULuc826vk-IY#wR1OAtoy*}SpCaw2R=~$H@0mKKX>iX3JN4S>jhz* zSIlqlI{=$d(`ZYJJ$yeUl_??R0LQ``Cof0Y!WBhEK~5oSaH=bpB~o#N$%M8lX(A7> zR_zX32($xcCS!$Rj{uN$+NxpL_JM<=nX4L?LZIHD+~7`2FtDAzu}F2MQ(|gQ#jdEm zMS`SS#8}d|NFqDnX-eK$VB1K5mC(=hsJ5PeHtj~`&24`2(MPY&R7mKFO@4m;a-mJr z(m$BUWL2Wk#NtEni4lpLdjH*aS|dR1^yk0dHYY(D%PGrsg*XW#c~33cQI#|B^`Vw7G0v^6sFyga|g~Je;?9(B5C;ZGOV@ zpo*L16wx;ar{DEbHBW?*X0>*^@A97;RP!nJg%At~E4#V2x1Q06O-TKRN+WNLlorwWBWGE2jI zK)MYP^?!4IPYf+k{JBxP)8kHPk_7isc+(P9kF`WMoxG1;;=E2@e`ppzwC&Mq^+e%||7yEzeb5qN<3%A7CzQkYlUy5LziVmN)dtR`Tb?a5{)oa#3n#ubVnJbnnnbYk`{2xt7roKR};e*EgzLn4;=8RPK6eW{8ELk|spX z28CbP5Dyc7hW=f2UE;5>L+iyK?jA;&A&TFb?CT6Rh;m=U;I*$iiaHa;+8GpzXeOo} zmYxko7i}*cbTI~?^Bt~?71sg~j@tKw(SjTLH9nWtapx)eFfCFRd+dgiKXF*vsyd@M zHt!pk(jAdfZ58h=QXe!!eqd;x=ZBuzFEuXybVfT3<*_Mo(dfK?nT-2B*vGK_P@f_z^W06wWI9qk%B(c?@T{B z?kIt>9fNT{&IX8!-DsfG@88{|q z=Gsm+K=wiw$tr(6SUx)UNS?S76nUG^hKk}K@T3w>Pv{NAK2kW7`VI%^C%Mo>WE&8_ zT_>x;wZf{5hV>z8hR`hsDu&cIAXiin!p+FW(M;?2oQTzS{U+%$M-{ zmcOE)A?u5(WwS4AJ>9#{ksk+NZDQ@#xgsF;G~41DM=W>+tg?-*hJg!Vq+LgU1gwv_ zQu15-gBa^Bu7WrPSbo?{KTyK^U1`0)8$U~dkJ~M-lE?8-LB1~CB#{QU8>`mYZ4#i{ zFES(iTpWBP4U7O-_?*L;}x zjsmf^|D|!K_XoF^L$u~o0jT+lq;E{e8>^(Uzt~QRH}n$`rwB5p(7f|bM2qXVTQ+p<*ztdqJjHv z|H0w08|+e_yWPwfjU0ZD`-Zm}Awq56f8geZJPciVwzHqWl}#@ZW=#yZ4kx1K%~mwQ8zUhr7DHdPE7H7l=R zKZ-#n3`BJPPQFOGrn%tBLJV3UmeH!44?^<`ab2JEf>7K=O7a8yIMh9$%5^}Hh+IB! z4en5dp%=?3CtLAcO(FHBNnd5We_$_risSbp5%=XEn2u}J>+i1>5@qGzgMQd9^* zM;@{#pDZUL9joG%t-c`iSw9uWtdNDOyk|Pec>GY_+7?rnR}AvH#ZuK6kc`Z~pCCvO zN=5^jWoDXxeNl-Wx%!rlFA{#r(v)W&f;J!BD)X!JMR$^_g&SEzk;ApzzvTGO8#B`1 zE7il$$8EnCu8pBcBh}>I*UPc!p6?5ecu)NM+b;5@*yBXRy6F=lt(}Y<7tAdx|3;(V ze}m0dQe)5#3XJEKO+j;ndCRF8f#__&Rc%lHG&DPynv;fwpp0uCz4^Q;sE&cwovAhf z&A@!D$yNd)92Z;{zZrup_^i zMLnsS1$X8nQTpzqv;yT!<&0)=F?s1?*VdxFRBAA2v)A% z2|F3p2{yiuW*s=XfRDy^Nz$PU&YXJ6D{%wg&kNs}9`NjfSGM|gj+Pzx9DKs{P_ll2 z)@+vR-W?$ECP&39vK^Rg^-53TI^o;uQ!xU$b};ubxLxqO3$k}^8i_^p;#FxMM`juk zuzh%MC?DJf6A>Xqd&vkcJ|9>OJJk*;=dZ0^Z0NxEohoi=%=be(`GmtaF+9(kHiMU0 zaS(7r!@56a`{Aw6YCGrfd%y=racRq4AeJCxvMHSa5vHd$1W!f7<*Zg8;+bq%TsXz& zm7EOh^#0?+o_Oxiop;M`JyM}tOp}rC*DDyUX#FOCGamW{wxkcs(n0wChZ|j6DX=^< z@KDJo1CD5hdK;7Lo$}O7=->A4o~0E;&c)e@KCd9MkWFu zIprG{X8byrv61)VhfH|dFVel>l>#&g!ilM?IUs2DncqAr2KMh03;6|SL*<)FtzGvx zNNV>qS=mj2!}aw)4U7puWx-o~>1hGfGrhQdf%6qSDwSR!cgTe$satEC>sg>9@O_8U zqX?A7{BqLjq0T3VAMsf^^V*rlTZJAoCJ?FclPsc*^2N z)V^CGpVoV9yyWq4S>jjU)8|S+{BxnC^Oro59_jkYIW2}_BQEN{6wUx~xpAHKxpd_I z$z3!qC;=v(J%7#P5RFLVKAp*3$^cIfN{er9v55BT#W;q<2;eyEJWS;9Lv3p+o+cK4 zU=$wR%>Ke2$S$cy-s!gj(yD(YMqhP-M$`6D+v^xq`FAE0`{jg$pP8oQ+6SXyDV`pc zJ`40&^@h9!jRCrpfK=b%Y|uz}M~%jnTxjdAPdZ7Sja-(!=dQnYfU$z+P>yzX7`Od= zwz)J8`B(>M3EYfDTTa&1rk7(->OoS{z`ZQgY$upVM;C_{KPQa%v*x1iN3)M=*rSjk zs(Cm{>CrYT zSFJz~Rj)8lG2p-dNt#IiRTc_Np&eM;j6jdJ-rkmC!#@u$DHl_;;CbcCnPsQ(?|&2S zn0Ec@i$*8=MI&z9D?+0N^S?ufb5Q4*&>zG`G3czEFQ-is z>hJ&j{qpxxWL3E>>?IeA-VmD={XJWWb{D-*uBAnzkRJ23SiusM{8#UpwtNzz-8&aC zz+Q-gh4KZDh0@TqQ+<;ELh?|tP*+AO+B-h{J)eb=)fr zDcpRtJ%oAG$mxNO~(f_Gp}@NwX`?GQBleDCygbr?dN zNu!2FdqLb48N4MJfrJ8K{l>a35LL^ZC8F(v`R~b+N1TK3&bz?$1kFcy*fr{=UDgMI z13j*4NrNCT)yib&*9WZo-44S`@8S6qUwSi#cd*D;9(vz(7;5FN=N-K2hQ}rk)w$C@ zLF;;v2K)6v_%^50a;0zp6zlyA{X_>q)+>`*re+G#MIQFc|N8_#?m9dbIGzBvyX-vy zZuowKx&H1F%V+q-)(}5X{vN)U$)35SH4aXFLeB49N8w!J+(J3`Gz>WY8nHc?fZuSxE3a#P783dJp_b0~+Hx5@a_muSlE{KgHFlBH35D=a z$|E|-7T?dVk)%2~{|W;2X~RoyWka$T>p}Wq33MJ5JWXWJ0>!(R2i}F`!TrqUqrMYa zu<)?$r=xT^@bL}Z9Forku5|IUzN`6=WcEsomOTY-j^7r|!1G3#XOsjyzU6^G-^ zvRCl;x30#4VixRPcQqjl#pjs>TjhV0l|zx*Srl20_l_}Ei4fwC`?biISbeHGI4(<@ z)RN7ETU)Dls%0yoDmQ!HzoG<=IAl)j;{983j--Rjr>o&CVey2hZZ#x-2~8|iEry)> zUD0ucOo-X;JjYp;4BO?^g|bg`5Y0XwEnXUqh}YbL#_+jw6>+I`#bFOvUXHpZEfR{7 za?YhsRXsq@-5KwUrRTzfA6G_4HN!#7@h&y(d={dJR53BQ?}tvid>o81&_f(j=XiP9zCT_kB`jCv&ugN-9xj7;J=UGpk2s1&g0Vm%yst2{_O~0^eB_T## z*LKA~UO3MkAs*^b2{*WR>pK)Gky*sbe~BX{aM-=No)Dgc9J&VuE3ER7jL&)6wdG1w z(#WgcyjYB4HJG*aql!>%)vHHQL5ZkPUpjXpFa=qTv0T^r7=!}FubZM@S?Doq?E2Ev zEVP_2Hp(85i^66*q!e?Lkf`ja&OfFcH0Bd7!8MnUK1R)*Y4oo^f19=UL-zxb1u7@< z-AX~v_@`Diw(Ahj6=~*Wiq}ZCQ?S~VI0aSb7`I8AB%?m#OhzTaQk4CeB1^iV8WC=2 z1x*R&qx=ueW#bdYC{U5C)7Ux{Z5ocxZ1-m)eR)=usH#}xH77>y`=kJg9QqGGJW+?j z3(s+io~%N~8O5fexHss(q_@7q`1~?QYpbbGbOmyCy;0R$pMxrlHmN^Q*P!AZ%5zr?;m`XvxZ_2{ zuwNreVei1N`)#Q@aXBdS1_iqTdn=-)51J*sRf;aA>czY*Y(!=}ULs!jJlx~;k=DSb zDm1KY#}-3bh=O#D2*1fp!e3TJx@S(~@Tk9uD}du8G|32r^h=Dub!VqP8U*tI%MZ`Z zb&Nv%5Is|P*=M-8E7c9H??7wI+dC+50{*cQ)r@@|12)1OCWZP@5VNXY%jOt`pr@1? ztbdk(M38|Y`~c5uylTrY_hTMN-VEi`$j`&PnD=6o7v8H}BK?xCX%?6QUjLqGU50hu z(6fx<>);y`LU(z89wtVk>=<;XA!5V(TBq_Hr0=|Iix2q(@7CXxKlfe&yT?%%BqQd4 zR;JYS+R(cDlv8lES0&tHaSr}R(Rqhc{r+J*E6OT+ zk7Pz9GLrX$=v%T{iiS~XC@U)zrHrB?E6Lv3dp;j~WN(q3NH!tscYc4K>pFj&>s+7n zocD9T@B4MfS&W-y{TPS7LCT#Lnk-m||9xaIEgcFyZe}m*CO|=tW8&fLMEH=oDPUJY z;$0hEVi{3Ng1=Ix={g*w`}ASkM}g!~Kxeiuv)Mf#R^Hq{&`I_c1WFYCjJTvj^Tl&| zPwA83WqFgD9cdoceDLseV`DDVJ&bAzJ6Zsjs6#HFLHY2U%OUtBOC@lHcpv*Pkq0W> zs^e+Ls{yY+i5{n~gmdo~?(j5JkaWz-E>r7l$e!bGCnw7VHd(j29F7$D?QNT=<5B_* z`?4o*b?1UFJ>!21UkDh;jat|)%K^XtD1Ob!ltaXql9Pe^vH)ei_K#7hg2-AA-P)cK zm~^@I*zH_8y!CcDCl!-~3ks7qQ!2wrd3F~RK=RKvTit1ri3tUF%GOWKq=#H67}P8fSBJ(X638RL2mcBC6`tkfk8vs*h&=ELYt8NTqd)G9C8|0+2D~5Q$kfa3 zPIVWt#ec4sbknn;K9);?H8vY3z8V}RQ+kFAEl%4$Vm^#Rrf>3n5X%Glc3J8sy)5Wj z5LLBzh{d7HjqTl8VYp}ZBD$yl399l265M(mVWZi?z2|xoz9#ErSuSLa+b+Cz*4HV7 zVP1v<|MWk?ku94|bCz7(Dy8FWN8^i+M98%5EwO<&ih1o-k2LT`a@gZ?^-${&;!Fhem;~0&Ci+rzmZN<5pe6 z$sqnhJpc9=aq43LF4FF}-XvdyuL}#RDIJT(G_%QR0dDp9W(#kTXIBzF?prs1<4iu* z*z5B?xhfBDbo-B&lI9;#$)+u7fgJo`Uo~UOayDL0-WsH_Y`~EXHfK1Z^RPUfoX$3L zF}9IYwp0xJjMe7XJ(a5x@nx68hb%iH@VmS4obP=$cFC2$_Gusu=N+Nx58=weHfOdD z(3m9Q*57K%B19&pS>IjBS%|`0_wI>bdRL8q{JehtihLn9Hjq+b@5;k7y;Y-|1ZiGv zk!?)9k%%*k{gtkGWn-(maWA-sa`2=?7<>O+QqO~;FB0%g#QX0q;omQ_aJo1#V>OV6 zk#SJqY+eF>YaY~hZf_=zBBUa?&2n(js`(ScD`hykNl;xznDqVV751gN6=IItHq3lC z8}YI@LI2-{Oia6Lw=YDc4u^-FY~Ayrgye5Gv3sgef-h<8>3Uk6j9G{8x@>>O*s=1C zP5$q%I7)~YH;C2Z6R}Rm8C45#S7<+{oyH%ERLC%kdty9)xw_I zeLrFT26r?s)f~KZm$iYA5r&(0Or&$CpdQ}~ zmpMXuKau$<&-o8LfA{r8kn=QX-uR@>D=`JCseXqJrwxMDEPKO)+k>F~m2x)Z*$Uiq z;0xWn_Zw|1d;lNE3!w-Dbz+JL= zw<45)NEMUxB8O_Y9%C_4-c=2|<5OyijJ43^t~nSogMoHqc+0`N60-d?Zbw*G!XZQ3 zSyCJcR#F(!>ch)n$?^)ey5s-&oLp&jnX8MW>PXF&Q?pS%2pCa9ze z)owS)1hY2^)T6<5@cVqDqy)*gNynj?YP07%MEO0PjT0`1t#mnCgSjg>rGP!+1LIj> zxXBRbo>&A~5$*c&Drp$JKl8}(M}Yn5rl5?=QTQMC`RCGNIdE!tB)3i}02GdNtBN(3 z;~&f{9&uMb;^FvZmafPMXyO(Nnpu{C!9DK=+erWC{bghi4X5;hqVSxHwFXJo2>Oty zu~CT&%oB`aX9zG>hD|j=n|MSjed3A#uC=0QL0{;FJ9U5WtMPC#WQ)Y?|YN{wOzBqGpgnU zspqACG(?Rw54K7^4=VYJU)QtU;IexI`X}pM$Hb~}UPzAOQ}>V9CxkcHZmj~R7qRW~ z_`b(+%{gxK#syfj`C^RsL2nX|+)lH#p#d0)YY$);#qf1<7YhS*oXwJyTAG# zle)D7w*K^CgYDSA4dbzx$t~=6)Z0pIke~Ien8_dObXlyf_P67J0-e%z4vgcN;@%d> z4B_Lcw)bwoh{1NZ9P9h7OYz8=BEFa|(s}uiyIilB!0Nr-vX@WiW2;~Hw)ckT;60lg@sYkt=S+5<3ipa&rMDq)+NbSvBAeHyL^}^K$I4 zqg2-zP70i6NSB^&B=8Hu;hvsg19o?oT7OQ|Vd+(LC_|$fKRVkOEPbN{?>}iOlJ8T4 zJ(;9qZG!9ZzAnG3&-}|UH$|S)`??aW`1I#cw}>f(P;4r6-7Choito-jD->gY!;waN zihS%F<0rS0mxD_KMBS*Gig5Jhd9B+=%Q4+=ot_=}RyeWzJ1+Wq5 z`m=1m50TklcWh&62fjmY4biWtQFXkM!R14XP_mePW}Tk~IbMyx>91NqP3Pup;*Un) zOFSo@`aZaNMn_sh@2J8mXW46Y5P6u~^|`Pty)w6jaUn z<|IzUpZk4--)lhoyXfM%n=R1V-&2va=nqaG&UQ*$eS?=ZIF!q_2O^>~K0;I*^aZvK z(*_lS-}|N+LF*bgptOgwy5uz}a+2h+Q&2ETsiK6;06bkfQff|DaMcmVWxxgN7^{GTs%VX(|uA zdO<2#rJ@{;=}NydS+0jb%{RRR6@@tUDqUjIv09v8dTMJlAq8INX#s_-Eesr$|6?f~ zgH1lXeo1ZQg@-EAI4FI(pk`37IL56{jWPbZ2sz#~wXcjo=Z{+1m{lcg}W5u=QZ_)C*1dTVnWPv-Dy;{TF;7 zV3>N2!bTDUa?#G#n`C%5T{6M2i|_~{oje3<~V}4RDRE942a+7A4)eO z%`>HD4?=A1p>(%={~ez;EcBT{gR;C4Ge&1CRFU+XkWb&LDJGinqX(khb8BgMuc4~U zeaB&ZTuEX-&W*&BstTQg=HGGMKCb(>7rx-_(l>>UwS`!zFy!@rAEWV|@ADhpe66Ic zLDG`9WiCEH`bJ?Zr3tGqJo)kj;hWx z68z^D*#>Nh6-f^oM>1Q}{>Tx&T^LJ@) z5cXhM+nU-L|c1)xC^V{H`3fyUREbp9sEw;#5MI@KIg504j8zl9K+!vn_a+#9o$ewgp#g5+)i_)^_iW+;{D{}=LqE<`3-9zZvh6@BkKU_zneCS-Y0WQeKz?4kWS z;wXPbT9DuA2Wa@P5e9LrNTW?R`E|wuiT84UAGM4iGAwZk6RBT@H?AByHUuT2JeF%y zcXI(;hn|m8SMZ`Ix639uezBlxzeYu&uEWSKsA5GSolb1GYlqF z)orbJL+i_z+|OgGz<}qvWh_k-9Og2W>X;z$AVV1V)s|WywJ>*SJiihY(sEoohV$VD zd+?)qmvMOOa)fOtr4{8w$5F1an zx&NaLNBn)VO(UHRp|9V>y0(tu%{Q@HSv?=%PFAIS@T)*v%v(GdtKS7E_UgLKiL3bJ zn5sgdU?Jvva&52f{%3F~>43eSeK$VhI^S#f@eO#>7R()gTmtdeKYr#&jD)K-yAtLd zH0UOkjv?n08iGy7{cY-fZ}@ScXJCb@3Mb6JdS&Al3J0Vf#YA7-fSpX!H@9bUvBi>z z-n*u4Os>gQ&P7^&*gNYDx5{*q@?9jxh(kL$QpLCtaKXF24|DUR$m+;x{hPZ}Z0(Kpg9D6>{ zfQs-P;*{i!PGzo8Jka;!@R=<~7}&27#S!%z&pZzK^ER>xKks;@x@And2NumS zY4YEJnUIc^6CTUB_)TJntXvCbKkpNJJzx~;#^$hR=qAGxNprIJ`xpci76LzT*1+cJ z;mg*f`&3lby{QW^TiEy8*4)gaB)GNP&bhd_g`czkom~&AhTIUVTbX2ZM0}^1%8SxC zP_JMVG@%*9WOFIW-wh&Q!hG{ncF`LCe3JL<7v^y~ zvThleljgCDnkkiMM_?h-@9&kr?bte+bENXlBtE`GCuDl5AG19+=c}h4#r!G_exJEE z@TKXQCFy}Dkh5QjT|=b_pZuXMA*B5YZY%rTN>3oMA}X5F$!;`YVJE%T0oojRas6h_ zL-tyH+WwW&gkc9}XRzE?VDTHLr)WMA(EWv93;EOLK4w75=f@Abo)AK(w~y>I@al&I zQ_r-0FGZ2(i3olkx=P?@FHotiXGP>91)&$hS<&{fW8?f+IgpJ;Yuyn}3bflKu=tdT z3h_CVA1$e(L+A3ZFnQ4%Ar8PA1}XKE@UTa&BlnnvOT?9?e!ljcWAK7 z|3iU1N}Y_T#EsC>qPgX2oHE)Du<*OJDThw=b3Kp=S3>9hwvX9hd6dA%XwSO9h4QSA zDGS^XMbviBIzkiPeK!Som@7igAd_z?BM+X;cgn#KJfZ5lx4{$dg4nIch5 zJr|PbxwH4%sTJ7RnffnQWF4Nh>@J9mcSF{Z%bYEv;>e{T|HJL(HkjJ#?K!U^honOV zI&)_QkdUxw@?+t-EzL|tTt_mT=_H+5la`gvo;?Wmnss8+TkCM_ zh9q-(f|b<=t#Ft%STAW*pku!f4(%hjQZc9^^$SL^-MV8$vK~@3-kF zxQd_Q-J;sXRHDaqt>?)I_ek1*DUV+OYrKjpMPxs4df$#xOHqUsy&Tp>sT3?Zc~(-px7K zT-eG-4AcL}%4dkiM{K4hg!I<%`$?5kic10TcG=}V@AJLLRnk#JE{hkrTUxJd?+6eo zSud4!u_Su)Iwo!4&`E-;v)6gSVj6sY1~7=xP!Y+)@vnAumO$@N*vF8KeZU$sZfDEXlWJ>!EhQXicEAX8)x_6yhBym7G#)O*aiYSMRr2phQbTdOj}#?dQpS=uY1 z=syozcH_gu%P_L1-1V_==h)TR7ET!=>Yhv7)c7t$zI*i6p_mbEFt%R~*`_DBf;)~G z(^3*9KcxdoqxPVC5r=}h>{*att<+_~d&~Ht*EO@e>whszg|n9UTr+MpEbm;Bjt19> zdlKo+!bD}B77J(M1n|4v8p;bO#0nmor&>sQ3g-hC?R1${{MuJUmtlK~v=2B+cRwrw z+D>~8m{9s1_$V$hEdBrIm@igkmqmFa8G(>c(z)}iDT*MV;x|H-2D zuLm1XdDukjlmVx!MuC>t2}0YoC&xS_2gt`a(4eLiajjqU!F!oG%jp%S*NIc_p3xhivnhMVO8+S$isMgC zghY=Jy%}Pw!L{l7$FEv4{}L7kaSic=-WhVLwtedzuCv3w*h#aqtZB z<4Z7P8{RjO)U6dLIARk0G*`MW5D`%Cncn;H6oZd_7kx`-qX4p-;3 zB@rKTR2vJUB8j%*0<#7>NmMLyhpjD>39;SWf9X7kA>BjbBT+wD&`YuL#nqd7L`VMH zz248vi6xDMYku5IkU45b5X`28!o>zp%>h2t5_c$K;>SKhhr4}CXKEX~=U9#Jop?fU z8lSm(sAU3FNB1c*@gE{)JWtdxr*1>FU)Z6+E(KHqvMR)M|g*^B7@%e;%D-NuB<&X=`y zsyeLkg?>CzM2^rC_7Urm-2~6%6W6<$ucGeuH|xCoRoE@Lz9diAhKOhT%DGQ(0SjL} zyYKzXS;8pxBzq`-58TSU!NMna42?}xdTrV4MKv{R-q%Ee5iQf1Uvo$GtvOny-NP3^+WAaY5o#&-CZR za%{wFav8ZR8j9%3(VP22YsT=QSY*H_8jZEBr&pchZ=yKid>PYCdqSV#0Q;|UF=Bq* z=SV`*09O2-_RGU+50T6>InJH43$M>!OECLsfXu(}qYN5zL^*WfFKGY7>eBIxu||@} zKJ5IcA@2$p`_7VwwrLSNHZ>G4=^DUWOgxn1u>oRwuoO|=vIy*wc_EvhR^gcU9$z}{ zF0e`%OE_rGfoxyhqm;TPO(a&T<)vt3pag~&!UJ36$RcHiPm<3H4gbES-*a&ijJ1CI z%oSWCoVO$nOp^9k3Nb}f<5uFx)owb|34@1^uO5EE zia0k}>Lm=0JFyA?P3A`boq*Rk^l zHZ}|q%JY2L6+S|`N9~E{_+p1nHeGl$m&Hsl*!vTZcx}2FWkaJ(kTMfigOJvYYv~DAmJLY=D0p zx3?eZtC$u+>#`EcLaZl|61nwue*O_O8P3>Q7bQ$QGrHCPLGd&(>Xf^FZsIWVdB|53 z*&|LYnsgWsUa>{HPUj|me|v(8MAQ!c?UF%lJ()XRSC}g7vTT$8^Sp=BA5&a7b#e?9 z*SJ=$bef@)i{@sr+24_J`*X)5r58{@dxTQ>vIFY+X2i0;M<4Nz@pL?4%tN~3?+q40 zralzl6$)`5`HjgM`c1 z=D~MEa|HQ~qQmXRnyCM_kEpv_8FKwPVkec4P|Gb5g$;>ZL{9lqvi7zVGF_Yg>i;eZ zv6j7c__i*N&X!5|Sg}Wc6^*Z7igUT~ma`iu6qov5OeF2L~gm$iyyV2S_ zG_Tu#|Lz)(0?a7YzfJ|A6a0TNY-a#HF{jlwPEb9(!2Z`Uvw}FiMPn#4T}W49^6! z&9iHSjmM#!y{AhfNzo9MAnBf<8)F{YV-iR$OJTw-vo5hWz+)M8@-p z^TrMj9&eE5l#=>$@|2@!98rgGG76yb`ezLOKDp@J>9?lj<6J0lVfsmvP#&s2zjq0n ziV-ej0w;$a1R(D72OQB$5hBR+`Tm_B_C))C?;Z7+jL~;BQEIZsw+U_ghr3jnJ%o4b zmgjOt8^LZ_(7ZnDNLZEaW1(#-0#t*yOjxA z8Vgj7vl&1w{&$#MC>P8XKCv0u7sG3xyx-Q0`OvSp{XyV<2h<`Hwt;mz@U zpg-O^8=7AV+D<<55r(z!X4Os%w2EPVMDq~a-F7gvcxK@#TL~qj4R7zbRzOVrtPlfD zCmg=&oBr6n7WyxEa9ta1hgpA5OVzf1D9AMA|83F>&%P69_r?x@PF1H(wtXXa&wIkpRb5H#_dalc zYigACjUROHzxFYg{S7p!)jjJnhy&txYy6}Cyr42vVbAEMA8?#un9zj}kX3m~=V4SR z{IjNM=lJOlR^nU%oiAd*)hwO=@k|KFCf{0~ND2b&UtHJrKS_jD9o4%nQlVhxUOAW0 z90zf&Zj0A%q`-@TVg>03$)G0J>OW25saCxfPnV94gshma)p2%VKxTW;Sy&_)7U_Qz zl#O9fzDmKrw3Y|VmsozT9ZLc>niPHWm>lRbdQT*1WkPxIZOcX4udu;rJu8`X8VHd~ z3;$--@Y8YKuPO7wBz^aCbTTJ7?qb$VIH|7;^7ZNBMW@ezC3~6oe7yktdLC`r_52(z zoI20_yZtoDe{_u@#aS7`T1qdNGRorXiDf;6{C{v(N*bL@1Ymc-FUV&f_9-9Bo zir^`yh6^s|H&mJIQajNtW1QBSVq?CKZNmXobYPEAjs|4KAa=A9X>2UYT&v$>LR!-3VlUTmUsIZ9(=qd zB~LDk4T2h?*$VXF(n^S2r=%i89(7?VG`WvGxoOl73Tfl&(l2wOHBYf)djTEIhX*kJ z$ib*4>K5#k5_-ojW(Eh;Iy4+;?%|Nf{r61O@8jYM1;5Sj&v3P<7Mme>;E0y}K>{@P zn2GB??ipp_6ZR5{U7j5PK9%zWI8s!QmvFs9)_3fHMyddLa}y8{~gEp zB>Xnjb@M3>!v>N3S`<$*@hOQ{wM9vJSa5uqT09{aU*<|Euw>4~PcKJ$R4m5g1KEd2 zVW}|ucxL*$7s+>VGQ{hvk4_l2SGy4~lu(ExE?(vdJe!8KujHPI{9cZwc$e%Hr*iPq z^{?DT;aT`W@tIhY#Ytd&IqjoDI&WT(uRrH!?gp|w`=gQqyP%Pug)@NqC#=aXbcEB5 zfH1YJ@CQbC1xNV_SGfG=tdlG9HKsQ7t~YJsU5Dw7=4 zyLL$Z$g6yN4KfEnIQ)Y!BWo3Kxv-AsU+x1cn-SyAON|gf<&;+behB97(oj^}-2uJv z8B>O1gYchgb+g%24|J~w3|-RifE-SV!vduJU-F0R^xoB4aO{&iSoxUa)d@G*Ko@Fw zdYUFv`RGMhyQJazEWisYrv9>retZh*g4Mgm^KWp>nyKIm!Dz^F_lx}&9tv~GfwE>* zN|@gM>R6()4Zb^1_TVVrS8(8|zw7kg5yGc9(l;vs1j1hYu(ExM4{aaWUfuZuMN=vi zqbpIk=AW$f8I5pk@mjcd$I=_W-_OoseJ2VZ3K=pEOA3Tg$^r_up%`dpu0Ne9U5p2M z9S24Zl6-glc`(0uA z@8R4pkB!8qz3{MA&!z1`BSzaYk;(=hcpzE$dHL#Vd`mCp@#QjiNLZdYE#u$`${nA# zX+|CJk;F?>4=*_5F|&JD)cc&^hY-8#`Ce~$%WQK#@81XfweKuuYD$8t!-)!flW|}b zAItsfcN`ef6<^$9HGq!`HS|TVGx7Bww4uY>0U&jjTQP~`FZXr+E!lK4h4h+8%J@n0 zon{%i|G5$f@9VxaIxj{+&8yLYp=Tj5D17Svn&TUoY<%*(LO^2!j>(H{@ukcro92Z-w;i2$Hx*My|Oyl zj;D5eyf4>~KHv3v&-lznoX1K_HMge(fB5mprK(*@IpY?NQ97)5v(jup5_ep6LCN zO@q#I^55MRIfypnp4I2ov7m{!%ucVlH(=)CoQyA%Fxre(5oa&mgzw)UcZx(xqGyW| zzm!baP;xj|z{o2R^!sW5_>&L@H2?T-3~xCf^7a{sP$hAodTy_Ku9%1+BBLP3ae^PE zX6j5U9zBZaa|NTVw`9=$dAGmgn*zwQ!fy14n-bcJ|NXRhY!6C5tzX>5C66dF9rf}X zdf>cLU7AuUFPgvb``vr?Whlk8i+aHaP<(;HvwoUCKvw=rx3o_ddDi>etF6z&VIz*A zFRw_wxSW~67apq19(sI0R{Fvl>ienjz?+n4qx|Gz~XXEfUCFw%-*(Mxl`7Desihv`W-})MTYT;C<;2Dqg zzn~JuBCp@jh1V5%=oqeTV|LbQLWFCCv_F4fY7z7u@381gdB6S%{EbU$pM*%yuOCmi z?#>EK_iSzIw*G);_iO&0swVXTS*`hdM#sU;6#&D5CfuYdTUs!cF`=8RCmr!xw?O?}UDzq5DA$ZAR3g{Ru z=&VH!AU}t}Pv*y0U_#$pdF^xw2)sP+uV3E}84*+dk^zfABj)Tezr6w1#AI0I50LsU z`1IX}9+IdsUb^k)$8zwRR!zZ|^4OY(Gm9dMe-KEHQ~!lYW6>kX^4~! zmb3!RNsL?)hs-}y6U&9@ixR~YZk_xZ(`iUfY`t#&6K=bLr|%ETPG3Gqgh^3+9X!8< zdyT(+=bNM@Zgul7h1xR`fxdMclL0$8a4LzNgWpJf z_cEK#Vfz^65YNZgRWomx(5=oK(>HC#=4r$xrK&X2nx#N9UizKUWSL3 zPd+4~t1s5oz6hie;{r^gt`qx-4mtl$BKtFOcw6BSSN?T$*S~sSwbFlROXI5D_OS@G zg!jHyT?|3PnGuN_+J+=vjHRbwfC1`qE<5Ka9E03yJA)H#(U6*3w5TMh0dh@+aQ^>Y*LST zloI8?c6nrdv0E(e^$8>!eON1>#RF~14xO-&4o8`$3t!LIvms6o-WODxIcVkM+pv4+ z96@rLyF7OGA~ucka+Q5N(IeWo|KyL}BdEnYG(r~3(O0qWPrgh<6RbsUU(Mp{Q3rXh zn-Ez)F%i5P@Tsr|iA4SEHJ@EV{u)A6PnQ;;*l*J^`NG6>(g-2IP=OQIJn;U_((6p))THS6Eg7KCW#>*ddN zvZ$t$du8*i9?G1M=Gy7Z$7h1S^)X8Fpg6Y@xzp3+sAntXsjm$)@%7A9U*a)JB+q(A z?TnNZvHizI(Y0<3%=St>6zk(hW+&4eS7mDPpC1zKmjfh8y|a5xrP%8d>cR4BlxzAZ z;qI@U%rABBkdDH$ob68BI*oe9ISFb?U@Hb`(2OD?s*;YFY8A9 z5ScM*PCry=a^x`*V=S~UR@{KyQl_tLML#jO5nJA9j1bY-U96SlH-o!5DuozL83?VW zzGKnzTqZTXcuFKQP72ohaXNDrV#| zLn&!XQ-{|#fwo4QQ}weD!Cc{zp~Pc=R?f~cTb(gP!Nv=%A4FLYA?T@n?i(-qFtk}G zsdxjK$!{MiX0k{0C%u<0=gh(N&=+J5KR=-TmsboooRbOTL6c)D^`8kbDf960!575J zNRB$UKRZ$7q?aWr8;?X(VyxE#i;$nix_jew0=e}`Xebp7A|6nQ7Np8ThdivC&U&|@ zuICy~yCmO0`t~h;>+8*!SxxobQCVT)%Yl)5LP9tH5!Bx@Ys6M2a+_Np^j+ zu0e(n(6jGvb-h679J;Gp*#DC7Pv<#hNaB}O-C@~{*0d&!tod?N&f21;n+m3f9!@~E zNq9qeG$%pZ>%XOb3X2p=U`RBc3g#NcubN7RB)|$l-Q=md%ktq!hU)id(;q;HZzEG<`Wnxao+#+bb-h zRwe+a=!clqs7dtrr%Mq?`X7DadPFIroZ>nBnrjz*YVf~1X;)8_*BE^%=w3tpHZ8s< z%SQ<1XA#Cbi46kA)0Y$nEUufhLJnzya>q|l6s0Z#s_yer-@&Wdi^Pt7YQ9MbF;}KdBh$6_vzGbc|=9V_2O;L6@tEcF5c99jPPB0 zw14g8Uy95ZYhhs9qJL1- zQ3H-0Poyb~~{W)|l@z zyxD9a67>D>$>7?tUH=J4^P@O>O{xuasOEUWi++H>_C6E!k$zC6 zpV!P#9sm-v%H-+LFp&TEIgLBF9}aQZ5EYX>AT#yt59RAAkZV!OdEVLsAK#8&pUUqA z_YacvXHv%@rB?CSeB&(m{LlPMe-g?e z6%RW1rpiOqW8wJGbbQJ#7H0Rpps46igap?Mh$cQ3B1c_AMc;mf+pVm&&nB}WQ+`z| zko10&;!wwZq3(`Y1^5|tofwU=+&s|uFn zjD8Gx6Cm9FjIBkW9Oh5W)ym-cx#Q_P$5o~q-l8R!j4`X6+^2DRT6Pwn&41>0x;X43OD z@es#H|I79_@u{S)OU>Dw@ch=7;+GP(P^;S-F7(70C*EvkeC(otE6avHYiwJB8Z!fR zS;T*s^6|h{SE?-@P}p9VerAE+)Trf&s#(MDN3UgDecj=lolj#TUjX>4Q15lbU-8X- zKFs&IP2pr$QhxWhhuEw})!oz85o}o`ub5;7!BNHd;*E4yoXBob^!;`Kt~LnKJ4N9Q z;`DK*zFV2F6+7pn+xP~H#GKxr+z^V7nSM-vq4*M9T^`QOEQG?-q(5WSaeZo9@88>PPcQ(FCG4EjQY}x&vpfZi~w1d+_GjE)Few1?Sqbldjwd z2DcKtIrAbOFKspK@CKtj1xu@i*1?Z52|FrfAV9`;TX&Ubq=5+W9CjyfI`v zyb=u#%C5J!<6_}sDzk5ol0DoQvfJvCB|V?y9F(Xg4}bO*)8hYOk1GS0^O9<^ao8Mt zg*mAQ+sTR2a8~vso<8<(MU(j>R2Ei_DLB2y^xC?8jr6}^e}VpJ9rXm9c3L|>+BFRU z1_yb0AN?fpM-CrL_nU){8MRr<;XmPY<(w{~>MYO%){@w<%dnU_(L{NX0_BR0K5DQY z0mkOJ1H+f7km}t->i@1#qs7~))1SYPBb&du3wK7>z~zqcnHA-2KoV7%+b$cBfA!jM zdFcjN4s1@{II{sax08EHv(})WQF}1{=Oh$Y?tj9}{}+z`pjz>#B;CJFXbUdr@FC_1 z@nn@&I`sLVL+f-C3!>X*lkqu3j*MbhxDOs-L(%G2yGpmX5Usc580$qQ)Kz0~sqR)H zoUeX6QJK$y%)^|9|I^_{i@|0RysE80dy}b6aIF#cMf1*>t+xR0q^^Y%Z!J_)v}cmr zbi%?Ju~K1+X1KkkFUBO-2^amzoNW#JfR~9iXXe5rKw$U9<6^~-_$_2LQ*#ES^g^ct z85cmg?sS0GuSrPT8c+39=!N`0_xUaikAMKd{*H=!6bkvSXkSSg0-bO9vNu^rA<=5} z(aP5$$jmu;bnkE#%)fIyLi=$57{tzz3Z#f3BxphZ|ygH2d>Sz|?Jmhehx)ZW&i7TONpqdEM1$`t}suCDi^= zGot{E&2uXK_B3OrnjrDYszAto@uy|qZCgn7uh_}h+W>x1;aTBAV>me^b>hxKG!B)_ zdF%f@6;j^}C;jIi2xGht`ol{~!E|+GoBVzZHaK)Utj{S6Uv_LGJM*Cg8Uu54@)$`y zms?jT8EBhuxx=T+8QM8mLeXn=ETkKDMzyH4B4**tK#H3oc{{GZR_^duc@%%xdu=nN z?K7^-@5yW+_3^Q0uo}w0AaO44CxxD)7RJX4tFX5Y$asg~}8S6#s> z?`JA;u)2zX^Z?24YV_w_K}a{&k0cKb;vIqVo7YFwXGXDjeDc2~hb{=Uay3j_{f!-I z9+?@F%|m3ME;;j6FN`&}+;>Rak=Rvk(>Z>O)l0e_IvQm|=j`dAyAe5X{mg&wRV~VK zilb(7l3OJ{SU4u#NZLE5zVj2lW}E~IZ!d*iIP)H#x>J67s-zsZzk2>&p7;i*uKtpm z6R5$Ca*xJWmueu1BSqjpF#@vpOf1oDB>+%fvb6P1#kFZVX7S-A&{CPt=SNo$Iqk`} z_b-&gqtIw;Hl1(4l1TMKFtQS7GSu5}Wmn?bOkb~v`WC!&%Aw?@P#HEau@>Y>YKNVN zPQf;gNx&x{GPo#F59gO>YcBHM#PnJp)MA-?0K6r7{Tvra9Jph1hb_9Wk)CvqhW;!3 zPt~#Wm=Q@2d^tk4+&c*(=_@&IK!(T^j{a2=U4q<(U#ZjY1yR!@W8v?Hdl0Yn`goFy zB9bxlE_{kcT7_*3X{WbJd9k!PtHj(Buz%%-cL@W*0D zO|68Hu%}^+((ALR`{1dK!1&`x-M1jmj&xss;XJfX@Q9+C#8-uKJhG_z>y7HQBb&f_ zhxL@29M`nze-=UDjfzX}7pmjdWb?zcCeE%u=l72e)Qfimcq z#8ax_GEU@qN$Q@P0?F5UA?u_o<9=k=Llxl0!G^N_Y`n5N-3$>*+qq6g`;ilMve|uZ z66fXfInf1uVf5t{nbzcgiI6@(d-y#kKU!#W$$vjt1CO@vd}h5Oh%&!#jZDmbhHLim zl%mbokWkj!tsR$AkhQoywJv=bB|4n&zBiyl<1b0)Zo_jC(H~<_ zJ|7Uk(en+@7itdftAB&1ywff)8&yI%MXIEjN zkLUB{R`&t>?0hNFCOaOVQCBY3y7U|Km^E)d^qz{bNNLL+ceuP!v+o1))dJislWb}b zM#q~5n*?1k{U!bdRkswH}M#2C)9P5a)nhXB2?XOdGc{l%TH zvDxep7FHT_Jkczy1t;9+$lu=dgX{>~fl2~jkX|LWVy-py9E$4###FQGN}jodM^E=l z9tpPqn_Dh&*wYj&XXj#(W;6vx2QQNn7Ip%)$F4gyK@9b)91SfzKtS2d%j#2dqqtSm zl!vn`1237F`g)t*kI_728ND`5_(En=% z9dzR(G}76aCOwPh-k61F+xy2AKjsD59Rk`4=sR{G!V23CTZnd!;Jzn1@`~*@f`6M= z!kBvrPNS}{k~x2|Ju3Xu7FJz&)j26XJ|zK2bTPa*C`-kkO%4@|rKka;!TR`CF7MLX zCZj%RZ363^dxEYhkI+Zu_*26lo)ER)!lTdIKF-EODX#DLcG zuAO(7Z@{KoYvb#UG~n^t8tuQk6J2Z=EsL|&rHo!7YWzN+N2w<`HEw$?NeR0t7b>A3 zO))OW9kH$!rwpYfSZ0mYf`7+6OHET9@{6rXHG@r{Z@p>4=zATQXcr<`c#*;5={k?a zM1G*3igRvYw_|aGNQ7#}#@;tip1Qb30GdQ;EDHli$lKUg=rRzAjNAFY=y0NdaGtSX zck3on8FEkm=otm%!ldzkC1XI#CGhSQeleH}2vKiO-Uv}QCU3Xf$3W=ph$7Y%43+(E zdkog_fN(_)HAg`cW(NeX|91_+Wyumf-)kZ;Neyxkk}ihNL~TcVGp;Xu-^KD(aX(nS zL{wf0twff&fz?Y&k`%?~caE#9NK$s(pYSx+nunf$AImXa7a+*$trB1SS3q@v9!V9s zAU#v^ZlC`keq;VZU1;Q92ot02aZO&rsi~@t^iCDT;Y(yJb@IR&(t0gN`%FtpoSy+4YU8?GLo3O>xqD9FgM09}_xD4B5U5YM!cwM&_?+Y(x0SfRMEI1@5^)Abi9BdwZZWo9g|OX+Rf7?fC5*A zShWX3QQxmQKI=1q5G+m*7x%vo+Z~H!-eg7s|J44Wg5_X1DNtyuw9OYd<&HxiSvp8g zpgVI;SRCDq^0SsCM8Z938{de-S7ATTYQeB58#4$JGSxkzh5{!F4R0mXKtHdy#gD4* znB^yqp!;+RTpM9zRh&$Nx;ZcYyqs{<6+M-l=$8%NXE|~0bwtV^zN_Og$4Hc4wO@uk zkIlerbzn&zb&2b}k^AIk@LlTc#bwR^{OaxuJqPlG8t&ha3{9=ddGQg#_<#Zx>Eo%J5t_k6bhFeoXuu01w z%-wt)$k}dO&;5~ca%BM!{zU6h{Ab~(dx2bi;2cEM7)f9}?aRgKSnQOkn3KJFI5R+pq2M2NtMY!q{^?^tC1rhtu9yz!ITMuZU`&6k=b2b7*gcz&WbMJGnM>p)U=ng>N z0=If)vX-&Lpp&$BW$7s6uUzEHmQ2)XkvgWJo(S_E&YIiA{LzC#0ly>8jmVVXLw@%& z31l2ptSpymfcRV^V#6Z``209P^rcG!%tg!mjOFWv-TJOI1*RjYUFu=<(Ie%s=0e8e z+Y@h5Ly!H(Ar=kvk_!%25;M6z|JUP_jlPJN5wJn=V;pQ!=vq6cTLnL6CNp^+wW2d3 KqZ{n|bKrkuOu?t5qE&WekQDJwbZaNp;$(6iThu4Asi@PG7@!^gwJ zBf#P6|4Ig&{J#PzZmo0w3x1qj;Kse-UjOrXggB7kZ~+H$9IoJS9fun@P~$*{10xQ% zaA3pX4i5Kl;KG3ihle=)&zk>p{bz9apEdt~=8QLS_s5Edr-!@A4jj+M@ebUL>*0(g zf-?}~S)85*4{s62y>Uj*#&K_U+!$wQ5n7!7Hck@b#yH-A2cf}=a9wAI6V_ie;+4tn`jZo zJ8(Sv8cxrQo6m`xM}gDh9Ep!}o*pGmkK@@m-hp$r9t&`M5Y>wfyEGpI-)6 zoBInErKJ$8r<%mHQ~^D&Ug(LcR73Y0xzA(K#vtn}s^8l18XiH}1+)0HYnn;A z;Pc+lLhOzyTnDG^eGnfK9N}XzYPMn6=%b|Dm4*s)EUu?gRzUi)Yqw zy{Q0h=_zqIt7QS9`8HQjb1t}U+AwRKiGxZe+Ci*AEF88Ot(maIL4tR=Iy*KB)NIL; z9@Rxa)PhXewR0KJKU;U^2xY;8S!~A;Qw*rAKe%ZdUku?fam?US1axy(oMnv5!1f^M z_7Zai@I*<8LxKT34H^9;NRGQt&0`033k?|7`^3c5qXk_i*FJyWHw2-8f6o?GEr3qA zb!5)W9U5<}iY=Qv!PJMJ>ofRH@GGyW$0^+fwv!G_XJ!51xP|q%PFF1S$=b;|IRwD* z-3}$@NLS$h9bz8B{f_2>!r-?gx5FjM2-tZtDQVxjY-JWMd zicVu>cWE@N%?K|t{EGq)N>Pf!{%Bz7nq0o477h`gvIx(g4TX+mj%kyK6qvH!Z|R#& z2mN8a+VaIn5N>=$IGA1lHvM(J2U7Vky1|6~_qPaYTbfuihKj*jbFcrD^Dj0fCfq-D zcLQsz$R}LDGmnjV=jLG&-H!RdS?8e|R*dcV6d7YO{uLt}a}wB5@Euz_UgfZIml+y@ zWer5;S2je8 zD;nk(m_VUm%D=?Mn{?^?9(Ey4`IvpQIs-`lB;FhrJ`% z>C5%EuHEd$WDx1D1w|ZVZHaSwTW!xkK+fl>QF^ymZT(7M8`5$0@{WKWS zX}pCr#siLsUvVHGB0}#;Ry{Q4_~Kh2KL)mv7Yk#61nrMrnX@vS$9`pNo_tv#0RJw| zY5dhV!G1`5xVYn?ho+*5)Lxp|gFoG6ThYhfh)mM0jh?Bd_nOl;A|LK6}#SxF@dJ#nUXF-A}$_F;>SPvEc z3qtL?m7%P5p)gZx6COJhheD5s8mCF?FxOSH^R-FN!dG2w%D(n#%-FVqr6l(LEQ3=}H&VZV2sS{@NQ5{>}e|VbAjO%N%@w z?n+muC7h8$+kW;ytQ#N+6(L8@4L_E=gQd{IUQeDHr5y^n?xTNrYKv~UMuZtCsiD)_ zmNUAPCdlynco3;m115+5jr3pBdQ9`ulhO&NatsBpu#tpu1&04e<7&sx z9E_LTbsL_$Js1i;$*p9OcNkalPv3^ayD&C0JDWc(vN03J^$y;LN7y#0l3NujC)nt{ zf*RP~#N?>!28nyOV=6-YbND8DF;f$oH);#dB9l;K9_I=N$kLr%Xl! z{K(+ZqB-G5A^0q7`a`_p3Mk03syX|sqRIcNmw)_KL+=vmJrA#9;LWQS|I|-a0ah`o z85G4BgUbuD&)%hC#%|aX)o==9xlTQ4uir?+Y7>$?%&m;W=Bh`rf0oF?Y6Rs!RHm-L zR4w_}hkcvCKAl)tpW>UvjOI;fM5_#8ehk|FaWXr=il?k!vxy}_ivcGt_ozEDN7RWu zzPUpfx0_OPnswcCdF+#PQ?UT#Fl*x z>+nur#(pr*G9 zSc{*pdvr*@W3#M>J^utPV3bbr{=CLt!MIzvj%QxsgU<)OT($g%*z|$5?dXsttkkwi z;{5hBc3rxhcz25iamjFoHE%pdPi{<{`J4YAdY3*Fy&fX~jWT~H{WZq z4NCWzw_+&aGC^`-!`ZJ`laoc1CV2^nPq#iv$p6BIsYjlbiY7(O3hx*z%xRGg&+>CG zJR(4gazkgHbHO-VHfu0d1Z1OSEjq6VC4#J*H}OrO!aybbv)DU~8L_1*dF?!QjW;v) z&UI(Zyg(T-b6PsKbzAor3HBZ4)a=XX?VxE)ug951->XYl3&W2@u(yI;H+wtqmn;^e zD)7Wn#&!j(E8kc}G)@U~yk+q;q}(t*EoHvfdxQxHT}eE>ObUCg9s=PnsE~bQN%P(7 zJfIfwYDduM0iyfMEqjCFDoS;I#3AvR0qLhGZ0}@T2gB~?l1FUY*xEBA`s$tckr+ei zP4l@UY=PFx_Aq}&)b)7d6I<#jW`!h#to_+TAQKi2=(1kNB$fuSX(`-;Ys<&a+H*Bf zU0p8kpQ}1xC5gTKk5~vD1(Ri4s6Pk(Zbrgc;$7?y@7uk?+Pm18l{){I%HOe6rwga= z27X{kyXSR_F0Nv+V`ypg+6fjft7~BB!+A7W*(vPix`&+;?pj9@2iQZl-^^nc_#kxE z)XVzgWq2{Xa~E+6fvIE=k;EhkQZAa-N_IcS^wTEWdutLy{Z-B@T?H6uBe|U?!J>

    Zo?LAzfjN5) zw%-qnAx5HI&AOlxg1Pfq+}Ga%!HDC=-CLD_UW{{~gL-f+3)-tYi<8V$LqT#4Q2bPb zSmaJIkg)Oct+UjDy|>un`N&F0(jORP*e-%IGF!PSZ)zdYx#-d2LM4>C*-NBdXoQ?t zrb8d`M)<9v+=IPQ3(iA^dvl3Zpn5^stE8z3Fi&jX)Uwrr%-zwX9q(qSv$!;oJK6+0 zHFVLuLe^?BZ5_DAU3GDAu7MWi1rn;HR!|XqZgQom9=u&7LPARGK+KUJ1Ve3NREMLzm|BwUo&u!TBeF}jWYi)4Fp#VNcQK+VGm4P$Y(pb*( zQjoo}K6$!c0yP2~wq*O&FhQognC?^!p)WoRbs5({HN#-3R6+p^JnNd_e^3R(%9d;N zZDo*@wfT~exBz$>?mbsyt^$X~&3hgJWne!o_xqDf4RoE?XU*%Xf$2Sofaak}=oI8l z_B}3#XA%M)6&tlc(98%<86zo-jb~sj@XCVbR>jXk~!&70yq{Pm$JP)G1 zcR%rEW&ul>7QvWs9%L8a9@Xf`1&_cB?T^EX;7Pa;$F1%{SlyopzFL|Ok-skO*|5Kb zB)#`*K@Z*nw`YdXH}?w24SYzpM}>=PwKrR}^4#h3-w!gdsNv)AbMD55ekgLrauKJaDzo-qGVugdHLu-TmHJ^y~ik zjmv|+h%|zJ%hAydDP@tQ1YCLpciyKBXg-#Or{`UFJIf7`w%QZRhXE;&rO@u0RGo-y zXwCNi%xXhm(mAx#VvI6q?)%>J_kag|6GYKtb||}P;+8eBCAysO$2iPQ3B6{vUVrOq zft)YS_~ETNA;%|v9MgYYLD-{_C2+|Py?N76@$`-W{FUY~!0ZYllWF1WELVeI=BFwR z=YBHcFO?n%sfz(#P79=(5{784uUTLo`@se&ZDRUC40;>79FY|l3c*qzp77(vqRy@T zM`iY*pyg#cp+%g8HV8I*wrP@~@J*yR$HgebDEX8?>vl3!yR=tM2qvOu@1%7tK-tYc6B4SZ{5}O45hYeeYb>65h zg>>V)d?d75e)>knAAElOepdGBHkbfQ{LK~y#J2g~K%{^LNnUsx$$I+; z>lNUV`xse5K*q)`59*;d@{lOTrzhDhorifnjwk}GRWZz!6qzAv=X#KjY zXpeHOFF0^d*@1lgL+6e}VN{5Dv06bR2LejUxr`E~kb}%;j|ZgTz2Ws+g34}4g8S%N z%!Sv;d#f)(e%uw^!G4aVN%cZU3k7D_GAD>i&yX%{WCe@Uo%=rs4A5WHcxsbkyhoTWbZ6>$p3G8pTy>C~Zh@9yGQk;`4w>G%l~&HSq-g7{2<^FwM8|YO1|}V`Y?0n@I&}Z{fg^kSQn^zFvWx$=3vm&XL&Kx478o5uU@;v zjI#Ns8P+84!$;>+TE*+)h-bLt^6U>zm?KW>I=8Hc7_GbhMGz^YBinAxnpft?B_Z8K z-{vKixFm_?Q-B}%@`JLBzOWkM z5##Lh68ylpR*J(IvSe*f;s$jQzsKL9+kX^5y^rAwyS@ct?kL7sol!(LM7o5;&l(_J zo7gLqzwANp+aAM+xdVKRu~H;dRzc*Ew1MX(oM0}l`>kn-H#Al~+tzpUg4+H-xB>@x3QJj!HE;BWQy( zyCnWr)|euyvZ2Pe`%Xx;>?&68pBV~Y@%U#m;tvBF0@PyKZ&3MCktj)xGa@vAKdrMN zKqr{tD1X5g=H`ypho=qD%^dPiO}wH|ag-<%Yaj>w+azB^CJexe=j(&;Z_i=%oZ}(q zXCp|_C(620C<`A7U0B8qtwCwp#qqaG*w$3lcg zJE2Tbvf}+rD}*dGzgAYmf~LHrINw?aoUc8avu;Fi-%z^bT0a&}tfO@DuV8`dsAv7e zybY?E=>mI2y20HiUoKe#0X4VGNdR3NC_cPYf+ybrUX@i2>=zs1?cw)c|MX6HPn+?i zjlKgO*|6vkv$R7Q@8jpb0j*$KTyfC0(F&sVqDyxan&875CSt?nPI!KZ;S8nggmMW= znd9%ha8ESr%q@lmw_K3(*cREZQCU^ z+dcpok|$EN1Iz{T@QS{NmKvsRYBOF7i{F?RqzY5(Lh*U3(XTt%qeO$5XkN1 zPL@{VjH{fUbf_nwkPDZCRoxzzR+RiOkWBbEjbe%`6UJp-~B1F zuS`VCQ+IY+B{Sh-)toK1E*aevew7?Pl?<))N~TjUGXB~F8s+MG>^DM?ea$TYI};IKe#z)>ZVdk-a&IK+7(n^sst7$lMc|XJ{CbTi z61moMA6fHeL3i?sKMBC|4~%Xu$$Wj7k-%-xV+R7(bd*ABQGFacSwpGlcI z&44bZg0jKD1av48{amgt2o$ysSX-6-Ko&!A(X2xg&06_R8oLLe3qqGkSH@i7E#9qY zl_nQ>l*H22-sg`p#Cm229)%z=&EKg#iQynJCTgDbAQ&zx#qD-S7@=RZyXhWhebAM8 z`@t{$5uo&i{#m2FJCNO1j?TE}ikNN7_NeE*(ev}qyf-u*pjdZ>Sm>5F6wsVW<3H2` zlkyQy$9@e+33Qd0b;<=+!q(|*-2{YHJJ33J9D_cZcf1g}6M^UmyN?H&y+PRvuaBxc z4E7!jQAj>?gg`{m`t?aH5C!snwyujn5dns8hmbQW3osA!9gRURHF#7`C0&rKUjp&9 zMmvxm99=4v^?_D7N3*)J1mO8pw4h1j1v}(*rT5AFkZYL%i(Y?qn}NiB z7gtNaN&=T{6()`FRMgQg#yAy}37!NO*f}_IP}sw8f}4lIAVHb1S4wOQBBbPtoCQi~ z^|?zqqp~B|PCNSMYlorce3Fk(o%}#j^5CX_zdl@&{yl2I;0?=n+X(Edw9z}gep%l0 z7D#8Pmgcv#JKA-R!|zEkMny(P$Z!d1aAK$OEh~8%c|e*c5!;37tarO ze+flGxt@_I{=7TFKe+$dANPLMM2 zF`FsW4c*dw9TuQr0#lJmA0OTGLbNw`B`nB&(9%Ud3yViSU=dlQ@h^c?xTYUq$mzK_%4Eq2fI^p}T&I_4&biE)0F|e7Yr*QjY4^>&1 zK_-27u;4S}^;LI7CGza|*Bl&?ucn=pN3j=V>PWULkr+dbU6K4Smm&B)V;esH%M0J6 zb0nlwG|^j%?xW8WcF6w=pwkzTYeHs-oo-R+CA%BC@ufIQ=dKCTyZI=D zw=x(mlgZO%O}>D0cj@w;ZiIr4A&+MI8+CYVf;rvPbpx??xqYswK5+P)u%`H>AH@Dk zSUu|!4hcHFe=_1U5R?C26Mum|%G+l9`1~c?_r^#=Yy*$?tucy!%1Su$+78);aDZE-A2LldzmnYRh2H)rqi{i6 z6-8Rw#EKffK|zC~w+T5s5%sNQaVYdciPqLR@KN8X|k48bN!#fVvQ!CVRZ0tft?E=c1e$xJy-ry@of2t|#i%yr1 zy4Hmqpr-Aqjz(V?8ZNp$PWvMeeRvdU@D5yn+%sr|5=9~o`ER`HEnW~y5oeJ`Zvf&J z=`UTM+knu1!{`Nk9dP@0ho5p!7kS!hF(1#EAa&+IyeAU&NX_$t$!R|eT%(R$!y~f= zd;uogsf`GjHT;xxBO@GjX4x`LWnhpdRyL91o;^6{m@=W#aOgFE$3ZOYhdR65_@#2S zk)N*Q=|wL$P*qp+i?{QJuBn8q>m&Z?YOkRVhRG04n#_AHjj}-O>EACp$=axmGHu&7 z+!dMc6yLk@+XQi%&!o4`X35*En|=4*X)5gmg$Nwa-R z&k*r!P$04&;(k@q7J{yX2k_&SxT0+WzCWL+!%*+{C}ABsUlh5(v*@H42z9Js#)knB zP*bBa^i?JXRHf3>ujz$=OU9$Q&2Jv?N$}EDo5^6n_FQKjedZ1i;{X$MD+qeO$-m=C zj)CT1+?JAJF_4k^Vm{C}1O0PT-$St{Zgef+ugMiA)4+Xzu{Wn;L;UPzFWk=8u zr0k>+JZ%_)+S$W*~Th4IYL@d^WtX)nRC2IBg+i z7=;-2cf3+}M!=x-UB!E=F?jXVzd7>u0E9_&Q<0b>P>E-ryNHXw4>-04Rm0!G^rr%? zI9z<+GIe4Ulhq3$2F_$k4sB4>rD~CKz8z{;|6`ZMbi+K+qp%2?ZqT_REZj+oz#_wU z&3CQ?wzvAbC^8Uin|vwB6={bstG3>sPun3#@DYFak8YrM8uwDh#or~N+2@T-df;pu z=`%s&cHp!ao~>AXhwGOh*j)4N1X1kS__qBI!18La3LDu6%O?z_1g}3pOXlo^acmdd zUmE?yxjqD1$;3b7`??^Cj~8(`Utxz^fW*`089#|7q_iHLGk9qm&xiu z_%GhIUHs8|nAIYCAJ^Le*3>CayPq_JCJorV%)#X;?B4xtZ|gvZj1XpuJ3(H06XZAF2ST3N#QvRF*!G>j z8Tz0bgf&Wef(^O=bE}bCy{`w1S?{y7yy=FO|2+RtbiW5P${SgO!W|Go+WLLAOTMMiB#8s#*E#e-$H_>Vrd4Q^KL#4KWSEoDc|w1Im1ZBPxv$vl z=n@R?D`I~UK>%_cS#)DLeuHGIKlxp8iGja6b9LoU{oz}^Iro|IaCC*E;+Is5Givk{ zaFVUbhJP#~C7o)y$hKYThR$>@l0)D90k9ozxvv75(cP*~S=;|z0h-)0k zj!l)xGDV?lx3Er^KgI!NmhGUNZ#WYEwD4bfS0W7BZ45;u#Ubt=OJ0-InQ$s@e3MZw z8g)||sg?ap2F|109`UtU^yowjn~F(>yCV!cUHefefXSYDs~`>7XD4iZ^5RgkG(IBg z34q7%f_VCag^&a}{eOvACS+SpfmDR;A@28$3(Cn^a9uw0(aXOnh{l!RWxit$I689J z^f0C(+UnuWv;Kv^!8B?^NuGv?=Q`hh^T~sAE!kY*s@dqE`}dpkv(cbD9{B5rcoY~P zo+`Zv3P6{}rB3#?f{|vKj3nHNhYzLMYM16yz&YRPFP~04)GZXxdz;08`eaTX>3^wc z$~4wz|85i#wpll((@jDK!)a2SzY@^N8!n?iNe)1;k1w1<;{s=@MES;oZIBbF<`bXQ zgBHKhLYvSem^^Rv!@4yI8cr1h6tt63bRcs<>dgeSQmWYdFgY7;Id+|^bw~zoZ*wVk zvrOdsySHjgED7D+(lF{TPXhOq7WGW|1SmF}Rk1x61AV##%*$>ez#;u8)q21k;nA@4 zWZv;YLk>bqd_RNGx2AT{t(*|#?td`m5ta&#R98}_zD5IGQMvV9<0K%yK+yapAsq7L zKl4p?2f#D@mBvfuvGDrK0Z%4R5YiB}C3!*_hTgM>w)5cP{Y7Kl`-(;3Xr_{_N=e8I zH0OQO8>gb6+MFU~SlSpMq|)+%vI|)5lldhfW7uqoQ{>^*L4%7YMKs~;h-T{3n;c?W zD7eM&>*A3XDyTjrRCs2CF58F|icW_?8pYzJGr_S)bXaa9ls6tVewobl(Tf9#e8JPF zK6b!RUOOqc7Y1Q%mYfRXuMim9J>EEUK#yx0S0k6zk#SuS+a*tX&Uc+1RcGarSn1Pu!d{7ZwE7oI+?nTSEHm(J=rM)*Os-lL7H7mSd^ z{cC%V&jq2^q2$LEyx#D0=R=G(KQ0f8BimLzDrLt)*L{GMOyl+$12X|u!0zkQ9ch+o359&zfrCwEe z!oTkDi0_G}Di%^5 z)qK%#uh(6{;{cT9e({`goHt^7c%e6cHv-7Muu)z^F3|5uAkwTF3wUAqG|hG~U@f!6 zu+y9j=;l3RR@`&kspln^AX5TVJ>bs0jmy(fOxWlD7~E066VY*}o--1kZz7wOibfC4 zqFm+Ie(1xYk_Y)jD0nbTkU>gJ7bjDA}LQG&}I7VXF)*8uKduH)nwLq_;&z5l7D5EQ9%2W;B z#lU6dxdWwZv1rRoCVll<4C0I1J}HQZ1)iGIJEt##U^MMgzBsimFld(?j{Y-72VK*R zLj4Yipuedm^jQ=f5qKoMBuPZK@DF#Xg@S?GH44eGMk9{Jfu4gncjQzPD(Y3@i#so` z;E{dgkLK$AJ?yt)fJ#kh%9Jt~EJpkE_`i69jmOq3**i=0%IvQmiKrd!+^BT>(|`(; zVO`T+#koOk@KYxa9v$?4oeiuM<$(M=EqBb$B}CeNJ8!Jlc@$aLEx^r9r+3u zM^Di*-3}e|0wWoLfoCGYFjYx%YrWJ0;_cb&2S0eiF8))m&joTw$Mlr;<*+(bQw@at z-M4|^8G4QhJRM|4;(7Q;UJ3pzS-#&qu}7IS_mI20EqXy7z8|vm8tr)wKdqHG#Bh1| z(KA2vMh;ib8hcVkq3+O=wr?jPC{>i4;Eqp{~`T0mo5rNMKb~u^fR3=W2Mm-Vgi| zwK?5)hhVa5=xh_yC@6M+o8F%rhPkEO;@cr(5G2nSb<^z=yzmN+H6|K_0{M{Gl7$iY z9cCh3&({x69Rg1SI!AzC)X8K2<_vVO2MA9n%!8}0>xUrTS@Ger?$C{c60=aP zL+%i?W&6xf5`Te|^=VGu=m8*nc|&S-?i1)ls@w}b{~m_%4V^UidZFX0wapi~zU_oN=)!xD(xH0s+NvKX zAAF1aHwMK71e5^^Q{Xa8c%I|KI7Ax`A*zls@EaQ=xp{K}<_K1bB}GT!!SS`3XCEfO z+b@iSWbq5o&sn*WstiHk@Z<=I#~?7-bf1dMjlyUY<;&c}0WhU}PSp@T1?#+Q>wYgL zVQr{M$ZUQF^bEN-JMu%1zFuta&_x8C%Ov`SLg+@;(B4T;h+0A zh7M@=3EtnA?gZ!Vz1Es@Js{8$Z0r=>0lW9AWS7-@pr)KtyC-xI&NWC>hbfGJ5mnl3 zqxcY9Sn(@M`#J#qbeAd@dWWFr>X74A-%qe(-lNgMkanZmb$B2T>8h^VV#sqq zFYkikj0(j-~Z(-ITw$~^R3KKrBmw~fbV*aOjL>4RWN z+DJ%MPG@_y91Onq<21EA-B7~(%iqn6e#nD9%jfK+Ah^cx;g{o&IGDTJ!mIeh7u^q< zz54mOJ-YdM;y!<#0hIP9kBprp)ML98_XEEXs2m*Y~pgK(_X3E>dD4f6`1_1ZqTTPpuWQ(K!TZjZ#sNe(i~i z(qayJ)yF#^nrwl%HjktzpN6BKcULIVaKFQ;Ewi7jCL@sDo`>moTwfSzXR{wCTP}LA zdlvJLz7Q&77;_!2R7Oh!T%vf)t4k;;)M3;v5ZWPd-Hjg(Z4s#AorknNtAaq{ylq!QFF$rN3HUcdU# zPca#cPCh3R-_q4Yb_#Dxnl5^S>Ej9wLR>s^MAf)7m=*_qb#8;-MM~iL@s&t%MmwbV zi=`-dCKyD>1bm9jf>0P^XdokDEDWddKbpeTL&;UzwMRa^LS8#z4Na{Hz&Nww_0o{gS&Y;t08^D;N<9UI$0RbXvZsX25TAH6;Z7!U6hHo9j`k?XA0T1r zi=U~)Y>}En#HE9_Bg|rOu>ao(VchuuX|av8&%M+GHweZUIQe=bnyi{ z?i|C527kbvP#;`Aij+TXm4w%X9+x=d1>ipCnCU4K1|FVNvsCDqfao$SgW;(SS|Gxh zYM5IiPMRH;s7@yoH-@hfL4*7MgXf8%;m;&Av^*4SN$!s}BU_u3(<6cF*KeQIpja?a z(IvdI7l}3)oT;^@ve1jWh4U@T@es*(>*~nMLipIDxHCwTg{DRgu^;TSQEY=&%T22^ zs9_RcEi4uWJ*<+J*)9VV?M3~vQMExu-PUwxxGa$&PiIr4FRrd=0ckWuf#{XhnDbu( zO_X~7iClb>J*pd*5WAidhkhzN(KxjZLDV<;WC;GcpsvxQCv}VpNU-+y&E_j%h|zB) z{oaKbluuS6?wFl`$P#iIlZMieTj<`kJGYaOjbN9*Z%QJf3SqD#6wU?Do^uvN{&|p? zCRE0Q4F=K{-rAKPN$BLi;jgyVuR(L}ko)tb9dh*W50AWN3@1)YV>4B*Xouypife5M zw2pWxcpe0x@zR0nIH@-f)5`tjc-0BSb~FPfaPfbl;`LQ-GJn9ZoIC2G^#;eo_bzXu zybyhW>tzQnJ@n`ny^x)_7jh*i>|oq61*84Wza#cG5Xr>Eq$Lvy^=^I7|NRI>mp^bw z-LvsP(v4*!nq+?PW_;os&E*iNt6aI_|1KKU563F!oDV{;1_rnCo?AjD)uA&j+jB_e z(}|7ecY&@`61)qA+Hhnv=j8R32okLhGpZ~dpux?}ykI&E`BP@f>H5V2G5gD0)sZZe z@twuLwJ;i%^BU)fo~NMmaYD(|mhp)D=IVrgdOWzZt4g_sC8ALlM}zQ@EGX7%9(J7w zKqs;W`U>}CAl`B@^}%;%5PR9Htu?&;`20z_U& zaZ-L74sRAZiJTUkAu!5EA}l-s$Uh2*6|Tg>N1{fpb!;YZ3Z1y<(dI!l@9I(gMlN!? zL^3k8nS&00jt~Cs;X#rix<1y;s;Ihgrz3R014;eMqXf&efE7mU z!CJ@!JXZMjJ}Gbt*H6l(X*Tc$lF2BeSL|27pj+ajy!IN9uT?eQpjd+BzyRX$_GMUJ zb#yEVS^&ObJ|jl!WtglW_ZXyG1}%f0s-BHicvitrZ1j5t;&&;ON9LD+An}9U6!!-F zejs+{%it3H9`f%=IR6cF z30z#3q_ z2To%R^avM8?-`wl_#sF-`exkWHJ+rr~UX} z50t6~6Kj%vf)>+@QB$s?pxt$2&uR?AF#i~zN{_r4A zclr#9cXXq>rN)3XHu596=>!O7sb%=^jle&0>T|yzPr#)I2eIF9`Aae1U5S+ADd2ri zH+N(^1p--WHW#MHAxYEX4DsL`OdN31%IJ&($xoBu#@rbw*!cU-?{EqR#BM!LYMO!+ z{HIzsdU5-aCR|z>*JsZ6ID~p@sTYWu3~A_2W`Qk-EHN6FzZm31S&PQ@gF`5%>8-8z z0DRwC8B(XAWV%X(+GHL^^4)Lh-I{?2Do>4Dl;gn4=O|A%r-43%q^xIt*Mx8+ohVwD z4M+PdytBP&Xsl{;`QOJp`0p#x&0*Feq|U;db*Yr z^j{{rm96TzjjP9Sn7U?(;OeM&=6Sx4d7@FvU=cotRT7dsq9M9;rV;q}9z{N#t3op` znj~DPuu#!M^7eN?6>=}vPCq4ShVOJ7wt@>yh#{gmvZSyE4&x^%8ceHE_*0G%G7UZ` z&vvs)^mm5gXwRAa(-^q*J8Gy{D;PF{Z=RFG^}R-tc43wIU6Gd_*Lv_~F7i3s%6q&K zjWo+!uCH1rA$w3SZ@y)RbkB)DtdkYn1H{8}fRiO{3X8PlgilJrG zx>)926{5-8C?9OChGyc|qv~gBQNjCY97dtwW4=%k zbuJ#{#d(T@J|v@hL+*ymqkL429SaqyEQfx7ht&|;d}wJFtJY=7Lv5C+ht%tZXbbb^ zj?9NZxMcE0u6Qj4f&+f(b4{nhZbg{{_Ba*x+1xh%xuqb@HhDSJPTc>Tk?`ThwBd?d0%yxD-VpmKl7|fOMz$hCFZ%$GC`t6b|^Hc49PG(&9drB zK($!qOJ_+6QTppkL;H2OdiM``lk1| z8&e1pkNvG>_j8bpGrph=RUPR5Ln>mWP3Y-ni=)JUSa|5ACCtlRi}dxwB1Qs5U@6m5 z^7>mP6d0tb&fJy@c!?q{ba{nAuoYz|24O&KrGz7 zZ}R=Arz0A6X+6f!C8D0wdg(U@^oWI#F9ow0i(;nal74vb1L?=eI69{&h_2zWGQ`V* z%N#7HueS0~g&OB`FM&L`wdT5{^rZkfcV5DUoE4~YuGz;B8xJHEQzG>nrN{$6=fCv} zIk3qz@BHDf1h6w*;$s6Zq{DW2_O)IPw4P{>hB(Ec2PU!0Sq-5`-dkVg4eJ~5WA5Y1 zc>NY}sh!k^F=vB@XrB8E>c@&_XCp8?h<;}6wqg(ApNsaN=Vqo0MV)4l)^wiG+hH90tJEMi@KaS5IO+#~$i{8aPRjOQw z%_h{yc$)}ypAa#vc`AD3_*%-jEd??6QyTHPXM_7W{gr@{Ot2`v$LEiijtZYQ){HI} zptpLXl`eFdKp%PWF4tl*Ec%@-$yY2yM894pM%U({NP<6XD%`nXa;_xP?}jL>-_KmG z6LSaunhMN=Fe_vxEj5$SCxS}AwK5aeM;ddc_qb8s2EDVPrVzr}y;pc%@kBoi(&dw@ zPyczsdJloE)~O<#NoW#y77_w9lfU=230|XEK0KDKyd2T)o`Ql7J4x zrHGyfq@cEtZI@lrVu&?i9V!qi0lrh^tAE9kA@wDJbG#|=eNJcsq z=iv@GW?t4Mq>B#Cn@mY$cNF-Ck zuYdh_4wxLVS;;sTfj zbVjd6k}T>M8ZEzlDjP-eG*9tt#3RSMn0VD(5fbA$QQUAZ37tq!8vd;@tq zW?y(AXDR2>?+bE*rD-3fGC*rgn)8us5&UrDv@U2b1eL>b^N7L>IA>5_EbqMq>=wNL zWyoxR0a<4O;jDo&L+aOUxbw-{K;B~&9QpUM1T207w*9+o1b%^3 ziq$3|83{yHrfA_?C-6!17TtQi4qiVEzA2{{!;SOW6;qpAP_OqovE6MA9;`*CyKk() z)!xTF*XgDqZT?_6@A5AQ)Ffj5maqU1h7QSB^T;sW7mcKWggxN+$uEr|Rb*InLJ4-7 zu%Em?ITBr*MvnErkZ6h5nuah&hGTxc6j-gmV0)Rt8j#Z*`{!N11g^WpY%Yr)&a>rE{}Go)Cd2%_WHaGjcEIRU@1? zrxK$VSb~M37oQDJ<$$T1uz}{@8c-NDdA?X#fXx+m=ZL;V;Iigi`*UFwR!6w@%-J0X3-IZFSLCUM4b?9p^Ox?V_c5P!GdSjlOWnS%txJRt2 zRyTe^tjBFv<^&up`vr97wdd^Gz5`X%<2)sE@IHj!Y4q6?6fE1s=XuRS9ZMwF$79tnDm7QkdwUk-9*CrUKSP*f zjb3Hlb66zsMS}l(b87~4Q%gDMslLN@(d?;EzJBP7Vqr8+nu26CZj*Oc2H~v0vikY< zZD`Do_juh>3GBJ^TPLq=19z1*ZE*1i@UgQdFMRa}*l0UR=*vID8`F&_U4vZ$PvW@v zEhEByzG%((Pg)n+6MyDiXZr?DX$jOnj}1b{OiJ9ig2Q3yQ$s5Q;W{xN&a(b}XO42? zIR{=AHJ}?U>970GXMxt2%}BboG>E40=+iGI>;P>0;aug@WMQmHs1SiC3xajxu5ndW^^DLvgAU);8a*3ci~X!Yeq%Z^M?{vQQ&_eHAT6r5z*1uvX>YY zK&N3=Y}=I#RBX0<{JlypoOQtN#o0C^rgy3H>OHj(UoT7*e9z z4;(S~|G0I*n!pF4RVPtDs7D+D^a+&j4PXoFm@c1hM(^yGBmNacK?j-`8ksF@LO z=OO5cXRONULyo>c&N1xQz1zCM?#kz~t+gq17~CiLs5B0Ct8bScTbM*gx8m;3_tThzWGCuQA|gaYh{)s3_?kY?Xj%{KW1 zB$M^ngp=U6NKiY~``5D({$v{r3LcFC`8CHdDuO?%|LVD{Nb?L-YQjC;g;k=*`qN#u z3%RJv6$_CstVj3twW^t!q9D{czc}ky4x$No+=bTs;XNsJzj~_^GQ9aaUi8!pxM)IT z;4fbfmZt;%z2CM&f%(1D^@RH*K!7tKsi+ndTo)M>tgLp~7KJD=EYpO%JZy+W5Dk#mT2k1Gj_F z1M425c+YN>ynLjnhA$C~DWvU&q-H`nJNw&j=Zv7rcJcR&gFDKQ+&{B0=>|vUh;`XX znjksL<5Af&J2*uG{<6NdCWcx$`p-5JXoHpEXX%kw~=` zKNorhtWWbE{ff#(*Vx=BNglpJr-FVym$QBdG@&KAl>d|=l%~!v?AR+59q_tge4W5i z*^>D*|1J$3zE!UMuwMh$`MzHzo~lP|hh?YIPe!9C2GvP#s*ey6qUKfbpF5Is@m$;A z$bs^RpJOG%ub_s{pZ|Az1G0UeIhgjw83wdOrS0-tk={KT=ZOB7=+*lT+{vO5g6CYd zRQnv^;qlbHi$=cSXhnGA)<^+`(Ta(y3Sr=<%vLk@AqEy+8A-R_!I3x#Hgx#U4+S0Z z*OZj5hmjP)u@VBmX#U{R&`Ntaa%XJw2IO_EOk< zNBUQwrlaK8*faxk(w218HH?Nb+j;ChzDJoMXD+i%bOC35za!t{8g#poR)UqK3_VKF zZ!h~+3P*w+uT=i-fG^xi`5_Wd;F37+hYY?jcw1_g&b;~`MBJih**^0c{Qkv!w%NH4 z+IoB{SAL}-HtT`B&*lzj$#aD{@@yJGSB<*Y^4K0Vhd1HtZ%ZJRHTL#d_y1r!cws_f zBpIgrKG0pP^o9SbU(e^$5p)io=~xY`8^A|=j6?QK9w;^339Dc%MsLoYQ*Ib9MUR9a zc+EcyQBX9CDS!BYs9zgA9Zq=<4TUP_waBKxgQAVu?7t|O(z?=dJZT7c-{0Mr6SM`x z`@_!rgy;0DHL0|b%52ckP9wh?I1VhxE-uE>4%khpBwIIa(DG~@Sz*5*(AA2Z4*2T? zOGZJI#A|U7J)Jq?bPPxJGyPE)^&)_{fA;V~%}3OgbT>^xI|ua}@w~4qPY1KbqI=6- zgn7BXrbFmD4w_XrAK&~D29$}SGgh9ta6g~pvhlZIAa>VMxhLff4AbgwddxiF@h{)j z?1lzZlI8PCJy0H{C)TOFI%t9GqGXF67Ae5lk!CJs8wi{J+*O`*kqDle5U++mfP_kc z;Z1`Km_2;v9l0@ta@MH6ryV2cHgk?48Jdl#xIes-NtbZ`|1>sTE$Rh`mK%)pSo4J^I}th4;D5wxcz%Ki zn|^-F-6>_9;1hOzRKmuJIkLWGBYN-)203y+lpOG2QY$7lRBDTG#>Vc%bE9b>_LU0q z%H4rGhJ7ZNPH%w1Tfp46l_{fVOM@#HWU^w z2U))DBWk0hm~O`1mU`M|ppQRGJpb_sHp>3~=N$PLaDDcDkDYi2-cY&x^IPtPFrGh` zMf~WoS9>+5>1>99X(LR#*_aKZu;-ghC7A||Yfmod1rC9koXYXx^mVwNrXYGqc>iQA zqf=K68z$`OPIVQvjf1d@M%FihdAKb-5K+jv4yid)ygX9*(Dw)#ShyM-q1KTzIPtO|r zz~FF|hQWLqypH^eqfwgy!&=Ib?X7Hhp2BgEXT^#|bF~mDWaYvy=_DRMs(pA#)mGrd zSP736yC~{U5n&|UEx)vcTOgQys&zYb4H~IR-jCBYf!MCA33KOBY(rLh*5XJJ=<>sNYvT-0H zm;315+hH}B|6Z2lcSQLh@3pIjF>)4O7|zjhKs{7H@K28l;M2cncpya* zypIm;|J(HGj6&=Wev0_&d`83~F1Kw2ozO@BH@9@o&%$+QR41zt0L4#D2{5!FG$U(b zJfW0MD?$AC;2!{@A zW^6662WTc3?Zi#{P^xh535~@9v_LL9r1Gc}GGm4Bm0GmG%RlxWa}p&;T99q>N>e-X z&0e+hyZ9WAPq37;e@+AA)>_QQNy>Z_N4CGa9aVW(dD4}og zq{Cqr@Lu)x;wp}Fo?jDi1c4=E8d3n)i6g|zKsaM;}E)h}R#(&_XglB2&M_Iq|~A%vVe`+vIsd3KDW zXc4JRxvC`e!jtld07DOw`*Grk>BtunrnmnO{BsXU}V_``xTG3zg&SCr!-UQJ814?p*mi94#&Q#Uc^` ze9wXl(cTZF{a%GMgR~e7+5h_XAN`Kd^rd9mk15DNYp`55Zv!fX)T=jy8j;XhkzU#L zFQ|h<-|J6yB~X6&^G&7yGy2CSE;l(AgJ!wcvLHVoj9Q zYg{fypAQ=p@rE8alP_CcAteHxq~!sb4_<(MUsi1FNG!Vc+^dvoAQ3SLNMES3y^pfw zDPJe|-9&RM33j6I>frX@`j0nLiovq+uG&F}BeE>bt-2#c@Z*lgR8!hkz;}kp+vX9K z(62y`oxS1#C_BD3 zlI!0G)Wv=NtBhq4fw$mJFHP5mB={?N$6kFznV&Tu$Z(dRjECH8Id0|XO!Ao@)iF5o z?+}%{-~JGceZ$#|u35q@XY%|H#vjlpHlo<>^Vx{CUHgd3AYraZ)@r|b%@Ks3RZZM% z@j*0t5tkBVE0IhhPG(i{4p^@Bi3{+@g0!dE4JN^5H2AkrOI2?Jo%=z2dEC4hip_>Z z`d^Y`b^&$buU8*{`yJEtwhK6FGm%P&XTJ|Ub-vuW3~eYRhQ_w>mpN>nCvBJ$=teoi zQ)2VS!ofk>;Z4?trSt5?t!W*-K?{f)-V(< z+2A1DkL;*7J2QM;p_|=Rli~U(8d&G)`nsBip8QDhIkJgIl+{@g`onrq)7 zM2bE!%(nqP9QP6RD*6l(ws#I)zZIizUf22lP&FaW4$7qv*Fj|d%V}M597n=LbQB7< zP3V-SmG-ww<)}++Kf%!;2(f-RL$ozLh=gZzP9_Jbpyc$b6#BZ0P<+!gmpB{2G>M>< z(fv;F6>Kw_YQK+E{sD2}p+0g}EVMK8>xIAM;TidJ)$orwTlRC38{BBE%1m)^MzMoF z8y{y^kXIR70gc55I=Hhq>c7_Yu_Be;Mu&$&dUObDa%d!LCC#b zz6*7qFMJ0Znz5j$sW`BDK}{0T*@cY#e_6+rq=Jidhxp$s-9YWPevGE34qD6_NZm=6 z5M^TPH_p%kU@;n051in}m|+PC=>qb2BPTZeXmXBja!G9MCi z(jC|!b}rr-S%+`tCcGokn;_Q3I+?Ea8%{{QRy_Q@332)k&tAIR!r~SU?l-yrhO(jR z(!W#sSPgZeJ1G+>R^cr(NpnRRGZ4zl>7V%naVBr`Z7OeKHzLfuExcK=w~XP}nECc$ zVV4Jmd7r`lOl!1|dI)1-p%MCD?(YIT+FevuA;Ko7NzXsLauR!ECaXAk$d65Lr%VK8 z?1Lru@zX1DGvM>I44cA4u;_P`amN(cv3|Yz%hxM@f+d+1BBOq+RGAW7uc6{+e z(C`N&3O`A-xUPon&Gt)h8vX%mWu4sQr>kh?Mz?fY3?p{F;(#`Ohzg@t57gG=n?>bC z59Ge=?V#$O@TB&cO?W3tb*Vgd3v492|0WhM!Rx-*`w7$iU`nq=89&O589ALzA6B8j z#*WoqIeB9Q)?_bR#~iG|NO9~*{nl<&=0W^2_xCQMxM$wzm1K!7ziYkuFARqV$Z*@fELiO1k4>OuvG&1Bi z)h=@sbKfn96OzpXB1bw}x=|85rpLj=^zsh;D2;18d87bV_76hu*HGY7 zI!;a)m9jGK^ecZOqTk;=5gMS)Gtql_)>6YXZ z#l{-2Z-2{s?%G#)TC;igW7Zy;DU~8y%)btOS){&oBD-iHSAgrKn;LX@v5funoI}ua z)xxQ<37VYk#|#6zz{a`K@~V0}82+#?lB8?{EsIkOl%cukZq*$FZHF!p_}cXKf+ z@|kvwkP*PQIAcwJc6XtwWtFzi!3;Rv7s-w-n=;fGX+e}ndK#D0KBjq8JQYH~upu#< zz=iQ#$QZi1g(?Q>EdHb(!9&innOFa)gQ=pQd7L7h@P#rsq0eRq**6z_%W2p~+ijzf zUMdB!d$z}SUBDYyTCR_n)U89lsuAmvygAsv$0y4wod)Tp;UrfN3&E|W|M@e*xgJ+- z<)~ZM4H0kYK(oaaTI`?EYMv+P6cTl}SqBKY=q!=SL%$hx=kdvmOC*J`qg(hUH!&M# zFYfIY{z^y5UwE^}%j40wM|NfIbP0s(Cnp>YWykAJ9NMfODF!)mnq^9AZrtd*YNX#` zBRU81E2Gf+_5 zRIsbzSM>cI$!WeH#pui9>DO&nbK&uP`||!>9C>|NPgkUjN1fe@QB(du(RPg6!xM3~ z$nT<^2k+q!qy^+W%XGhhTq*5_an)fYmntHqCvq2rFDlD=_co#z`H~Y3A0ko7^{eHe z{T}sqKQpe)%0UBP^>rzH$gu8_~=EE?lg5xk@D546sT)GEKCMN{{_pKsh4N7D{9 zfo9`G@Ixzb@m$al`gX}ku*@b382$R=*Z-EGe@%t?*LkBLxBTdOCsip5W$YdCt9JyN zJHO?A2}J}<$jCg{vY4Aivyuh*98vioW=k|gOrnpr z92+0jzqdt9dh@QC&ef>8=~O^!(kS#7L72Ka6DSK5#TxSx_6Gq4ju*~JBI|`BUreA6 z;!E?Zns1IsG2I2K3`FwtcB*sf5llyHT3c}}7|jO%r+eX$7t3q5P!=3rMYdl> zw8POl+6uzm{Lazhjm@?jUuoI#{ z7=)3gsb}erBbNtu*S@M55`50XXQG>T(XrTNn;#9@AaYzs(X?aa`AJEmLx|w0S(CN--Br@x&Rb6zt%hxl?c|XgO_&LE8wXvmtg9bIb>?t zY3Fv;6xitO_MU63fd-am=>O~nEXV~8h>*?`eAPGh`Y-sQtm%I0{?-QM+H)*WsW%!a zFqP;p5qw_yMGtOT)u+R|A=Q|@j(ILR^h!RGYb}d;g#y_`$h=4B(zgu zdlY-Ls2Ig3QU>43#SK_Q|3LnO4BAmnJM`|Nm}fj>I( z@s7$~4WhL}XLktxPRou*_B(HhaRCl<6v9r2PyG-r?l_i=1}+{W4%#(C7apr99A6m+ zF7#DvNMQhVoxE`;Oe75b_AzZtI`*%RJFvj}z#yXG8J3Nf&=WYEz-6LK>KK3KaXZl*c`P}hIbNAm20KnEv#@MK!?dn z74x$B7mw~G;x=WjZwlT=Anf6K)VAj_c5^jj1>#EA}z_Mmc@rfQB9qcy{&|)<>dY; zi0{KkH-KPAf#~VWZ@-YWriVSkOZ416?8|%;;WZzPM@> zenHEF92JJ*vz}d(uDZf_QE-d?=YwE@LXF8`XTHo;4y4^CxMT*OR8 zkFjX|6vb|%M4p9aKFp4tzWS4%2KG4Ib-LI_33FRHxaL!J2~(7<5Nl))#?Qo`lb{#~ zz_a;1O@Gg>L3hpNU~#7jC<~|`Cw-BJ+?Rhk_JuZ}9v$y(?3f%LH|}6XGNFrgx;S(m zGB$uh&iACJE4=u#&6LLlg$pP+mqMWRf(*` zFn-0NtM_?5z_M^MYDI<_W7v7}MC0B=MAFH_rq#Cuxev{#6Th6ox5xEZGhL5iZv|?9 zWv4RW{UiTYs<43fx*xK%>45~bM z^;?uXG}!>tQ%@i=rg;iXr1{Sxr**K+ifW}wQfiFhZ0s`>d;m2>mrnooC&D~gaTk6L zQ4D|lQbR(J6ifIkoo@Mn7+bQ9;LP;6i0L2v9^id*4f}fSm?@w9B08JUVs)l-1iV8g zH4Q#&0+h`=?Q(9RF&$Dj6KyVhi;3K%|KlnALe^Yx#6~}Ipp#gxm^Q`a&V7GE-Mb9$ zB#$uDdurf%gAPuDpdYEt$jaGMHUx&KJSjJd=;j-2+#IksI)ePRiMfO%5 zh2-0jn23E0FVPK*IwoPshl2>yap%9yB>fL+OS&pZ6{peWlA(&55Pcm`usw|Sny9{*PeA;>I1?{!lMkKFA)AWtnRB0jua&hk+xzv zJePkqm`g#Alc+e%+|(rKR%Il6^R4zM@AXyRmL*ZVkATC!KJgueZbl^K-{8bAd#8rq zsx1c3eYp5`_zFhV?-YA?cMH5aekAKoQsV1FCTH3{3?jNt6|(bxS@1-mRmUL3pCI*{ z<%~(BHU4&VDB9BH6EK^QE&8uap*^Ru*0SvYMBH61uDVBqrLh-GztOQqLYYJg4;`to zt7&)9C#zF9$I{)$-Ago>8du$tR~{W^<()Yd8X$>V;l~>M6bnHkii}q8d@ow~lV%241Gr}0tzK*QlnS&FgbuPuvr+_xAAn|d3F|w|e{B3jv!7bDL!si$H@z{^Q zZ(lNI#C~#jxu+3wJ;h2>`u9{!@g!lM)khm4!1L}g!%@A9xb2$h%)1m*SbJyQCcdYS zRT*@o>Bc+r(!i*8rzL2I~X$WMpdCa8e6Cu3RLU;j7yu5 zXZ_DrQpHjg)mF$HLfAGcig{{^Tjd#Urq`S`-m~6IL10sQ9{o8_9Az@ z#~|viyz|Vxv=4FAiT-yaqX)9iPcU*j9mk%hh&?tK`T;4n-IVh*9WW{Uy74kO5x%oV z)!A_JE21pHM-1g8F{emYwZ!kmh-~_2$2SW@tmjgUwiiqS{XYvA#&?(S(^KP{#&sRA zkh7jaFUf|tDhJ%rewhdT9EzM9A`h|q3G2$X)G?qNUB`dyrW)>V`qH>9`vVdo`{dF_ zp@vD+@#JVxO@B37Ql80mNClyY7}L=-u3Nis3t7QA*#~BRW17yiBXN z`juN3h##o5Fpg%SPl03Qr^FTTQqAoOQB!#==NWgzHTy<%R;weU$g~rz1}*I=-M*mz z%6!%>+lJ8ngr}<<8r=9udu0M|CKYaZFwoV`nga>!%<~t`J-jf9b>ss_hKbuQh!eNGLFe<70yp{4k5kC2TQ?kd<1OBo8?zhM~vc!{Xk+i*;# zUb{5>>1#};w~57WdmW?p$O<{*IFFef_K|leMqyl8>~!*9=5UgPQD&|BV)!iQ`r`vh z7SxR}L~lxGKnt^;(?7zVX7`pzlm}NDG?r{}ak*!L(SuFN-mNr(-vQ;B73RVDFMWXz zUll`1CZov4Vk*=-zL}QjFNP=j$4MG0Tt@la?j!UpG39T zZlqFmGq*Cfv!%@wu$7O8J%1I&xuu9z#-{#qdlHOQ4f%`WMnTwZUCPflMg6cKHQwV9 z*anug82fqf-yFt`UoaEvjl?z$9OvrpPvCJC9(NLPJqr+q#DxI!v$c+LH1N16>w>HG@A8Zn?) z{3*o!LN<&Y0jY0R`B4ARAW369laTxJvP#)afboU8p5bjm-`+tndQ{a6>55C8b`6&? z^%mj2qrrdiraQjJ!Xq^>jT9cnm5>IET}#RD2=P^nd-O}OXl*4nH1OM9hx0PVY~Xl} z`Fbk;?nE~I zmL9Aem&390ru2r(X#;q7X=BXAyWh$Y0hru0RD1OvYt(|jUC#8aq6bq0a-p2?P8U?QCMG&5(Z*trO?GV^{1h{;>hvkGkf|{B9QO9_(n)YkdPl2 z+p%?FMkP%#8I2dU(XYqj--6F81NL5r{Z2nUNIU%4nY7VBt*N2XyZ$Ff8YQRGN=h*RtE1*fj@id2k*UB#xxI#5`9)RWW8~dUXf#Y)Lv)x@S zP?Okw!5@4V^0+Kiea6(`dy@U(bpp@0&DV#|;QIscjJ>wP$fFMHe{CP+4(dQ{%MSoE zQ+Sd)TQxY~4+{Bldex*;pfXZUx};TtjSa6^=L~RRmUIJ6{ek{i@73hhKXUPzdp`B zDE+73G#jg$5x66y>We$ER~J9()5JEZt)(t@Ct?kZlg+AWHo&1ZzuG};05j<|j0x<9 zAo`1JI@wJRSh8nYUBz^OQ!Bcwyhj~|ZIkXks?Y^-XQta%ER3LQ^h(l=n-<_mN6_gz z^&s+k)NzHQcVU;cbs*)68!W452}jx9f$dxF78OP}z`15U;QaUdP%5DR{rpTMI97a< zO+PjToZclzwj=+;_D9xa9u7~T&`7S4yYF8S<`PB0A4EB3vhL17l-32_ZF*6^^@_JlgFmT z0uLs>Ibw37!zUsl&Z7sK^qnKDyM*-RbVD`G=Xw_1*;0$8#d_>^4}J1D4NCrNX`o8W zh#b4ZB3^Ip)kpCRC-%JJheTWJp-222=nUsVe7VALMAbwoUoId4=DxjchCCAJ+G+M2 zB~lLb{;$UAwkM~M-OZ2ImGi79s3g(0hD{6VTi&h==pMoHb}a?Dpb?wxNyko>QQ&9g z;z|F;n&R{PNKuM}V4C~vk3T(07K|+$JUZhyNViAY`lu6frBL{DP%wgXE zbFU&$*XK3xxjD1S>fNh&)9psfr>F^=X}D`rZ&-#&ij1Zgc35DVvuVX7lerif)ye8H z!hKBohm**<{2G|gf{#h>RTy_#MzlE?ERKjjy7N&UhOq_v7*ZKX4A*ZF22NQ0FZAzI zH4SKSgKosph zYha`*a95m&RT!}Wh1>ir77YYm390nwS&EARW>G%3c+a~(s|WogyQ4B$_3Jl1@Zl7nj%xX(KuDB^Hcqzs}SWg$ii?S4D&r= zDV-QIIHx4djK3mRk+31tk`>Wuo(_EM@sR5jagY0bHJm|r6i_TqU31B&Lm1Z(j7>?n zf;T6M-2Wvo;1XUp1~LsZv3#zSE4{Q-*niwSv03y^*d-bIQ$_B?*vK8Xdb6%u*tc&Z zZV3`Zm;l?|zPnBLae?z$Om8LjVTeDNlRudbGi~1Ab-JgEmAt_E+nlwr^yaN_HtHUH zG;oRNT2ehu=h2H8vLE8|_w2JnBl2)@^E!``Gg@%<&{hA>F?ui!HnrPjISWmZd5t5N zq~OfCqXU6wF;HyEW-y&4^da`1om}~)2-5;g4^LTL1!^~DOU4EwxVLy?q4T65aIyYz z&g(UTAoZ5GA$lfw^6AJdhqEqF(Jcz8-;o5p-KCA94JnX0bbWX1&VR6<6ynzy*$lao z(&pUBpJ4n-HQ$MwWgwC!rY3=RJ+PHry(RXm1E~8lpQDm-kX%iO|H0l3 za@&`W7v=UrIK9*LbccSRtcm;5biEaxh2IeP#{C6KzwLc1|1}IzN=YWitp^CbU*T*c zGz3m=wA*V3;Xdd$2)C2k9f7+gVaigDlc&|R00r{IF zHlA4opXq;7#wYg{VdKAQ;(;S`;N`UEFir5Y&f{DIBzv_$yVW{ndaRki;i9R`yps=D z_p!0YA{>(U&xqL&IJQ3=>n|O)l!8(IJFW?WUyv-O%|q~JH8?2NzPYGI@NvyXANJD> zfQ3vmk0hbz;Z#+YzRP+W2y2dA75vx$2~GQ^xh#W_K6Ds7Lrm!Dc)iO&UD^&FwI;@# zoSncpCRFt1OAQ=;j?n+Q)de*sw`UcgA8r@MBiHX8kZ8Pohfet;c-&fMz;#;S`=Ptj z5=$?b(aq#ms{MfC*W9GlWc_fSrCE`7avCbsFW@NnUEdmEQoyYfdG9i0-;;u_^7sPkIkGo2l1rf&cFEp4N z!MaGvhLX@{GAU8z6>zZ!YCGo15()i#7qt#uq9<^$GCFxh&7=_)>+Yetu_8i0w8`ug zO%s&RMY<%M=z_4mG>*-q4e+o`GT`t22k6K$_j&cE8mz@kM_a|4A<{wVZ*tuP#7qTj z{UPX^59j%M+9ihpn8aN^i`GL;UX>A1;t=HSrz-E}67IiVF_G$>At1`}d10;I0(M94 zteTn7LR#Dly^ULb8$-pozD3J>9YVs!hN+Je78`iL2Zjmlr0)jc~RL>b{Bl9 z<9DKzw4vc=MAe9}1^Oq+(0}vVD>!pXh1S+y89GRwNSR#oN9tWPKfV#!qZE-2Ev5}? z*yv&UoUCC+=-d7+@=?|pJ&e}L6-W_>8^Q)uPfE`BN zbbnOQmG1O#+6#uAi!O}gPtn{E`CAdmP}KdH=-|TF>*&~$UXsv9OW1ZF%{v#7gC6LT z`>=e-g>l^O(~X)tu>1KrQ`vzZ+=y24`|s&9w0UzW9HxVj=&B}J*{}z2G5?psSp62% z#|KyfMR=k0l$Bap?Q?i~O5dL+={6+uYzYuubcd3%Pd9_TZ@@2!(;QjrPoQu7ObLCH z3GjY1{^7|;;?N5aO$ycQZmkD|5UCs%3f-bFPu7D zO@1{W1gB_xR-Ub9!T0E!f8}B#pe6qF8!O2?m}gOHdBbW0hiLD{NkVTWR%}i#ZJmzZ zld}ps5OT?Fzs|8dJo6YSn8p=fA58)INXqMHR9}PXdy&?uV<8~gUHB`|*$RHLUheSx z7zRhLNAbFEJprQ$(@%63PGIJzSN~GW7dnfLJRKGZyq&L^6c6q0fPnj1F@8g+zL(oX{uQqGv}WlmT2VuFgzrbs(W4lpk%7 z2eFNK$|OY?@NV$W8QEM!G%HyuopO#)$U_t&`A-MkWRr{apjCpNZ>L_(UNJ{2=1zTQ zSsW41Lfd#z(|vFa(HJi?FoT0EmiU<|8{}7aPd?;^KZIQ?y(!La0aXFHK6|nO$RTn0 z=c;d(;ue6!>hPa84Oe$J{V}0yG&^(OCrU$XD4N&d*PL5b56!aWjNmeshIm zulKpz@Xv1UypOymVxqRRGwR!`|B%BSYJEu+O{jP4MLrZkE7yY#cv)qkghyxOuAwLj zdeyX4HfV~>bH4ZurRl*9K1IGW5&qzTEkH>xQ0kY=8eCa9FQNGgQJ6 zrU5dpTrP|3gx~j1pj4;YW7K*OtaGhF)^ zDIq1Zh`x44ifmHe$4nH`u=fbrE2ZpF%HCv;5ZRK^x%Mg}$%yQ&P{~UD?(Yw{kNdcv z`?>dX-sikt&!@GT(-)OF2l#AU_`1+62VY@p{^PT#kEM15&dr8g!}bQ%nirU_VsCaw zrpiJUEJpm^hToXMw%4$yAGaGg$Wj%jZHVAfrx<26!&`9oeqY;GEF;moYGvrHwCmv9_?0q7mJ0Gr1;+R0<)K>lpxKOQ49JX3Skvdi8EEP5y>mM^*C6XHkdp0(b_ z*CfF^6-y>PU6599M)Z$#Nv5Ta0h$n>; z40dEoT-P&(UhBoe4+o;)zh368@mCfwUwYr)aN-#}2)p{KG|&lCJ(c~$>CI^$=534=C^y+QQH5gGq<8f`Ni~t~@3X0i}ZKf2;mkW2K4T zGn#})z^GCXq(J0$|7-P5;Qg0F+`ss1v1yiw&kHW(hdsUq4u{WO%h&bA9Mw5lHUE{v zLK;WEeN!SnX`|<@O!RGLG@c6ROOL}dGE56iZlOTfAni;3tqqQ9wfu9uCcuBX`DNZk z1Ble1V$)|bhqD63Cuv@3!KZViCXfGI!e#%~7E4!+p*%|?`<90?1SZ=_2YB1TkEh|8 zx`X#2RzNkBWz-gm)4$R;n+8F(Y3m=s02koD?D8k*UK~J_GP%`eAQ)-?l8sKYgn|?5 zW5Xi~AVuS#t*G|@>l$ip%l`yIQW%oH^x6TDe?6M?`3B_dLkQ0k1z;V1n>bM72_+j{ zF&26^ffla^yK=MRZFlm=ti5JfSAV_XMZGut-m|)gVFCR_NJ;DsgU^4}!g6_9Y}e4)v)1k(>f zSNS`skn7)7nY_(S@SVMNXj_~Iy%xVJ=jcv?oUH3bmyU9yhpiQULN^!T%VW5#u*!iJ z80Z`IoZ3L))IJkGK7)K}e~Yz$J&p#uCK%XSc~HUpr&bZ|6G(fG{5iq@6uM_}neK88 z(fh%{ao+jzDDb}j#y8zT zdq@9)QK30&mGvyR+4s(UwfzZBLbIp7Kbe90V9)*NS9|bZ^w~0hmo2Et;9G6!TLIFl zxqGa{e(0)JmcpH%yKs2NeR|~GA0TgEk&sxPh6DBSW4aDAphzL*QaeS4dQ}!8rxw@2 z&qDIVdLRc%@SU;EySxpz-TNik*I3cF*S+1M2e+{sF;odvzAX>@MUX@sM$;&~@a z+0b6CEYC$5GSrmia4E@(30=IXx;?>v6eY-H_|ZJ3Mys;VGaF65W3@a>^4{o=VCP>Z zV(-=h)9X96{u4EDJnops6}x_TwAWkjbGruS`=soj{Og4SY(hT+Q#Zl&tNc?{;USpg zF&FAfS_V#UhZ{MIBM_l^GUfX4FZlLoRcyEJJMp@n9GD)N1ZJu0LmCE|kSsS?|5A;Z z*Nvr~G7R}e?441^y1yBL_#fk9mZ!%-#Iuk_%$fx0HNTgNQdEn&$sRh1zHxXkB{ls6-oh&0 z5g~FUORn&KZ1(_4dLvH#EbJf(`?*u%*0hOPMyG$D9|$G>zCYI(Zbw2!p)8N$i3rSR zJ*E7XHwPpqxa5PCLhzN9pB--eX?XAg?^4CxMtu83haGQRDYysi>NnPw!#00nD2q=u zZcNq@t22oLw;}s3>meJgcDtVShg$}&$y1GeD58nU(L*DbmDl*X&Z+C7mn$Lk$MMSJ z2U;Md+qktTrU9!mSai=Y`a|cxod4LbmH^Yp8c@wu!cp-p$*7C{I5s2H?ETUp-ag*6 zug8-MgR+CezHeILMCC@AyIVNc^RZ}Io1exqOmd8UNu3}ctXU!T{Rn}9|6b&W1B;N` znPtDOx`{g+ENiugroiCVq7Vp}!0Q#Y4Gz;x_%4+3l2QLTRB68s;QO2aH3}xDOCnxD zu9eu`)?G@OE@e`$|!AsbEcRO=d<^?Qdc6ISU z3yA%Bc>f&>ky~MCr%@+siYelREfov1;5>;UyQy!MAwL-Zo$(HM`tV%~iZF5Ia*hT7d_8uWqK)e8#z( z6;~2eWAN;Z4gIO*beIe3-)tES!l51eM)#IpVpUai$@;%Cc!4VKtEjExuf^Xly+2=o z-9_RH-%#Yj@R5V3wtq*#dkjy?1WkgoUz4uUrOJe9zuE+Pj< zFgfYPI(*?{`xJ3*7zUgF@RKDGe;3W~eyWNQ^PFAwcLNkwphERhe~=rIcmJo&=*|8L z_@BHolTg$YHJ>#es9*i~ga83{09%-YnRUvEIV9uX^uZL4XoP z-8?b+J4vFa>Uj@i^_Op6x9$c&g}v$Pm~*B$qCZ5+k1`m4C`cPnDUig+-zs=hCzfO5 zX3Y;R1(m>Ke3TcrTjRB1>YR4(hxokgz|5qkBlZw1XJE3f0}rH6{y_N^ES~sYHYhiS z9jHbIuiC!FmV*`xDr0$Y$?Toc{OLAWK3#Kz!XONT zs=L<50l69L;&UQ*FZeQT3)N@8vsX~gT)(t(~CwS?>?aJ_QNyu;9opP>VfaLP*ABrr2_~`fkTAnc-^pYA$nw3-yXXbT!14CUhxY!-M~4t4@4}MS^>yMgI@7h;6vQe zT_%j5!KMp@-@g5hX~Zg7WQQDZr)HL?t4YAM@qm@~x8H9KTX{ z^RwTmX8R##JgzKus$2!DUUwI^xbKWDM&D={bqB#G5zd*PS=rz{T&5+g`3Q?YzgW!r zUnM?&_X#~YUna(OcfFgE-V^zVm*yYRHewt5-|BJ!=|Cy{j4eMq3MAS~Ud^lJ;?h5L z&)u7hV2;sDlSSnXR#Z`LX*-ccq3#H5qpr4z*`?T%rLy+SpGM++ zsqSBoYVg3C&#lG4X1uP+h=1N0#Fn!`3xxz?znFsxcisJnzlf@L&;^C#YyI*@HpKiw z=k_-_%5{wYaZ)XK&rZRlkE&1jY8WO%G5eq2w`1y6#lviD-SBOUwm&n%9Tw<9W&5Ow z+~>YEsl3u0@OInYODE2))Eet=w`VhejKv~N$kP+tYy9|weaeWvz6}-fI8$Oz*@DkM3oCH^iIimdLl{=sKo1vw4hU@ED3t&y3dD>ItgnRo~ znAh8qu)ztAR(s_zKtY$v91eoJl5`pgt;2>sJMPe z>pqv?vQvm9upH&RNiS&PZm=qKVuGu>{YsOaSAna2DbPnZ8AdD5%FYfXz!SyFWj^I* ztfup{Od`8GD! z9_@ncnyWacB_CpydoAWEPwa=g=Q!Lh6F~Di5ec8&u-uFz7?%-}a@`ot_rZM$^rgp5JCxLsPZeVZrk^&}6;K+Fk||(v*BFL6BBN z0(3rx>vQU;;i+2%*Y-6ee9dL#!Vw8nMXrrsjj186P*+O|>m|GSRVL+eJ7&98UrzN=Xvqw_Q8 zJ|qqRSI*O!na4NKIvrWz;GiO!GjJ>q9a2Y2LY;XAE_6umv?=|qg9r&PKGZLIuY|@# z23?ZS6;yC0<%0gTv&eI}xlFoN1vQHA8+0UW07I(c@qqW7sH58FV^k<7I?cAdP@|fG zDqOSI=-1*2{Z?80zxSfi5fl4v-|H_3Ug6fgSLDM{@BO*nl73``RIHgpl^Fi&wxRsGxd6MmKRn1w84+6G_HAEmggr`o zUC3rfDRDBxyO9k5eJ;y_o@~g4{wx*6&wOCCru)*kWsCywF-`6+r9QT|3Gru&lcobzG@LCqlj9JlKzblVMxcHbCPO>8I zU|<_DaA7=Qrb(^ZW3&)tUN>KQf`|;M+={?@dtfQQXqZ$Q)Py zr4&(c=m2_FT8k|*bDSNw%qbwe4HOd%`s=*O*gmD;YQ4r~!h|1T-;jq2nO)7d{l)hV zl3@FsACWKgXpiCk&y-f8$5;K~EoMqWLc?G*_lH?{tJNrE7I6rvE>diZP?8XQ+Wxw% zTD8H;tR(f({2idmY3=5zA}7#_@iyL>r$r-nwOH`taXV6?u#@@7(8_NAw zdS*?O1Cf<>H2K{+Oh_XYCz76~;7LK`TuS6mxb}$R_vfrWpqP!zraj^W!b_aznQLp{ z(yu6mIguv(xtr5I=IjbM#Qq!qXBrG{qT@nC^Fv@H*i2tzRtUEYd^~T|jKi{emU)Ge z5%3gLWN}TLA|9VS4RkSh2%Ecm8IxROsQJ!Shv3h@LCfga;wj$|xGd*zqrUMME)RC3 zop0O#kI|p!n~YcyVV{M!=l3swIiv0HfMe*(^+q>a9#Vokt@W!T`5pKR&nbAE{|h_x z9&i{7{)00#oA|z&DI+TTw{!}BtkK)yb1iksN@(5fFMFcE12o5#tlP0CkN%YwyBb>F zLb#J}oVtYAhbx{9nb;;JED?&&2wX_Ow-H&J)ajR4ajTlz-17^_92GvgbE^hF{!e=& zHhLa@6)hxl9*e?8*RV!v;7|B;{L{;8115N|U*gj9^FJYqWqHrt$O=E+sM8}M7eg~!nyM2tXwXsV?RBdv9I@xmt&{QtFXzW8&F+T+Z|U!- zwIVxY<*KfF^Mfma`Re;(LbnO>VkJ3>G#(OO%tYV!QrAUIjlVCqncYDF*0isX5hLNM zBa6(;uRi?q=H#E1u3>DlaJ)dDu?$W<+@CwJQiVfe)n`(?g2CA1#0?s?emvju?V`k$ zC|qmrmQvhY4vdFR5&q~uz#2jh|NKN6A+r8N6W?chqF*L4Ojxc9Pq@2n4BbfuDi+qq zcV0;l$TK$tZL*G`YX|9H20osKY->Iy{dfHk9P-jrD2T|FVnm6Wdq)Z8jFfUT4@O~T zMtELQYX*lcwKzPj>4WsZnUyGVVo&S9!6S_2-|)9s->ysfBuGL?a!u0l5@N67W~~&s zOZbrF%H#Qu3N^etYqFr?gu=NqPn!8}Vj1;rtIM~A2w$toNREl8!=Td*Qo78)*gtyu zkS6{F0anVd^+=;}ro>tl7k-MrmL%IY#{LI?B+u`4IX7TFCS%70uMk+C{;A?h77xn% z^;29^X*m4+*tImdM=%i0ydQF0BI+&Ts8Hcv-`V@z zi}2awNeZP|EAHb}=L^2pi$g2fdw$3tL-vjij3q;IsFAz8EYaVXz@lV(w56R59akHh zAAV|#M!6n%77_c=WuiB?3BxORIFQ7Aq-Ycp`#ygv5GN&M`n4KNlrCXuGIlTTq__C) z^($+#qpykcbAHdI@d*4Ze?ZnRjhGAXI{us4$s0FGh?Vuoj^N+Qm&xjeiecM1wR&Es z9nYP8w6I;0G+XYke?onJl-ua*Vg`?>2xWdLy`(h~g zuY0{az6T#%edf_wbC5t})&=KB8>0b=m{XA*b3olYrAXB!Pp~+W=vy$Lhr}L}rns`I z5!UV&kw&kJ6CwqE=9-X@phShf*e1RW_{x6@9>EX?i`CzszG%jgXPF`qM+>H2JR@)ZjW}_nfmaZIhw z$L0Xfa6qqE*BI?MG_KeG{?K0mKi-Fhr%<;8_na-u&BA-Y+@CsJA{zGp7nw-|JJR|mM5=eA=slsdt9~vZD zKlWZDjH&j$7q(SE6r^J&6!Ln6>NWXSM@lr&%8YEh8N+3y+g429qjroCe(l^wm+lrg zFA8(6^b>Q54rYg`*`FicZz2|u&4nIcRAG!;Ge$|I!QYzw`_PZ1Bdlh>c+fX0s*t&v zHk4P*G8uor3dJ7XyB|u-@wm!tuqHikB}{&?+dtCHE0;KubMUVvpB&kLpWAGmN#z=w z&(@aJ9+qp}zB1z=Krd(Lt|z-tk&D>IU4k3LX3=un0#hPYKY_~NUWIX49}GOd3UKg*ILkV<-%}V(`$%h-N7kt05M5CME zsGTd+f>HdZTJ84-{zDx!jSK50dWhxat*V0@UFbv9YRt9^2YNRom+;8H8FhE?@ZO3n zLsvAPeVl}sDDC_WN8exq;nAb;+ZFSia^sJe`^WUSyD$Z1)h z%61K)k$VWQ8z`qU(Yq9@$=zF1XzJ%(SKT+A1oH6RgRItF#NI%vfNEJZ%6YQ4;-z&+ z&R6gpe{0P;kz-M|lH#z5ycKw3Gjdvy!7Z|CN6S=*TFS_4B+}0ntEdL(XAoqD1`rQocT{qeY~OMc`U1(_x)>%A7XY;TE52ce;4=A;zQHt%kD?z0%l1c zyDz38MPtb)zD;B3Xq+l%b3zm0AWN7v^QRWX7G+$q&=`i)7MqJLXZ|5CkLoe6_sfX* zf&2slf1okpKcPA|n~+-U;3uJ{G2rKt!KUy%6NEHvn_O;1LrHRAyP{?!bk{5H3SW$X zhYv)*Jq?Nhxx8nuq(7&CsM0JH{EUT_oASPgwYbszmIR|B1uL=&@^xf>KY=sCmAD2} z$&sh*8PhNyBXp+rSU$;k3s&$rKl7Q+j?gBZ-}1fg8ru1LPa#T-IH#OfHITM6hu_M~OvX>Cf zY>Aj932ElM;*fk!bo|Pw0(Mgt{8Zl{j0Z1w(wGEsW3B7*TkQ43T-4HmEoJVDMETkA ztc}O)_*lO*p$n^Eot^wjwLxWMlHYd!!qrRYjD6?4Br!+-gnl|N<2WgLft&iD*Z875 zmAn;+2Lo{Y+I^kLba(WvVMJKIz#Q3`>B?MX)PH?}#Ut6fb0PkdL+Ax*Xr{u( zFtOJnzRH$UiGBv=-Q&@!M!!})hkQ8Okk{OB&Ijc%l%+DcPU(<btofc$Xvhcl@6_O%x*7Rt|hK)&#P$ z4&?%2BVeI;vC%?v9p;mE|MA~ahHaAb@8_8nV1erDu~bI@4P7^O_a#*jD&T6}dvG1V zo{q#=$Oy52rlH%Z)j~g6RPAzCmNC6uhCTf~9>UvYb@RKCaj3H+cjeN|I`(cSTNZbZ zMt^4CJi2G=gYNlXIU6_NhMKwS`XU=L2#WDWvT43+h;%ia9@DO)!-iWzUHx6CC{S$s zU+jAnm(cxsq-U5=W?$qPL3Wie!$R!OoYXbYcbAqSIQ}U}@ndQN|J_+;j$dYkU)d(YG{kk6 zjc_%65W6D!Hp>270cdJ{C`Kyw}4~w&p-cx}+JfcHl0dq-2oT zF4rRDT?%FKyYv8M3J2LKn#vKR`FlDCcVh`k?AlW2y)F@Ip3?P19X&^|4p^aX4v#@? z;m$vQy)Z_}Jx>Qxa+1(k{Y1#abpxbKOly~&k-^#9=@X*|m53ha%kc1uC`=u-NSRGP z1BAowFF*Ye#5WguwCffSrlIt*`lEXSxWy!kNmJB;bS?XiOUqG2TV(o9hx8y?+!rK0 zHB$yVf`qL8BSa3+%&o1cCOM?XI}ys&8V!oY?04t#Zy}cV4spt32+42`GA{vB*M=@|T*jvHoLrXJlrbOMGs-c9MSlVO_` z+Bs=kP8@UXf$pUC?7QzvQu+rD3B#C^)0vwuH3|C7%>VQ|6$sXC4zc*uTYNs5BX6*1 z8Xr%)=dy11l<**4$y|!F6N_`%IL}Y%AqE~bxlvvt!UY+<{GkwYl*+BPsq~mLqeIzcCxV;gu^lyqiV1|Leo^T|_|U=b}jO zCW)hH+wv#{eIfYS`lyo0^fr97{bQ=-FAtYUUmlHLmWFGeAEqBs76fs`ZBR*b5)2;& zx0oUgi0Iah&9XyqmOZDH1PSu|c!zc}lL|@1TQ?5m;JO0gb;S34Tx>jU-%n_6q*IN1E^MKdc}B zfGqhv<}$YP5zf?obZ4Xx?W+7T%C@Q}eDZBIvaa$ckcRkl?iGd+PSL4dAo-a@7;$bm ztz<`hzqcAsGET@6YN=j48qLf@g)F_h9KwkRWNzZST91hL$INp!icn-W9Cpn?g%WRO zziU4hr;MAu-`sX|uk;hF99)@dK*JjuwWT!+~htHUK56`OlN7?bx`w;F1ucH7 z`Er)0FNxgP$`FEo0YteR6;G!shy6N2aw5lD*tkBavUjEg(&W3;1S{J?j`HPdY-lC0 znHHY}hDu=M8gvyq&K8!0yR`$2%9Hc2A!0lpn!v?Mi}fG4%J)w4?}SeR(cR#|rvb8{Xq zmpFzY=*H;tYlR=-`H&3dldC8EB@h5zSsslWV!v38n=2or0*_x+xR)LoPoFb=r z3E1&?>s~8sfG1B$x5Ri#;P5ozy26=u5KzJQ3yKJk>Ay-{V=+j~vr!ybU?HBr<~XF@ zG;Ah%kpAvDza4_bFI`4Agoxhe?N?QTLrt*q?A+t%j7Fd>5MWf$>w^Kt!t$xo4ltj! z;_1KD3_hDt?_M;0gtZIj#jOt$bH}>3zV`LS!c0x#m#-WNkeU56K<7(3yt51~@HNc^ zuPwo+e3w!n>F%k|_I7W85U`% zZ{fzx;;xjqcObe@9VjwHfR#OsB@&5R2)En3kgiz-ColgE;$zPxUdNFPOVV;;kFkO0 zG-WO%Zszj}b=JX)=Xv+bIjcZ7rQ9LQq8D7`-k(cIB0&Dqi9b5zZ$X{$QS{*Bey}O& zb=xs*1TO1twoB2q5Nl2P-$&&d_>vn@T3y@<7p@36vyNd1wOLRs<*NaPUsg@mh(6?I z9j&~;&|5g0JIO|n^%V5Kjw)r@6~{^DH1+~J9Izc9!CD`42X6g~i2+cCj$RVB=gP8} zET5j{l!ye53A{k5CZUb_>$+alNP9qh+p}B&9d)edF?rXeSp~PtaVMAxNnwNkbZ1Jg z-2g?~(34s5T2TIx3+~(M5j_%|o+pa$;Fq+jb8e&VICh5Xx8B?x(02oueoYrRA`E)% z7oD&uf6+PGCpVyQTI%>UHCxb9k{D$3CY~ofEK6w(6M>k14?mk}OH8xOd#*-?ANS{F zYW{7L0k|7>Aji-Jz6Kqj4|!$^A2f8dgT4mi^9R&U{H~0L`-vVIGZFrf8Gmxkc}@dl zR}KEDFI|Dg4;IBube1rbQS4VGXaXE;Vlg%G+Q3khwQ8jE7!u$8<_t=31e$aI+IkP# zfl2=N>gIM|crJN_YFkPe?jN0LT*~u ztUVS>H5dzN^PU5jbUdIT)g$lYY787mwr>~C49EOk@h4{14Y8o1mSDV*0anzN-`@J4SVM}>tf6?Crj+Nig0HfcJ+)m zm9hzLb*hpKITwwKe;LeM1&3gZ!y@|{+p$>3lVm^j&SR|UcAHAhAkEO-q7j1u3A97}33z=h9#U#(Ln_#(2U0V?Txhx>SW*Uy!3)Nn4u0F$*E&)rw zOCI2rv%7kg>(6massWp*1_P#QW@ZQuK8w%X*&clKTN2c=?d1#UL~;C^HPvr)X1J1B z?A%QsO>DSjC-Elh4rH+A+w<^A!LQiKMH4oCpnSKp`|Y|He!xIkR`LBda0-=qo8%xk zel#gzy2ch98_I`hti*tuC9a^m-UXlQDzfS%nBoC9%z5axF5LVYO1?z&v^vGn58b(A zh}S&DawZk;Vex+c*7h2Au->P*AfxYqzhERDGr<=BloD%_N>c^iq%BAB zclscEQWw22yold9Y4_gxt${zcMB%jc5ctb4^y`hIFFv@X!+GZ9bC_IredE@Vj7_%g zq*Gru#@<1HEAH9$%XTEpR%?A=faB9A^=*nzgIz97YRN5atSE{@GexDan0d_{SG)y$ z{Ia?t`sgAg5JSH?0mpV-lJCLxmnujUFQ#F}c zDvp~l+$}|W_LUw8oxbeHJg<)Hu!4?6mpyhZjMw!G7X>{xS|84g+xXVeR}4y)2v&xE zEbn(HgM5Ybkz}m|DB)5Hyyx;1i<>L6^uBe0S6lSV`+bjacgsA<{gZAm-R{w>`dArG z+16S*i0sMMoO3m37Ptd#uo9cDY6ySH3}<{=HGsKjRL8l_ON4nfA)R43j{}s!(?+skMUIYX+31#5_EOuY_HH zuLaTn9Z1s1M2GL$L7kYP8(e*c-j{A30O7KZrW1AnaAMgkYO9*N54|@g4S{>o3?-& zF1>TvH%?R=lV)9*E?Pyn<(C`vl8y`Jf0owqckKp#iIpP`I^4ngM+(IhEL?EdoLoux zqynyxF&%?pH!N&9Xl|(DjlbS!oV=6}faS0CGaXs?#+7uDR-Np2mJivRV>3VVW)$`xqmvVV>;fz?FBxq@t)TLv@HHFpM9gqON4e)$B-YyuHJirw zaDqf(Ul=)e~TyvLL&biwVOj?yU!*dhQdLAq6 zIynhxwFciJ-Y>whvw02V>=Q)3a{2rufMiS2G@KjdXe=Uni?#en zL!?DUAm6`k>xw)vhiOIXIhnqj3z_=HkEiY|et>!Lm;BE0|IfZyX z+=l(c#`9__Tqr@9ZH-!R2fAM?R{ywi21%u@n^M1}CguQA+KU)RAjWayN7Qna503($qj+dhY(G3v$!;hh`3lFT&Q5oce1s11qnd2e2auZ3lXFjV z$3YyP*uK`@hE&O~^YdCuAS7}+ZepVgcv@FJ32r|H|HnF#_g8*HheOP@*_R8@DBQhr z;@LE0?cD3G9GC_HhrapRBik^lu(PkMcL15Q*>!%G`2&ABI&*ysegMzG>d?rX{}9tt zo}eMwpU~oKcH(;nJL=iB<6^EPMJ(nsD}#SOf(w|TS+8LzX`YxI*d>7GEPdahj(%9G zin6V7ABW(Q_1YU>2cgu#^}oK|421ka`PJs+|8z9qotST(c*8A{#(>M%pc? zH4UE)y?2a>-bk}c`T835!SIcc&auR^0q^ckF@2^Wp0l@@&E8xd0gvyO>s>|0z-)>{ z+k(gwE?jp!p!oGSRR6eV=1TbkGBi}nvI9HT%f2?0MtcyMrh1K!L0%iEVEqh|9^Wa5&ZAveK({Bx_YTk)((zw7M4V zlmr`eo-M-T($T{mMDHKv(I!K|asn9j<#q(nwqo~s^O}ne1=!wnIckux5yadxaavL- z6o_hi%C3jQ)PjBaf>svHSbb|72&x8Ed8L!eQ3<$Yh=p6cJp$8Prd8M6c!7%xY1Mxp zh=YMwm7zITazVtfQ;F+DEGXR;GHq|L!^b(j%mX9Kzm^d>w#!!@K1+le3HrCXdj{Zp%aiOT1u14wXJj8^2*59^ zNtGhDFc7Xv*7nkO68$IM7cTc#15CI$UdWFII-IOOl>G))YG|pC2oB>_P6sc=e2lf3 z^b;f$*Ks;szsQ@f1WaW-vM8pN0$W$v8!jz%K#A80%Li9nppz;89Ot7~SX1%jyO)_Z z5YrSXCB7eqX%LrrkYpJaKkN}W>s^VnH15?*dPU=BuA+h4hS|7QOF;KE^b@`7ZZ!6<$0< zBL2d@1z)3Rrn}Zo!0|R&|ILae;kZ)jTqDQ*cQ1bJ?;QWtiZ3uPgF#6OuH>N@Yff+7(z6){TI=yVNodD>AoF~81!F2M`N9(aUL03hOTLyfjZc0(_^@24 z9kcQ42)R(L+m%b9q3P+ze zW%9?omurm1h|k%BTQpLPFQOnf=(<;xNfKUBK9{e=l!Rk$7JlnK2G@2b1L zSqTMNYg>-58!*@VVCQHKKS+1Vb=_7aU{)d5uZ&7X*df;<@Fimx$fSOXY~D--Sx*5r zap?i<{hKe)GKT1nVf>M^bHD-e`u^P9>?r`h5W)?M+;Z&P%zS8fSR6OfDxAL{aTjxZ zFaHr?;12QT4}z5cM!`n-OoTAqOKhjWKj&y1j;{{oag#<^fHDQQwE40haDVwYAn0-y zZ?AEkNb<77(%PrhLq%S|s|>!%n6`ZQ80jdHz4;smN$gw;mNNjFLpx5D#N6+H6a8{Oc zD?@j{o$K&^!()P@_daAVv_vz#e}r8+B!@|=pJ4eG=D4YQnfT8wL7KlLR=^b^%Quqe zhxgC^F}pXN3R5X$GW~0IIQ(Cj)Wv;wY*s+QW}X%dBB?SJDqVK?2CKpLnqdH_e`ktl zq01$5hZFu&I8cEfkcM5q9Gi^SzP{EP=6ha&LwBPeAKN5H(AvRH+z1MX3MqCZFUsVj}XsOX=H#^)0E4dmUj zuzhHw^Y8R*Vo#>c^eE44!Z{;+Se4+J>AMB@*y1W(h^r{c9e z{JWJk9J|tLoPX;R1!QEWp)@rP?_E2bUu_fx96GN${@G_^-;$ua0N=zli<8gn_EZy5q8{Uj&9*QeMF~%Jb(OoU`#T-X4iz#N4dtu5?|(Fws9$ zjHCQXVxeraV(&L9fL!Sqru}a(;X&Twp+*raJXKiw^?G^^JbCx8PX&zdi*~B(p{ozz zgQAEq&&U&8JFxtAKFEp4gM74hN?Z>Y&UvMn+jq*_>V+t>C`_Hk|ES?+y!oHyd)zfwy~=g^M;>xFaHUBK}i2PVYHbf0g)pPix*! zLzklPb?I!j%g(RxQUhtzE2Vz;GJo>NrO+1mb;C4B*!&JWJZyW%f;}7RNzD~$8Q;Ux z2S3w}J(`4z-x!)D{5jF(^czQhv>rqci(~JeO!@=b9a0{bSq`G$<3;yr&FIkVvdU== zB8T=bX97yZ%#Kf>C~ z!fgWmK;yiu8uOe1`9@^Mha~iY?78m>4y%XJMFr7QGkjxEdvEah2}fRZpTAVDxAzk$ zJtp%Riob#024d-FL41UTqkb&BTM~r(+Uj9!tC~od#4BE>_5zCIx#^s##)NXp_vEY{ z4x-W#W~>u8*x;je-oh(b^3*AF{+Q2pFo`F_t9u z`W*Egt~WFSVTYvsWWfPM>VG_s`|~I8W^<*E<>5pZ^vR{q-g^&4mXoSYSPexd>T;+S zaS;?Z7`q?-Cqdw_>jpLZ4Zhy8sw+)Yk65?4^H1YN%(Z(B3kX{ zDC!?0M;R~dq!e|2u_J>`a;ZUYtUsB3T}3 z9N!^zBUy1`gB=mP4(=RU{{YN4G)|N6v7r{0r>Z{|o58Mhe9AqV6g@Oa6bRui13QMw zq<*m-&|)@!lXR>H#@jbPSTdeQ%l=Gd;!@3EnmFWC`$Gv?pN$-r=wTv6=|)mDiir{~ zmlXMMUcG`$Gj{7F7C6vO2LpXF6FFMGwQzMP=_k>DO3HZXusC97rzVZ0AwhJHMid{3 zT}2AsnJHde=a7G!M$+xMD`>2lJgYgv3>|O#-sDN%jZo3 zUv&>WrgLX1dqPP_gnZ-gCZFM5hPA-oHzOEQ;*vK5X24gzQ6%i&BA&dQx!~dV4enQY zoE*z9hXx)+p>6geSWx;mq>VGcF6PvesW$|CRi??g9QlLPDNmh<_s^jrGLW927J)yh z&Q!%~g~N0-hpQCHV<3;PwX%l+NPenba{Qb;!ROoIi%Q?QQOT)7n}F0V7~|U+JGnIj z{Z@O`_A^shN^Hzb^T{Oi3iqxuvmZh_QNHof-E)}q&AFW$dvBmP?9>gl$b*E-PBXnK zN^>B$de2m^hzGs9OS!2)(T%mwS{WwD4?>LH#jxP-T{!8Mir(L9e;oNqCiwDh8!l@O zc30H-1iQtJ#~-$p;FbmXlV?>g%yCKwOWGJr6ui=rS1PZUG z=i-d*<&tia5cef?n}2_}bbysG-5*6o8Yn_gzO!<1^mQYyNwQm| z^)3XuN!d87|0cnaYO8&p$U&vpHy7{`=cp?%$9ntp*vXB68zqYot+^h!`-sfEdk%`c~ zbpG0)X%cQc?B{DP{{$BqCNrEE%g5I%#s!bf`#?4IQ=@#HulSeW>8-SKY2+%%r10O7ru(t?3cgrSQ0l<^38!#gt*d5v4|Os%DXUUMCkUBP$&LDtAY3@X zsePjX({D^Vuks#12VTl_^4?#;1ZP`cvvEE`KI;dmGrx$r-m2ol?8kZV%n5UqpLSrW%jCM5l`RfC)18`WOM&7 zU0l^VV7>a9bI6t$BO^U+K4)JH(yZjU5BIjv9W5Sy8Sio&2evP))oB6^`B1i$77yX( z{ic2&{g*)aI$asRaS!TEC5Lo>hrz1K(7ibM2{dto!!YOm5NI!o=pq&Vf~fYRD|ISW zz}mIP=k*Wg(5Ol(wNVo8e65#15*d1oa1w^tCj!3^E+kfoOrQlB$j61!|E)o;89aJ2 z^>av-eZT9CYA^5^`IP!)stA13aK2z+jJw{A?@ZRbKhBS5E^w)#1l;!(8`T%}2H(HD zq>{LkkA&;m-SFTwRr;=xNI2kbbiT;Ig6Xxui&r^}1`Y^cxXk&hCyHa`Uv< z*+;`#+GKWMw&VTx?cEK)y*&G?I0&IDVe#Aa>xDp^xb=E0&Npv&r&TX8?FTTuJKy@B z?HP}tT^9`Vl zxG+r0Hy3mfq~P5q&qjpXoaQXjj_AWREADLbTHM^TV^5VS0{Dr(SeC%g1FIsBsT=#F zzys@n!iyDI;F=Eq{x+dK;w!ag|HHhFs+4bu4=j*jiO)AGesE5rI!7Agv*QaWyduft ziXH*fstF@k`O=HrUM4-y6RbrS1XBKU!}(iZzi;Eu{oD_t8FExYDb~@KK&j}n_qWj- zdu(Vva1-%bYAqsDdhFfGH!>%ZQZUNjEtYKc1<=hr^0~7)3beglf4U@fgWUfv3_c_N zh7@xrck~7dz>f%q1=i?BaD!}>YIPwGoV}gDI~m)B%88lfOvq?IZ8 zW%(Om-0OyshJHvwymY)tp&1#jjm6LKMuLrSy}#=b#USE*o^x-e8E_8avXO580jgVT zqz0LcP&onfKhF2m(DJK&N7f((b~91;`zekq@LRCL#U^+V{U`8m&7<`MP}+q0;tTYH zzrAuCp?7dT9y#6$u>d@*`{mt$aFRj9VtYHborDR%#Cw{#fkntYS(MlO8*iQP}4|1;*bn||%!`FGe-BPn*@ z;47B&0iUE>=qHT+cuW5>{~E?$a$H%qunLvhbUW$HNu;gwwbP|{FG~|paOD}g5KI5I z2~>F87yxZv@~1_kItmt1hv2bmIOcW1q zZba6>4Q^iMn)B&UoZ!odAZI3Y=W0!RP#BH540L{!YTZhmhY!?6&VHOO!S4SsdtA@W4nx91q%}TRV#`f1XJ(QK`t*89h>_?) z=KqSwLU*5_n?+OPyf`1jvAgB$GmEQG?>|6DveAtmAx>ddK`XzS`sEV?Y*Aws|Pgw7mUiZ)M2{gD>34;PFUh+qP(8#`mjFSqMb{KAKnak z>G1UW6DX@>v*Y7w0NE}HU#Iw-glYE`EAE-ThIenDENO~WL$Xz|>3~jW$Qt>=-ynYE9>}!X(+lfPJdxyC|Vppi&{@Ow_#Ts5}ky#bL z@CFj;pCP^~ZUwv6E#4+sX}}WV+3K}RhOq8$x4Bh0GmJb~rV*r2gPf%s`2Tq4!MTHn ze0Xwn*e1SUDAVnGP~zFJPXCG$#Kz*Pi_T{ulY;^(!=i5BqdOtK7^4LLg>K;Y(-_0x zyQUL&$#C4LaHqB3Ngik%fqy>=#%PSx=_@yrRd&;SFkIZjXkB^ z54zsu&A=MdV0G-<)9jbQa7(%O+Gune?sL`94;!b!H(U}?Zp8@7oxSRL(AW=`rn8vb z{17BN4ZK{pcL%2Z^ghd{_zD&Vn}iK5e1SCyB@A}IlHv0tAv0pm4CwjTCjH-T2IS)! zFvOcS#aJ#Z^6V7a!Y?DDE%##Dj=jq?6L%6ngsfj zCO%??)@K7-B)u>-=f$DwLkX;~IQqFdF|I;CWjC?cal`pWiX%^WGoksm7dtC|I7V1S zFnPN$16~n}Ei34)#l)2aLiui0V$5WBjg@{4Vp}SE-U&o=*i%_1dHd-B>~J`RopnVO zMmU;$CVc${3+B7gYP#2gd0s4OTk1)I6OB!z@5!q%m5Mg@zSm(ewp^G=iSQC8)DS?V zTKNo~kLs7**S!H99uFxr$z8x!`Lu3ic?|)|J%8duV{$0-AxNlfmKnP>IH^zM6WD-RvC*k=) zef-vQgPR_v28Glqf@7n_35l4F;TSUj)J8)Fld-XS^S zJg`|W_lBCQ4df*3o@Yv*0|jUI0#5iCu$(2?y)1tQjF;f`q0kZuR=hu1$Shw1nq!Pq z_Gi9=@XjBU9i%v3Mm{U?i*|sSnB0~kU$zAfr*U5izdgk?PKxJ<@5{jNf6lZf)GEL; z*UseiT*b%E$vK++xvmG>W}eZ+E89R)?ZxspI8Ke|(ZB*VgCS(5AThLP{tT03Qwp1d zT`)T1R#5B~jqRit_A;Ew!b0wTO>Efyh}~7M-C}OX^{-;}*^9cRu){%_q{x?^@ENz? zy>|7_@Ym0G3e|cRn7>wLo3xT9T+P&5J;r$f#Ae)Q>%!HsPKruh2fimzuYmF6QsaHh z-=uAoaDEkNNj;t%5hR2TtgRM_M2cAVRjRV|_t4tYULyT*|6 zgvJf>Tk=jHKQ)BmIo3xPr@mIs}f9`6TU+4w08O+$wy#7DH85V9 zqjj2$uL%G30VB_n6&84~uTgSng-MGa`F;5;j~V_P*Jv4dg#EXu*qw8vg^dYC6A@dv z!uH$S zeN%{y^hOCDrQL##?I(7H)=#h()Aj*I4*8gH#P0nXnkekRxo)s~E(W{P^22tw{S$W4 z-IId?7axE1plN4gRS~nRpW}^Ve}OSDNhyx1^JDMxs@`0a!^0TvK6QJxz7MVo9b0>; zJcdNOUJnBa?m{j~Fn;M94-mf45h{WD(c5c{Pic&_;j^7Z*^mKy$o_UtSyrh5Y*|Dw zH{1_{Bl};R*9qJ(N>-1-9>TX+Id{aLhZhB5paKy~&EYF3pIeyvXV?>~ma!!C)^f!j z#f0v7cLl=M_oU-0vWZx8QutV-o~tAaySf7W$n{YSAPWhEBxB^KX5^)=vr>NCeEmz{J^2 z2L&6T-;jTusYnm_*}iqFZ8yaAsn+`6iC6*&B3UQ(zxF`#`Mrt7G#`){q9Dqh>H)T# zS=jcKJ;06YLA2+^y}(cAS1CNI!9bzU{8vQGCm=j1M5ss>27auM9x60>fwj!EmyeeM zfzzMv`-GVZfNCy8PQW1tm{;w^3y-l(Z%acOe#d~V%Wvv1 zjTmsvrpIjjOe|<)i?U#lhy)fQIy-qG5#V0%=cp$JDZo$voS)P4G@x*T{z6ykB0;n=UN{-*n43yKl*YXzB?+A9s1Mt#5G}d-gVP zE=;|2M@j;acN~YbMc)N89haL&1C)U0_MNp>d>x>H)5|g>X@GY#YyxJy8o*$F$Sr3@ z69|%1*(yE5%~N89UP?&Y0#ZfMjrA+9fI7*KubsJCz-k*cwJGR>l~<}7IdANM$F%!c z@v;X94A*^7yNCN7S&rpraK8EA6jw45DmPFjrjX6SXAQ*8e^vNeX9a$l-VT?Nu?B+& z#&(xN%>c9RS$;0z*Wd`Kcj7BKfwuBrT=xiEKt^y)nruzI^~Fzn(3=qcKi88+GT(6o{ui%PMsfMmubI9alT1P$)@IYUPGPKc{d_gY0qq_{HB)5$Wh<=7q~{_ zTzqJKz8O`hPC;$`AmOxg&iO(qep;RA{KT1hc<${7Jl#d9qQP~%pff{KqdK)qHcNPD z$#chE#DEB8Wz>a8oyol;3D5LAe%a>AnoTJ9l4 z_|jYT4B+WX6YXV0_q`<4YW*hqwHd3RCR0~%%&`T&J--H#32zJorBf31xSkwR729rduXIkg08Ol zA)?{meTA2*i^RU(RF;p|M9*D~rj^cWBKr3>p*}6zhdKgX8mZc{DYg5E4}?nUf_dXODrTl{`wX@ zC^h)fVCI3mlhp)7h-^_;{ih;zJXr&Pbq=}g*rn0+wc=Pp-n%Fk)9(->QAYpZhafV}Cn#1`i%Q^@A?w9E=;JW^?d;HzjuErk17BuBAWRICLi?MI0e6m(Fd)aT+n098u)9t7G`76EZ4`xnizthj<3EuhGTZpja+SB@to|gr^=qXpruOnpFt2 zXZP(;9Y;<|WJDP99QZ@7G3AGtmD8NG*dh_l9WY3s9fsqF6C9-1;c`75d_yK4si3J; zZBPGp9td~$X;)K92M@<4_b5IWfGJgEB2keGYB*wk-Sa8}#`M?2WcKpGb=o`fcDNj` zG@Du~#8VDjh9BZ@h*yEc^IT;`f2x7!d|~*Rrd*H$CbZqTs({Hj+qDseGVoiZ;K@;a z4zL(6xZ<%=1o;EoICs@z@IGNNPF*1Mirg*NaLus(D^z_0-oAevfG^|)WIeiVGv-}D z?34RCsgHfZsxGf|&POkh*AUdq=i-ISeHy*u9_tB;bmsc;13v(!V!mdjNAJOTfi#`7 zW}%?@DWhEpwtz-w<1@mt-mfG`&4clnI>QXv#j z-!4?uca8;2eO@&8PH{e1x)j(V^$EOtJ;}vo8VP+*TmZA&{d{)G!Dvvqg!r3N*9g`noeZ~&gZmF1J0L1yY9H_iDtNq z-g1S#Lvc99knc?ow9W6I{Pux2lDkMoZbIRLK9`bg&HWdS{G^KwsD=ZOk@2Y0V=*6O z@1&-=_}dG0bk1KUE{{avb$+FE?Ez?lz*qhWWjMNRUQ5Px6pnUzdsTgHJ(11l9w)Pz zaI|B}@t}PAJzAox#0H8Q@B>0pT|0_-xQY6Nw z>Z9m~vS`jr5bt@QZ+Mc*0RllN<2zdk{<%o>;KH>y<@^4qEUU-bY(5Hw#wd2Icf3bW zc?M5e?kA&aI)Xg;TM+a4Br@YENQAA_;i%Ql2M5A(Ro(T6kMG%@_suGBjm*q|!s{@e2+Cbbd zx)11pc(@|s?MFoTxS8d{X%t!*B~+Jr5`%aLa@hoP!xOYL)U;YjtqZR9PvSk$Nv zl428l(MxGFG0AzC@x*PgQ;0^+?o5?P@D75RUE} zOMGcCN<&LmD_e;g!Vw!e#kFPHbYv>ut-q8Rfqwq%J=PmeL%IV_x9?7eAa3bl$vnl+ zsQhQ;t>djYbhw%v*vA)-5KZ!fiNpw0L%Pu;%+&zWvF~kvIBLPIClwTzs9QjYLxrwu zeFOM4^Knxf$G7LezCBS&X#@&&QJ+^j+khwI{c}xq2*g}{lu8uZ1Z;$#a5{1}152Ln zAJW#%ApJ zpXcVuN&tBS*eM)jrLSrPjYJIpRHi$DdliZ7l0+9^pUpVK`k)6`WJF4D{^|tQ1CdeO z1AXAsSZ6(bz8M&^{Zv?%jRbfEjD-B;VZi!WPxy2a=WFT{5%GwL0k-aJ{X=ilz_d5t zT&GJM&L6}s%=0%1@G}|&stJ4q_&Y*b_yzIc+e+Q{n)O)Fub*uTJrV$8ubP|t%LMQl zzv+fUVIpwhqdjDoive|AM!agc+yQ%y347|vXmAvwi?0?E1vW0G{jgz<0hb4&C;Iw7 zgISvy(cf;dpk{XPef(l70P-U@UxbDO^%K5Fets$7HC_<=?wbgZ8<3T?v>glB9tsCE zGvRb9E20eaj+ub^r;-^xR}%QUP&-Rzod#|I&-JC{WKep@_?^Hd8;mk+(+Ne!1J}3Z zk8?!*!BtK!>9hWN$kWMai1%UuKuFR2H2N(lWMPMs?;{X>c`on$4HGoF(hP5seFTE8 zA1}UprvNyD)VUh|%A?ib^}kmqB~b24FKvQo0?6iDP+pjdN6r;lGZF72!Rkbg3zu~m zN*2*QP5Yey{QrD8UUB+>=o2MfuSEreKGF2oA342{KkMYUj-eMQ6nd}DMR(RTbdA2VppqjL#RRESWPXo8c;D1*qC>q< zRR8ch`oS19VxAuOnD`SeFDydB>UTVvKYj4K&^80nWZpS2BuzrHB;$;Q&lAuPL*R>` znh4ZT==X~mcfF?qE`BK|4jr=?ib>s1M4{<#e=isWq3?KY9NEf+sK=JPcKlid;*9@g zu91|CjDO_}Ew2S5ZxttD*&Au7e>vedd0ixWoOAap6)wN$S@f3LW=9yhO@Bp(LoFN4 z^d>6@4Wyz4k-8EBop2O3Y|PekF9AIdU;q1I{}XB{P5HoS8jZL`eXQv=@{r}7X!f`F zJ|I>%nk%PN#ptC#7nu8m(?3Rbk%S25BIfzrXOHBg(MRX<9~~T7Nb&af7bn7>(9+&` z>ydvtS{**Pi^|i`tJ%lkws0cK75Et>Tpf)r*=BzG^gSJs3PxR$*G)n^)NYHr1Tm;i z%dF!}ax5~zcPBWKPC`B_QTY4*sc3lZ61NdQZr&?G{&B?Z6AB43)_E76hJN->n|pSA zLf$$Yr@fky=mtsI>cPK6MDu(il%X^g6qBfQpg%eS-856{p<8uN5iN@>_~ zVWJ$dR{ZIAT>FSNYw|Ff%xiE9VGvC0D695xA?7f3&!54P{dZGDwW27@-;2&( z`81&Nii^r`F#{Nc@U@b2#DZ&H-=$yyOR5K;A8GI_cX1NI=qFx3Am?7Mj)kv;r3?jDDb?2l3gm? z54c{b4SwH`TQB$&_?1q!==<5nepdLOfl<|0xi7;{fz`w{(yTQ8}An*$GDT8$e~=YB*pzPGAI?T&hQ%-m}DSM3Xb&U`C_C?#CTjgmxFS$ z2*!`pcA9F3^m z&~&94OGPAP9d0iR{LLR+9U+_$C#JQ9k{ zYGS25=kJb#G}5q-cDCPum8NvI8|NU7w|OSB6{m0b#0gJS@uq?G!y$#a#$jN=8*3Gs z{{v7~KWGy9+6~NZez0)!9RtcQ;^!u3N5Ss=$QikcVX*a3Ni~CW7<}5IioS998yt(O z$p!9Bfy+D0+jn=T0oNz(Go|v=K&dpeDA?^cFpIFRV6XWF>|YZ*4u72ougqu#StW5i z>72|nmv^Q?li1=pCXGqp!qTMPq&Nk7c}DMt`i}r_`JLuB?!Q4KO~B~=;3;sy0_I=w``U!lk(zU!CX93rd1>;t4Fppz@G z;zvOti29Tsz40&;Xf_XsFqLKjy=H4~>xKqk*yH9haVHxveh(FF=vqLp1(Y zB@ks@+PnuVK(f*c%$v3myguIM{4iGzWG@j37YH_ktwi#cpOmI}d6>Ot_kQno0v5->2}D^?)d1UB0|ZnTZo0(apJOJ{{bKs-<+%A1;vra;28qQ-de zFWT~I7%u-5UymjDR%$FTVtZ#;iQ^OgSUwf)A*KJ7Hf3H#p<1!auwLl^cX%+jRe{Jd|&lwzaUb@Qc`=; zK(t5Z#D`aFgR3K7lisqFMO)u$>FZ>2P%=M*kM>Y1Iv482Pac$sY&&DO?^k7_S3i>p z-e0Un+sX@K*Gh5UFHlrcl(7L_YZW^YK8Qz3l@<3RuT`Oo-)j?LB+eI8@x!lQxEiI^ z=?6*iry$6k-yQDSj#gawZQc!Mqj8D{!)+6c5kpEr20J4|ah)0N-fdj+scQJ{ng`3G}aWwbd zldxu_FZ*NSiEtGX`exgAakw1mn-K;aV;M*syW5-dJPUa&l&)&|m7>dMf;KPzEJMRQ z+6&)}aQnw#pf+1z7MiJuv|jQqLG~>}b5@h(C_MRz#9DbKB1s#1s6e_`h z&|=gmr@*%f#x^9+_qr~Dwd~B`D*Qzp&toW5Z4AfSO)M5>Bw7dL1}B&Ed6oeE7kuOH zrB%SzHpkA1r<@Cy_#xEH}}D#L*nLovA7xi=zxQUH!@s@{kH zZUY*3&VGNjT7}~t`;04KC4jL(fR7nthO;6lKgK={p{eV?@ZfPC9l zcq?B6pwv5VxKUCE#?oS4Rr=Bj?KWK{eeyWa5GTb zyi_D|z7;Ii)?WRzfMxdeYDE7&^5j-yTs_x4~zzuJEx+%UMkW25>OY}B? ze0Rd;E|p@?|BQm8b#nlOs>V&=#}t9lB)5J3N8KQzp5w`Y8m{i)mGS=(-3DGQQpaD% zVaDq(U``%2HO6RhESU75{Nwi)mbHk-&EG@_`oOvTI<40LKG`ZmOU zL0bZ1VIzMkar^I;Gj?Aw#Hq?DWj~Y#?z4vHxay{((LZJl}^7fKLzGlNLkLJQ5DEq;_#{{;IDGyC5*hqh>q7(To=D&B+ryBGF$HX9L@PoS*0RyG4e;a1>cpV!QFI5@Gzc8o?L* z!F|~~Gy@&AC@AD+aOdkrG-2^>XXF}AS3Pv)%8zrMsCKG!>I`Hk8O+&`i z=jP&r8_`@&5eBtJP|f!f4Y$(;S$d@+`bzfhVe2|% zx!8Md7T^?cTNVe)gO`-EUS_buqjvqi-lmgcBofsOp*|hlR zdI$RC!Qt(TwINqIm9c!;W;Bs>r&Q>9E!w)%Fj^hZf*eyMzuH8%qqJVS1J}^6$b8|! z>(3(90@8A{qL`m3F-Q= z3ohj_(KS^cfLB-flV?9{0)8W5fyfu9AWi;>W$wKdz#evK;lIs8@J|(wiTURmXi{YJ zpS4^B+1iWehdfuoNm0~WHtqv(8}TV_z55HUo5v{*9qxlVf3;vBNYJMo$1ID-WyKmDS0_{qBU6rxFz|WANf{*Su z&@(w#Hh}X@3y_;AoHfORXYhWv*PbDVJ)Ze(BN>}u--)+<&w&j38_7ww(hdM=GD+ST zUlO>hS}^vUc?;+<91RmOk;1mV4_J+FFBo`s+Me{I6C~e>y7h&55OkAX#$RCR2VbY@ z^@}}m@1Kj|xm6ATrXb%imb(MMo;%<)2uOEZaD&jaiOdl=jwrRtAV^<83u0L zRebMB+Y4f1;si(52Ed03K9X^nZV)DO$=I260KAy`^h3d*3yeR!*f=uL0-n2}VI|#O zAfrAeQoI!kF3s6}kg)0kc8wg6*>)7HRO9hWCHDhzg(rT5QB{ESc5Vi%bqf$5P3rD! z`2iZAhFsto#Q8Tk7$>K#N5GpU$@oyY5g`3xjAWE01z0|!ITKhh3W9hpP&w8$f}L*? zadmemfbZ$FtBvazp!0Y*O?#&Y#V{MaAjT^Ne3cFyvqYX~I-^Zitf3y5iVjXb`-97m zdb)8s*-(Yd+BLG%`CF0AyDW_#nYn=e4J*?$zb(j)Q=&BIO-1#2XEMjNaPv0X;84PV zVK7{k98%hl3GTY0;E3!|v;a)!y>m+u*<_O3^9tnaxbQU;W=`A8jdkEZP{|>p_?WmU2M0c4eUZB+;h?iS>F&> z$KB^70mEoDYCb99_Ge`K=$_(p)q3Q&79xA2VgfXLu#~#!v4HbyYlzBR#^n+`YOXw6 zX7O?YU17dV5mDQT3_@2PT?uYLwmDaHE|s+-{`3R5M;wJr%`W=JSG6K*I=kidgm#p< za*x&UVk1gVi%zwrYC}Crvi`K0J&15h;=NVp1afDd8M57ILuPlr@5Ba8BCdqve{@?d z=uJYh*K6}U6uLoVR9W4CBnma!_b)`Dvic?ZUyS{z_jWK-7HJ=<*JN4_xjumIoSyOi zwTknrY&{3E4y{NVzuHEl;WxU+`8D!A?85b@Z7$&vW9ZQG&g8;m5BfYOHb+dAfg&ln zNgo;xppR>Be;lh0;B?{##BUl$(bZ+D8-KnM!SdWLzF97ukI(idiA6gRTznmpzW;#; zN~hsB^SK=X-9PL!mHJ1(wk>0^Id>oU1+SDOOcTN}8I1lM`FCLSz(FZ5U=|c}lSHK6 zB7|S2_dj28{tGluTc0vYZG&Gq5=$MpzTz9oXL4c6q)^3#$TE`U7`SB3kB2OK;-|Py~CUeF6E!-2bxmDTk7xfijwglV?J#bfifq&W$Lm-@B9OdpDQ2NPX7;T z%w?&*E7}B0>;jE9_^!j|2H_>y_CJ6`*q`nbMhI)haFRXUO^~nEr?`PJK)34;TL~6u z;hXD%zRbfoZpoy{8P(D`5Jo2YDe>AEIHcq&CmiYlI}7eTfBueu|3XAU#8R8Uoi6gt z3es*+C7|)+`y7s2p`6Y`x7`aO?sbk2Rp9oM`LNKcUlkxd>=s;lI}6?xiQCw>Pv_o(~~e&uz4NxA_C$*{E}y{^&e6Q*-g4mZBt(78!z&E_jLaOaLX)0o2^kdjqP#}rloo8Px0YN0MPtC=@AZ#M*d zcSrk~x2I8L4psIN`ik?=IUO(M!url{z;mh+c(iqddc7;l{zf%}k3Z#aRp3!zvD`M{ujmc<(bTi2M``UOPN{rbe(;sU=v|X`JX-zs&P&|J!jxMS{yE; z-qqIrA3V#KDrp%1A2god=;74746i-`bP99?@X4aUpb<3@ zTusH`qLKKo^*gk1X7>FrB5 z{sOuUS^b@v5x^Da0{W*pVgC)&U9Fyea6!KNL_tCbDxEQZk-EkNnYD`zGF7fZJR;PS zOGE-qm(K01(GX$5>i-nY=3|i#4GE7gK@@l)TTdkU;x8EUIcvq(L&E z8IE?nM!;>uA|Rv41{;*m1#cysfzMt#!V0nyd|nSVs5$Y4>T(qaP- zOY%6i%&_zV1nzdH=aa@kI8{onaW0N~Z9X$Bdn*^szOlXb8vX(9U0qLqJtM)6uxHPX zK^xMr>S!g}!$1uGmn1zl4BXiklAgLm2lZT3?zV~dps6grdo_KGm~2&Z@8r1@v=T7; z`i9Cr`r6tNDZd>7co`f%TyZCctS|A^gi07-r%tBS(Fqgw)`L+>74g7Zx-Fbz%;K2V z7osc2#!H};wm0tzrksvy}-z^3u)6 zxzEpG8X}S7X^}61;=Mv5k$^wQ^mob|jp`qWURQhRe18%W{^vz!WnTyu!iJo56SF{4 zPTFCK$uI~S{G|~^!;Yne1uf5yPJ!Iax5IyT`LHr4ZQ_dqjeyAMoH)lbR_q0z^5H>S z8VD~CFPx;~!!C3``rbHu3hs^tUw&P49!j`L!h&N;tW-)uW8y3!CR$JC-IRO=GFmV+ zjXKc6s9KmxV)6%Z?dcyh>g=I6S1y|gulFEH8S2J;-W1R;^hmPs4I8F#;_S$fHHXUy zEZ}K~s6rNhgju_A{S;%)mu8iGyC~&iuMF++BFc`Gr#6gB#LdshvL8g_U?yu7t;_df zP_a+t3w^b5#HTWMpw2M@Zrs!Kq?9eg>Be4WWv36Kpf}`0W&cJ|LPOsKQvQmolYCYs zIYh91`F|`bF}QvSwb0tA+)a$~Mbl;+-#QXnjgaX)xQI0ciEZB6m_o+dg6z^Ie3;;~ z!30EJStuu@|%6hj;eG;46+OFG+a_X|%l~#1rUY2ibqDQJZ1dmR0``T67am z2D>D!{AY^^KGM0IGhqoc2;7j_1lqt+;wdQedt1!&tKYB*{ zIUV~YCF@*qg9TFkd3E!Px+#?R%sq=IM+$Y9c<$XgFONO^utuT1Vxk5AoZ^U*4jA3^~aS)IONOcwKL8wX3}bAI`%McA@?LmRzEHv17v;$l-3+jcVSS?HSGPfvx<}0{ zjUJXZO)@1m$p{~Ay43prB*Q$9j#nQq9s|=g$$y3-_Sgz}_@AcUIgmFpxKYE%jG4~y z8#3e_1A7m>?ulVhczxhc?|b^QSkLCG?9WXIBa)4Gx}-?}*GjA2niYCs*PTl?n%D^7 z+Z#sn`9D?QhpK0h+HO;zI6wCqx$h&`=SXbr|KI_v>){<2#pRga+q?c_$%YP2m%DdA zT9bxVy0e?DdD8IdM^E3OIbJx~WS7J<8i;i`3hP~Aetl1}OLu|3%K+z2$Ox}Y3+nB&1 z&~4$68KKdHfyNEzu3T$E|A`z{RXnu8j<1VHP^fI8lf5R&$dw0}pTzK5?6pyljIQr8 zT<3>)`x)M+HpEaU8UN|C8_}>^9IV{xj8M*jM%SG(R%m%3 zgrcO}ks$mX^e>VI8n)R<*HwtZHX5Fz`q}H4v&f%qW}%CixL%%yrtEEKeqz|^*D`~u z{=43j$CiRJ1V<=6GjyR?IPtd5p#ydbq#i8Rb6|TFi&QSzlSqyuCfD8S40fm?+IzX| z6gLOV{{8B=8a)4(Oe%-e03H*Ja0w~?M(RpWpHyh`z>0^*N~#PyAf%T+>0SRlOxx*! zXCOrfD2h!*!*nS@`Jz-4}C z$?yNsV5YU_)9Ki4a5*=muQ)2EKw435gl>f`40avr{B>;>-Ep91h+Db=9nWssas4L_ z-%jS`7FBRVa%1b2#$+}uB;nJQgxhy9y`)4*`8ihD@+l`iXp|Ehu^`*o*06=W;YKFE zy6mBZ%5eV25k8nv6r%KAgSvrYT<5Zaj|rq2n;jGvpMjMVoZps)^kL~lnrw6F1XQ`z zGb3L22$pS42ym=8!u0yr35=tvP;=|ShoSR0?#uT1o87S)F!%9Z&ei2;n6Pi3Cd53B zg~rrEtMp3jOn)BZ88Z!x@X|&SNZZ34gW;4NTPKLSF`0Mpx)JEytUhJH>6@>E$%;2g zUx5LQP1gS?I`42Q-#?B^5h}7%5`}Leo22r&$u3z%QBj1*ULiAE_Rik2LrAzEl9ip6 zN_IwO8bW^O_m}Hj7tXoPxz7FE&;5D7UoY0BdieEV_eL6NKQm}(McuB5A@>D&b6fvA z2zm2^qR6ugOgDszf#jp~>?%@Sr|X2sCj}?oWpzT|Y!;R0(M~WLx#+YvzX`l3rxaqh zx5djo=C1e=^Zq-OxzD6*bm=UK(yZ%v8;PN64vs|y;X&f{xeTi zZvINN_R*;`*Z3?-wv=ac2v0|3&fR&`n`e+ZOB?$|)-+@#RZ1J>>4OgO#3{_%IgonD zYCkP&KN5;v*(*%AjYtR0lZq*h1l_CFZ?D>hh|7}9+HSjLa9uKeuls(|e3|;f6wlcl zV4saq&XmgnIc0e>3HvM<+TFiY{V@-|oPQa1Fei(|<1G{Ae^vzQmbM=~XUk!4wW_c; z>GwG)Da`he@-1ZywLY(s%R#fzOH^*+B`nTUvS?c5L-uvDajT*VFnKEY4aE@f`ixX~ zw8|))|NYo(xxtlC2@x!}IWmIHK7Q~XTa86E-@j8x-y@kd4)$)ibY=ZWi1flqsWufW5%gL6NgWlHau^^e52FlhH^m>E6z^0>=2O%+HA5Br`_e-NF zO-Alfe~=Wa_-t>IS6hQ*1gK18fZTL^7jMsh~|#RyT0%`NI0=iz#paqO>fXFIYMuSN9{&`1k}xPE_ChsfoOfKgb zICkVkZj^-&6pzgwK6F1A_N1yE^dRl$zcSM%>uvr=aJ={vEV^$3ResPPK1Rohm_Cgf zhX+-nJ(;(@?Vmb|n0gKRdQQDU3uNONpYNR}YR~fGJo6~zk*Rg<+EZR)-?!e)P?Enw zO=e78mO&q7(p~+$WNA#;SUWiOl@1X`Z`*W+OM3}_1=p&{C1*k@NbRLgM?D%Uc(pW{ zs|}Zgqv&{M1K>=kFI(z)Pk3iuuWTRt1Ww)X{t}t#3T$jTIwF@nfc;3i&YnL{VXy6M zYjLs{^n^ank~t6$4*#w1UfA-2ghu7-CQ^p*s%kF_QRD^YCXX8~Y(^?r~b zbYorbP8`rm){2e$-J9AG|+2FzA`!63*FOE!p~lRA@QVDl!eDX zLdHs$NtyH~;D7YHFL3NDxcx`1!&vzdd`^mt_suT!8h%qOy=vmaTJP19zllB2@~bfgR+slRBZ9Kdp62ZFOYg6G^e z;g=x)L;@oQ!{q@T>q8x&Z9bX0!&V6?-cP&_*i;^{nMca;BtB)W5V|e+|~Vm)?aRe)f~~D zLw&sva#A~*?r{&)@ka^j{P!L{owD~iA=3j%5^iT1es=(U4C6n&KiyDr_d2pW-U7ML z?|$27`vERmC-3Jr?SkY;F(W$h55ViqAsDSY0+IZVl>fA5;i%Mnn%L=D_}qHGsEWif zvmW;U6+pKN`K~WZq`#5QMVhg)&$(g9(R~qyzK%naQh>JoU8r7qndlf((CcwK_uZ@{uU_{PqN_TI;~*C-oGRyI#dCtR_IZov$%jb~L_C z)1OyYQ-GiBq}{X)H-|U%zXj8ZZ$tLq1iyt>hF};tDL}zxg&(z5GX40J1LG?lVRU^3 zc(ihZMX|IRRw$pBJR|EOajSTu8sA2P_LDZ2Z6iAI z)eOAf_eOZ=Xd&Fm{1$s7EE+WFNI|$abx_o3Hf0r)g3}DAkEow@!edWpU43H`NPQ$S zwT%5`IDuLBR1!Qz^?yo>fr>>MvQ@}wgY zPOBHGDV|Bdsb}^Z1bwN1L=nVQ&;lci;-Yx&!PC=7Z3P*MfKHzm2^@o zW7_S@Mg~0a_9)rR&VuEg=UfTr9fACWg=3?b0uGQI`l0mh6`nsP6D#<|5#Qr(Z7FzH zj+b~Z2%E5FLJGc_vMw5fx6>qt5MvDVzIRbqcpQNlEre2?^vc2P#`~y;DHV_;P@{R- zv;j+jFYhEO$hcpb*Sp)Z*b$UqRF0_1+S2=5ws_M!Si|Po#=ft@L0U${AD$g zm;2d>*zKN!NXF3j;)hNqWV&8=*#9Is3i{dco{FCZ1uF0vv~C|ox^r&w9NG-X?0H@A zfI%LVQ8Q|{RvkfA9S^l`svSdI1{4R)U=Qkl{$cpif9tRj{;6>wf(tQB=%|hBk|9(7 zIsTV!Qm9+vszrl41KLpCeRAQa81i%K4do?$zcs_#v!fHl&}NAmGuwI>jM#|y?UYdJkj1-nC$q_@?$V1GtPXcM*bX~7u{}1g``l=^YFb1h*4*qwT zCt$nmcmKblG3XeqY^MAA7S^_ZdU3>j0v^`$Q4i-EVa52TS1vO-TFVzu7S>t=iU%UU zZ(40aAE7@MV>?M&f0jENIDdnz^^_P_*dAp6O#&E8f5I&qkD?Wpi7au#@8(XMfN%8Bm!t(#VvQX?FG&%+^F z7+rmswQsnd4LKBS7!;plLqD&cLL1!%RrLEeXTOej))$XO-eJsljPlHv zNm$jM7h@fIk12RZU!=8#;HWg6EA)CzAiM8ls=~!KeCG1a(U@=RSa(Wtzat2@kj?NBGcDEn1;_F_eTB z({9%pdMYIQp@dpjiHWFWp|d*PUIyX8U*9~4Th!&v{ z2w8hq5V6>V_mTyP3V#}h?>$TJi{l6JE1}}|aU@=z1nY@?ii;Cig0)I*-Dv>wrhTPy zelFm)kPDf&_N+ko+ZVL-Hv=%sY?Wq|avXm4Ri3-+1jZ`Qq`u6MyplL2qBYjF5{FQX zeo^)$aW?CvvNF78aLCuwsE@?0Q|n!ji#OlFY{oqt-=B=avpMm%@*W-dS%?c?Jj)`y zKR=n*IaG-2Y4p7Ynm<9=(V;sQdLtmuTQBA3xfcbVJSTOVbe&AeWN^_VBl*THHcTR& zna~&No%BB|4d9TI%S*5J9yG>^CXb{wVST~4y(i0?FpJ=1NqSp1{$V`)-r!U{&M!Yf z%bDK?z3Mma!{dB-)V505!Pf?jD`kf$DDUERd-1=Sj6*=%!dxBcyb6m&K9jC z@vsPN!H096%g*tq5zp{Y?TJAO^t!YB(SjU_Z#5fs|7buzTshfcEq@cC+rod2xaRzT zGpZd)z1;|4#k(6ut&4<6acg-4QzXv&tTFsQ1Jw8-{%PV#4Kz_++Wo3g2~}=) z>(VAy-#_fr7@GB z@7T}T)t-Y44IK8kjpw1i_Tx7uNdH$U#fmIvNfJf1kVUv3VL`ti&)V9_cfrh3a#x@p z4dVFk-**oBcp>cdL;r(|Kj{V zW=@IqN0HeIzgIMqFZ$}1Fwe(%kx&(V8I|zJpSZ*&zn|{7G?Bh~-GXCW5>@RQzEQaH z3m(*%>)#_G098iSgCBW+gR@swG2WfPV-Uy%~d4XLfDHz^EPR4xQxd%T%jMZ&2bHyBc*RnCodukz959!~!xzTW^ zPoqnk#D|M*zFZdc^AwuH()ZFs>4;exiO2#`GU8~5(avh|X+#Dak_{FLY(zp~@l@eG`swU+xSS`3|*Zc{ixn%6%SWb7T$y@H%F z2A66=Pb1CNiMFF1Qm@Xb^MEef3vQ#HRShg`B!0;0b&pfP6Ns>e3s zDDc?!+Ceo=LO@1#GRdSJ54KHguv{eZs+4tZ#ZCCrMLKrdI8$c z_3&o-g>+T& zC*)s8d2Yr2WH<49~ zURERM&hExN3fV2Pd}FSWX=JYCUH|U(2x2&uwLh}E0wikwnEYmMAYJ$V^Rx-StQFPwi6f54fSP zmhG`B`}QDst2|M9S`zumm6_~uBG5Pgl<&cgG>F#az{O*1g-9%+;iPEICo-|7jC>z5iw1Rv zhjJ>?(Q;x;*lzc0l%XUcpgT|E{i%gU)0Ys4?O<@q?4GBH%5P9$(`W|K>n4PMq@F-^ ztKlBB3rz(5%OrW3lp^%yV4TaywP5&4VRP`$hX~l;fBDq4EkBTc;=Z?7k<=qQ$-X;( z)fWPy97E1W1VQzmVCjwEPml%w|p5nNSz=)Ir>@nCR9z2m|pZm5c9 zc{D+VI3^S)_IfxIpmTYl=DvL+8l4;ng8w)g`NT>Ce$VGQUE*L1!X4p+H&e^ItG_a&D|Hiz77SLoZIqCJ>ab@3?h{hoPqj zCDN(rNd9oTat*nBd0@?3>Rw-x#V*yi`y*F)Fy~1!GD|jcywiA}?uv#qShZ8FSIH~E zSG;m1u$>bW4!CxYc&cL8Lq#k{$-EJ_#4#>U83)we!mB?`I{^)=d1f+~#Ry)q@x8&J zuhF4gflJG;7NGOYspNC}B$RO?|6xNtz3f9j zq9{m-LAGWsxc!mR3W{QjI^$=&iZbIUuSHg@6ZgVLjNiTTLyIEwkqSmlgeWi#m#v4R z79nxp>wjLOWgiQ{Lz#xiWs%jk)3_0NO|BjPNj{8zd_N$XeRYa>Fgg}=6!ytvqI z^q(5E6)7L*=hDX3`{Omw2(p49;gwf=o)JE)cMVWWu)*Dq$GUsIQRBCVMOy0l^zj4Z zb(!V${~*zGJSKtM5S8wu8-Cq%9c{ZYe;akDA{H|i%J+LKm9uAgmUg7H_jweLSHP|S*$W2@hgAhyX&-y@(u0obh)gdmNDgL zDto$+Ex&6wr(6%(R4E*;HUCNEZ08C|)%X*vAC{jKtF;gxk9^v;4wc;85 zmb6DuF^KrF6M&zzopPUf>5BzScgQ5xd~oCEty8A;{`jH`S?Q^sNPKJmR%2&dFh0-K z&n5V<9~?`WGswa!fLC(pO{-}*e; za0Dv-da?}M$ALCCU`@jLGbrD(Qu*dN3@)e@?ySwiL{r?h6zTa4pMQD#mthd9hPp=b zq6gq6?|1j){WCCV`{q{M!ExAo?1#*1)F*iQRa#KEb{-C2ZK(gMnGMZ6hsK;W}XRyOfeLke~ok4M|u^12a_e`U9@?(Jw zlZPL7$OFUA+=EMJNwju=eCm0p#8(<2q~p0v`W&oNg<;5R{Jwm7K^( zgG852i7fj>I1o?baPz)^%XXf(&UPe%lxj)e$nRHR5-+s9Ba#n^bKKGQNar8|Qzl87 zie>O`-08;3fg(t5ln?BDR|oZXTzmX3=77DtL}c{CLQwNMaqIo{LMXO8K_jeN3Hp1d zLLU{rgm;ws2`ptLkoLTJebN}i_a`aWe)Y*?+x?d#BV456knxKHade{Cl#S6cPeK{& zN0=wuc<#eX&eXUTE*+R0A@}>O%8SECPo~aY+mv}3STe0{ppP^6j3*dTKLweo?$7H* zidflS;hy+YEkNY8501uak>(AheNkE$as2uJs`aeTVb?`Zf4giOVAWu(q!_=6FZam* z2#@x{dQWBV)u-KqLKTtjJ)wal4x03Y_@p`RGCRP)8n1xw(B;_7h}we6lN7mx&))E% zB7;-6SrIrYettC%GQw`ot7N(^`$5ll_KTsQHiU3$d)h|@0LxbLYJnd(=rLjWt zgYK)Hb?3@}pgzm@dBz@Cc^`d?2)QVZZd8!?QKb$ahOHbs&q{%M_<`poh7Yl}`P`+o zlUMMz<(YQ}-?`$k3t+cD(j4Bprl<9%8vwi3OC|Nw_hEd9k=K>V4A-TwdD_T5#3xx^ zw9|a@z*1M+OCEwZesCafjE~9@leeUKFC-qr(^{F<`=9HgdOxFj5O10^^{Vl6Ri$fehl8j1Lf59=8B-%Bugk3+WAS{1W?5azz6>5aeKE-iTGb3_f>L-GW?TQR3ayz)IYB0$>Ptg z#9fuIpBXY%;-HM=!m70_>^tx-?vo$MA62PAYfkFz&4*KNr>T+t-h}(t$J`p6eV$*! zRHYbqj$GVGA8o)If|Ux2a~0S?b*?ru=_P*Nxhs*}(T>ZzS{dT@m1DQ%1DXt)fr!$f+zG2_LEZUaFh#mNQ{gDK4m;gdtnu3 zo?cHmG%yHm6iG)bNx4#q5gqHQ^m(8z-?kF_z5?5sbVzJuUPzAn zC$!!;Cmt|Fg?<=S56}Ak1W{XNs%lMg6lOB1JrWZRp{KvDQU9VqWRb4~mm>cGsU258 zFues5!Xb;Xf$LB>K5s)&L51AoA{5qn>CwK=W;R8wOz89Wn>y`do8XZb{@ag%2Tgk) zt7EU*f+?=E|5(xlP`sSg1A9Xj)a9i2-SAK|OqI|wb91zTagA%mp;vWq{dSaI_Uj(7 z88VQ1_O}I2jkOLBJJkSQy1iv4-2lURV&dKG72u~Qw<1|z_WuHL(J^KX_l6U;oAmS;xF#=(c$E6yt zcR-eA@1xp?F_3j=sKfRTK=-9rDx=6}P-mp2e=s)$MRx{6G&K6*$X}1~v!worWxb;0 zxc(T#B!52}Fh2__uZ+G6(a!?6mx!@ae-|`97>j0nH32TxtnxfUy}+QIWu$bK9NEu8 zP5G0b@W+HPq&F!6hMk31zcro5d}`djhAy@wj?wC`BOFDbWVIdd6X6U4r@PJ0z6B^2 z<*&YO=ZeGs&^vDZONBvu<(*F(>G-q?(}2R|BLlG;c;@L- z;Q1i~&+H9uy(Qy7;uFw|npkDyZZhH~$?Jss&8J6&RI>5w&8=X?rA~bPOO$f)-$-n? zlqpW%nGb2N)!n#fv%%s+;DFvjHhiWPeBr~Q2??21Y}Ni{_`Z1M`20>3{L>Qh%O>$j z%>MFq72hp@LZ7bTS2GECPnWp)U!7>+xRR~yy_OEbms6zXJmP`zEKTIz$01;B|HC+( zKN`|=x*tk(B*fgY_P#>r+lvmU+mVg)8}r* z^SKAuQ&pB zD8yZz#m}y^g!?G9;p`XtC|H#yv7@fv%TOjO+~wEqE&F`}|I3UUQ%ccmT_~+QcViVB6^@72#MFry;{ zhY!9nJdI-Ot*BC_PoPvY2MJn1LG&!qjLd6W82zJl{aUxhi5g5qWF+0sqv2i@-#AHz z!hXmrwjPy0!<^@$O4^4Yp!9_ZPu+2Jex%jKjr9jSrTe3$8Fv`5b{7`RQGExm+}@DF z5mNq8`Oq1)KPzA#b`@v&-9;keg1-bU@v`HaP}rq3aqKH{M(R) z?XDKWD7Sh;H;d$ZGB&OgtR$Ta{%1Fr+#kY#ikJSrNbS`}d)nIAdb(B7@yOl}+#Loe z+4aBEH_Y8oT>TlXq^zIdXrI^8o4G*BTgtqXNGkT7z1EDv)u=51qAC-%3^Et7qu?UXG<=7pl)$pUj=UQso{KwN!aH&zCZiyH=L%= zG~eIXhnH-(^8SB4nhr7-GbqOwvxw0TNfZ9*yNMzF>}ap;A&w)ENCf}{K zP;oHlBUbCzrgRaDV^u%U|+2%;}VyH?2!f2-Lnb zjj-Fm!#{r?t-e7|Fz{WFFS<(Vn>=6c9x1Mo$2am83 zhff-QRZ*WL^>^P(bk$H1URTx%P+cLmh&gF;fOZ$hPwU)UnaIZ8g=%&Mob!0^GySbO zlh;^=W$t@BX zS?N2lhY;l}eWyq2on&XXDW}}-!fGWmr&L6Fh&N~ZoxYvu$MTigElZqY#Hh=GSoQ)T zf?7E$eWhKP=(Yb#^XrKgQF6qzh&?h7xv#a@26Gk?9Cv5lWVX-{Q|+=s&E?62+lPO8 zN2_k5J?C;$E6*zdo3QdeySB&xuT1xhm?LEkJ3bMElM8*@Q{2e zZyJZzlN!*%zau`p^pdE{EKFzT$`JB2AMi`gtUyuss-D~TI1>$~uQPdCOHg_1!4sDq zvI#+j8iq{6ZwQ;r|KgHNCrU5KRSR&gAZ?NFB0IIK#8CF_%3~>;=%!*+oGvf3Z23y= z5)%)vEbTDcaq=-nS>5a2Hy^I2AXIC(`7Namh2G)I5IMSwkX0(tZP!Mq*7k-(4gN+g z4lQ2H4daCRslf>u8!u#5`|q#XU2mc}>wG@{6%*p>`y3CuR7WC@?CX9*V{sHLwOzMg zpA2bfs8A-H>EInBOVc{EHR-Zbf{Cd z@=6;EqVAVMTYoE1inE@wzmzJm`K84&&Lx02;M929E65kgX|azy6f`5g($YKMT5CXE zb~<AxXLUyuGrM%ydTP zS!-zN`o_V{co+1Cr-ANVSt2?;AGnWSs1=DGQ@{JA@FO7_CAM=cu^;`j`NlY{N)Y}> z?&ojJokI?7cFsTKO$mO-828RrQS|Nfk>h(*)zNf9>N4d>6@KP9Abv=I9SyV|W+3Lt z5qEzpx3MiFahEwsCf1)k#gPp)48_a5Ul>RMSt`Jy3=0KcYxFrPR=iN z8jlh{BDF?i4vyCdzFwmlrr#Q9ZQVwdp-&ER3qGMxV>3hp-B>Q~P_4mh->e=r?$E5C{?@FGAMGTH;$?cN6cEvJ@%X4YaX(kdi3GmHs zySyMOl1MVJwqzpnU7zCj&pyPt@+(R|pRp3(Yon7mL~~GGJyP9`evM4Cf8=-GCeWP= z)|@icpAiwlmd8Z#5RYpne**L?y`%v?M(epcQ71;@c0p@H}%y z%g(Ef!94RsYVsI4h4dP6H7}`ik^dF($VQNo*8LUn%U876=i^i20@D#;t>gZr@9CKv z(F!&M3+0_-uT|_&P2P3uALi4L#;t!VKZA|9NomWueZzu?u4;)pS#C}|>>*EFE>_H<9U&PLaQb-r7iLMocJ@&>JUQkwVk7v*A{$w&R74yG>fRMw#&LCnL{L8)U)O~ z6h@4ndue6W5kkE7y;z|VW`UIYD4CV6xg&nYN0K4kb?EskUd^wfsVLk|U)YxaGos>a zBNx?ZCDx;khE4`f5-O|w1$0L@h^i?wE-;!TB+g#4<0b8nsFY^1m&yYPFMXwHzSvoU znN92K(abTT`$C!NbGGIzFQ7NB5%yB|f<$f~#txF#QU3r# zTcg!8VETM|_uKMwu)VPUiFq*$>~&+sZ+7}X*T1KqD`tX0Re~wYZ~; z^h@~o`1Vk`1Bo|{AMr=ZT?XGzn=OKcO7K3QdEtnl6tLZWbAkH7MR2lqr!KCPhaZ0Q z?g24Zp|Xz2=N#*8(0HA(GF__!AG!`x#~~eHc_)+@#CQub2RcLF*c-vt7e14WU^_6P zJbB0Ww=vw0=M%bAeG3+akuDhC2ZEL{CGxdBOb=dfXgEmX-?LKwQupzKh*@^R^N$N$ z^PO*^I^qHHna#r`M{K~gEKGtahQu%7@Jx0(V*?9gKFj2;7Vu7Sq5I(Bhw#|AeR8nC z8FJQjKQu79f;CSo`E0o*6y;R&U%TiBy3IBbX$PJ{wWw^z@q2;b_KREXSV$14&UuR6 zvAHB8t!2bEyrIxQ`L7~F|3qQKj|}n|oyCR*-r-yMBDaW!OH=9BM2mYG_D8ao@90-G zXfshk6KuCT8W)l4URp0pE{eTg6+@g9m^tjXlPi_Wp!6P z2f>DWxbu7VfV7q1U(GyPEJ&`$vR84Y!NfoHTk{8IkUY=ArmZs}vwmIj{#*N#@Qn5W zOjgKZwgDDfclJ#gP9>U?`!>yCW%4=Gw_GVmv=iR*Q_&H(<^Omv#G#DspJZ-Pc#$~o zJA8Bjf0apI&zt(Z@#nGLT=C!|78%_3N_NTXw*u~;9y)O=;~IA3b_oW-yZGfY@SKyr ziQBl!?M*-FVx`2<69&P0nD)OHH0}WpaOa(K@~WK<*v$3LQ(YQUe7hte@)pl+OwF6k zcuCy|pWZe;vgfHYwy#n2=6CVI)Xk5-B3fT;dnT5$P0kJf_o)1!otQUH?W1jbk!*`E zO?$|`Xtu$h_A|Iu*4kn|pYhg@w=D64biT(gx-4*#(9MoamnYamsDO7f-UAPFFg?EZ z&jzClU`gwrBP4d@aqB%lA=93Yy^Na~O7aG8-f$fu^^9FFJ zf|)Jj)IGRlTqdD$+yVk}J0#COksGa%`5U!C#KLa>AhS90=PFw_{Q z4EUN4%_Fhuex$t5+l;aisLtZ72hyRZ+%v(ogQ)%VZm<9zJB4+TYE74VzzC z8KX#Cx`g`2{&zYHU|%=;&dil6_|O?zt5jGHbAe`iT^{E_ap9dQSCMLHpW7F*bfpC5 ze>nY^wy=j{q zP+J8V*`mkKcsT=oon`K)L}#EAvZqw-C#~=9B`ZNj9w5C*=cE(!BPR!{O*X6&{cxuhVNA69#J$mES(bdxL*NSCz3zG8}s4$Fw6J z0|A6v5ffW1^sFvXo@@&N_6o=3U5Do|XY~90XOkdUz1o*>s681>HVc9BZzM3ab!iE9 z#KQTAO@^%{UvOWoTnx>N0Ua(o?l`do__bA*JpgE_7^{ayNPA~=ot*&|MyCctV=Ku#u#ifM94;eV=xu{}#jTibWO%71; zQDPr&H^M7{PZeFro?_Mej-IWK(jX9LvwrI+sn?)!<@=>$E|Af^9&KLYjjz^z4BRcH z#C1vc{%w{=lIB`rC8CFn;OgUEy{hRbTs8G?=JX{w{HFe-V%dlt4%aPy=M(o$Ci7!1 zm3e?HgxF1SS-7a<_Os7L{B8Z9Rk<+OKin4kw9nXWw7TFTcJ1=Z@{e&>W=6FQZvduC ztDz5D_r*5ecbZlAdg09B%lrS3csOBYp#f>NF_=C7>8t%|k(j~bq`J|Sr+Ae4i?ACh zAJd~Ic>1nf3|{JH9AdMN#cMyx+4g?+#x5~eKkaA-VYjCK|6GEe;%$0*YM(84Jby-h z{K@GcEQjK0ZEd~qs5KHl8I+8F-ObW-vrfiCw1>`J=!wA;#GI_`&q%zjzC2grNaD$F z6)XKG7J`jjR>JH4kT~$K!qkhNMPeh43?%98jZb)*Wcl0s<2qZ4aPdfAJkD2fG$1UU z#Lu_>zPKEMGY-#RO-TyHTYny&nriZdFNw5yhVGtVv3AZgGh$-1z3Fs{>?t;y&i@@T}RL;k3}T7k$rUip&btyr}rj$ zrX_%e=;v|U6VD()k?8=%foQP3n^$K4D+a2zcM|tY`h)*lszd(Had2+w`HQM+VGt)W zXdP3Z0zV(x)+_i$f|S#c^1yl`99Fy)pmrbxGH0s2^=@WE{PRa957bEO8dsiI#b6F> zRL#2UddI-T)W7frj|?DYm}DLWMFDv^hjW}qItZ;D6rSFWgcXfHHL0xe5YKsP!$2_# zo^!bD*}c>Zq8!aLrMd(xZt3M{e18kEF|Q8nn$Ehvx?L8 z5%Au6vnHCv;n>=Z(0RGk3xW-+A#(9GcbB+CYdmh0Y*c-Ld)c_Ao_g2R}d-JyHql7ar{mi zScURU%ju>AZM{wXrq2slJ!qapmJm<+d_<4M>XEq5;>YJ6x_RRwXQip@R=#jdtwZXN zp#r$q)QT)_k-QPcWU0!oN_b1fnfs}567Z&pHG2Fqfy%d+DvXP?@Y{B(gHx>f_(=Vi zR~tTwz@#evA>~ahj;;PVhr_+V@P?rWjj}KHZ`G4K8I%QabUtfxkc1;7?^x$?hd{)$ z4n~`Ra9nLF`PIJE7KHn4*1rvqay*WT5Bn`-;b@OF`QCe;V8(FeNu9no9@7vUE*1{N z>rBmOq8A@xA0gF8_Z|ddCe4S}20sDLGmfc_;PJy9E_Zh)GoQmVOM?BBL>hji{pRcE zUJJOl;bmDoFNyQJpZ)1fBIUom`?|jDq+$-EkGcO1`r>7+X#2f4Bk+ljId#%sg78JF zu)8v5VVIz_ax~3M!>6myZbh7Zj`O56{C)|<;o^nJB8PqH_|We|F^^D|f#{;D2#*9#@XV;V7=T1s%;CT&rHTD>9#s*V;l(GHoSbjl#cTj1!r-qot*0 zdCDIfihDNJG#BCr($tr`NZt(jFZZ1VN?%~%+w`Ai`U5ep7AV`CB6%;U+zTD{hT_*l z*2UzS#W;Avq@nsm80LC)_r7mVC0>60yw2f%3f5RS*U?ORJ}N(ceGk`2{I4M`Uo|Qg zZ`H0#E~cfyuxQAYDY6*2rg`aekMRrOEIQmf9~uW0KjPef{#OF~E@Y?-Xe5BhTYtV9 zx>DeAKf#myD+(+wN99^~r3%l~>49)CW;FBQKY-F4PyJ0GyKG`P1T2p@A z8L2q<87};BndVd65a_Y{yCzOX7f8wUZn3Ccxs6w|eqSiO`kB$LRYp7kbO9 zJHG!(26>T_WhXomp#JuE`hJl#kpJ$cmb9D(dCBc@YtLiAge$^F`)@KVhp!qJlln3> z(-OwpPHqROO7Up@hbTyw0LjnD%ysg7vuX{KvFuaSoTmqoaM@=_ATy(ghvzvUG*Sbj#@0rG0VW%TC+aO*DD%TVnN90s$hspO0htw6lmikHV>aH2H(S7$H>nW!$kjB-U4k2 z^j?qtmi>X$D>FHz@{ubFv_F?uCQiA*b8%P2(jT$dr;T5(Z}2{7KsNt{_xy-7l$j4?mF80yu{&WUoNC+=i#*>->HB-x%lu~ z`2upimss}Z_s`TqiTHPqVOUILDvrvvr20CPj6*v+inu${af(U3&Z9@ZSm*8gET*+M zymVkvST027;XO0YYSk}hVn02_ z+uU2F*r18|L~%|A9=?A+O2M9An1TWWDB113j1!+DVmp!HXs{W4k! zg|*Nb;Yxa6*Yg;hP&w=|KE)d&nF!bV>5v)9-_^Fi8V>O6rI)Ts z0GXj#GP{f-c<92t+uTNR~yS{)@uP;-V z4QfGjcIKC9LFD_YB`MtOg?~9*7uXW*9YNy zf4cQ?$ze#@k}sOH9fP$02EAk64T5}nEmM>50Q@~>w75pf16t_FVb-@}Fwh>i^~|*k zLOjw9JM=%nQO%~310`QT?=T8{nmY$&@%#_AWG3Ngoo2uTlL@eNsX2VcavDYxdfU3r zjKN-U$%;M7Qy@UEdnlMRU;Oyc?&eMBQP3OzF!bl-5ad2^v7KR@0oV6ca;EO1aQ&CT z+c)tG@b>=Qy91Y|;p?hmLOZEHe5_Svmoa7x$klon?l(_D?KP1jFJTlOr)v*9Um618 zXRkQ4y~m*5ca8Du-g3BNNF8N)t^yvd{NNFc&WF&Z|1or)fmF6(94AE~n^L00TOm|r z6xU5wW|6Is8Ih4>wM3M?QYs^Rls)5q>@6#VWbY!I$a_Be;5_HUdCs|?>-ztHKbk`R zKN;|SZzrR8WCq;kB$x~wDqxq!O}R!o9m9wpOq31rj%@?|#m}9sPgki2+bRu_W1?vC`Uf*uu6B51NQ9Q-4mew@`gf2 zU?7|cowqkETG*OO@O7Pk z6!>!j?i6%%k(tIYUCZ*Xi8cZRJTGp3KA(f_z9poklKbM9bOlT{$0nr}(vky}Yj0rq z7m)eSG!tt*PFBlNo=HLaMWB*~&IZ%Zna6T`;6pv~spSL4< zC{hBtLhef!JN{<|}RWzx$v9*YC!$cs3+pukbjU z-PL9+=_K>Zpt=axM+xyO&Js*P)nQ-RIuu%WPc6ne1rq9FJe_R#ne^EW%&^ zDP;YVC3$+dAO1Q`nTBsU7yT%ET!habI>qyIsTgbbadTxS=i+90-=syFYOJ)Q7XRc^ zE-to+JjT+Khu107g0JI`B%j=z6`y<#-rlJd=UjM3ay@DkWc6ob<6V^;`HLkGuE3qC z|C}@zx-@*2nj-~@AhmdJaT=@{AN@H=>KP{~9b)L&%mI;mCpPr+a)4YwJvI4NGN7r< zh8Jqt0P<(!<}!;xll_fTfKV!k?>!Qvmz52h%O9pZN=hNw!#lCCrvUP_ZTd&4OJLr8 zbkt^~2nyyk&bSyhLX$1o>(Sy|c>CP>{L3RXFnj)8wU}HvO#9Y$F|wAz zUj7oNN?s)#kiRy?CXfz63mn&tjyHn0sPW&QXG!OZzKS2bZOx=!ciYdy4WEH;-*Mp} z#agg8Kbf`aO1f{gPSEW;TnL#P=_(W!r0>-$UAZHzqtL_SbNI@hVc1cbT}q}HhwEWa z)eP@{2afT3)3pyq;8m>?8}rr#sIEP)YbJ3$%Ec;b4|~sniT=}n3`(<*Wqej-ea{qJ zoKnA}DYgLryy+^7v}S-e)#@p2*&kTQlP}rFI}fkxR@GyBXJOxkyE0URQ*bcEi7Bpe z5nRcno_zJ2gsqMj_k&1z0wk9}tD5y21{@XxV!KHHXErOAO}b7{N>7>I`F79|U{~0k zoq!{+A8$QVode-B?LVDjN8#&Gltmz^$GdRJ)qSRQ0_txx=bD#K0rl?M=Qr<{fNQbg zOrrlU5E6QFY_)xbl%pEdzsgbrUHxpTY7&JYUl`jzL0LlTO_K^ja-V_6iPfdpsuX$` z6dTJPS3=V~uZDtKJ&bOb_i#V0g0s`)rld6(=xlN88zKyKj=X6%NnGfIhGDzHx|Q&q zvhd`wLmjY|;8;l~Sq+(4U)r~BRYF>N-mZyl1vJi1N94BGKy00xax`l>>@q)$=Qd~p zzF;WIu&o2F+W{#CQ&m7s(UrDsRSDE-EMHrHCIFc(G}f=wL##;KrsL5{*vpkTQJX-z zzD!ER+CU!6i&*9-2{b_O<l5a}*)9AGj==7pt+fK^HjoUtEftpY8hEs@B z{f{!Z@ZiI{r;9mw=~MQVovlJJTd3wy@Q=p}kGJ_38c7@omTp^iw>tbq$+kOGtq81I zOva>!bFf9Y(oVdB5xz_JJ1u)O5hgw;{-*Rb!`rG?yIoIx08wtm2YgA6SoeLMOrY^c zEGhp(H$&z=PNs@gewZCc^1?j|_Dy*V1!pU;zWPUe@ZCno#iMEX9A&i26eoeh+AK=f zR?@LC-2{8gL=t{qmu*bpgK@!uRxZhl)wn!TV)@gl`|y_A=|0%;Q;0`LHk@~wYp|Yz^@Y%_D17rN-?oW8#)CEwqK|GCVI999 zycFM!l}%MtD{Qmz)}3U$RsRi3tQj&9%VqHM1)ZmCa26DdFgY5WAmDuT{)3DA@?dG8 z<-@rvCGha3XATo520?{RhDOdVSh5^5q++iGwZvF{iQ_HccSo0eZQ%p6mX1YvlD2jlupqWmx3SJ#qx@t8W7W$pIs)Z;Mw9>;aDh%D}p}9d5f07 zk&%>I*fRld8qK@R8>pGvhda{DFD!<4#S6W7zKY9Loz?cQzY%kXDk7WbBMpmiU zvpVojY0O>P&V!zQX@gR?3V4uYc2_Ju1ElS4M!eD>c`T(HxPMh);9MP-jFPPf2OC|Q zuk&H>IJ@Sp#lSX1tLbLkir;{{?UEu*eyi{i-A~Et+JwkcysAo>ldx=MWT|hx3G*x` zf*;up!9#ALWLe#Hu=zK(gVa~SKo0SoxVH#j!G0*fV+CYX*!F51{|6_EkVD?-bvPb> zbzrT26J`x2Blq>J!GF(IMO?qHK~8t6LXlDr>{JaKRp>9l-(-#Jvh(%OKlfPfruGg5 z9ad&(*I5DoJ*k$ar2O0&q08Crd;frNAFao7>l%Ete>rXWV+S&anEVd7??cOON@TU7 z+#KmG&~v`h*Svdu8( zX}eXt)dS=fLWfVeH^65n7deK>Z*c1)r{~`cQcvc%i}P>FHuxUAaYqT5%9d=jwgcvCidOY;JuEHzhGqxW z15&FcARP`mQHknSirNu=jrXRxW|F&i{dwMx?mxkXO|6;lwl{?|B*P4bC1R4 z50U(&R~RoAXR{defu_qTV5rw2AB_(CM|2f&yi(^%HK6O)_uRv-4t2Qrtn zPctbZc;x*>ui%R$KQU(?k4=0eh`OsfDZg|CH{-?n3(jw`u1R8ksO?wSd&42HP%;;e zslIThTx!Inr>nn+&JtMqC9P9od)|3J`0FuShsNXqU=$^dsG; zTXqUe59;y0<*DTTUe(z0Qm~cZgAPpo>SLWR9Su5hq+m6($Fs35*_{fRicTC_-5jT}oq(AH%eCT^zv4SGKfOawm}A0I_M?w-E#CXk z)Z`062~MM41&OvpxP?lo`Vb9)&27B@Np)4@|L$vrFa@{ZIr&`^qN@i}zrAo^rLYr1 zl215(6&t`GN-172HhushKI{KHNxf?NrwnR#W9gvIdt}4z-6VcSZesSuuNl-QyMKtz z&f@vj;qHTLT~My%kTJ>F4mGpUT+}1|P`I3R;ZIVdcS z)2#^p%e`L8&Cmz~r%sp0skOiZ_a{u{mnz^}c7_N)T|Kg{42=G_?`kCj4L+!+4~Rp_Q>;Ut?onb zeZ;?hZf*f>e>cx!r)3b*B)^lfu?h!s^O?JT>?NgO!(M;?I}9V5bnpC{Nu29KUvqEe z9XK^OYBm3c63Hkx%4SclL0L%(kMPO;2)x}gE7|Fga{ycSkGrhMgK)aPWlDzj2xr_m z-Esys9h%`Tf7=e8x4G6_+v$_OIRbbNiHH0UV% z=($A3zu-P+tXn6ona4Zi=NZKaqHq%SS&L z*Z*sWZ;E7DNqmbCxb|(DhmX|Lv9$01UO{>vvh@jU*5AS4UeB9qj!k%$#q1?xOX_XW z&8V;Q48s#i(XOcB&oFjn){nVj5emxf)2^MJ28-(lddXB<;mLuvlPnq|pf7pyzDnaf z#GDM)65G7o!Ip<#f_~xKkKK-|6!$^-TP_)w^=bU5^L1+H{rfm5$Jb4bdkx}&YzL_oKH!TrvN0Y#F0k+M^1kYmm-U;vy&1v%>0Vc~FF6C3h-^Q_5P_?7!zg7b2+Y&(0^tW1@#zESYepuc zK{#$`$#N?KTV6gaXP4WJy*CzUI$zD>Ed1?E#p4X1x2-tuy806zx}EKNfV5xq8p=p4 ze@F6bw)(8p)r|p)E`EMB^B+#=jJFlCK8YWnarC8Qn!=3sm9hRlLExrhW%}&yJia&j z#pq5=FI=2_t!HJlh&>kTZbrWD26jV+BOT0CM69R?S-Ac<2$}6)?dSN1XEu&q+gs8G zdD{caZ%l?@l~w9Z^8QBX-k2V6mHz^QBia)DJEQQq#3uB0@E|-I+&LgT+yW^K6@wiC zop9;s&5e_aNq}U1TJJUFV)qmA!leaG@WIAD{c52Y<`HpNdvU24J|zFh3N?+#x;#66 z?VPP(xH_?DIAO2luhL)D9JZve(a5ZN={pIr{#5LUk4dvGmJ-7HEez zjAn0#$EqO7T5&nAt_^sW+67tEX26&W_+^=9q4<@x(lZYRv_+%wwSAHssa!vB{ANT8 ztczdZ6pH3S;&X{~fZa~+g?1b(>T$QRf0Mz1$YcWi-G-VW zFOTWJ5SLx3zr^3ZxbhEY))lkv|1ye4*b_dD?{&n~0&O+t`Z_V?>mzi3GexmTogiUT zH427R8^2TN>Tt*2Szmdhci73``;kNCOR&szeor{nA1v44?&>&_gr{#c1+VPcL*z+l z7@1fl!Ab909T^2WG^qFF_(SF&5bd|itBF}rV8!&ls;@0La4NUvWFsRX&mw64(6kBn zs#!K3`qTy$uatfCf(D@UzuKF^TNLQ0!T3#~^`pqvxW(5!pO*+dIv`*?BZ!t87ZXco zB?*U@+;ce>3b4h*yrN&=Taxct;K|1~TlmAThq0^|NFFZTi=Nlh5+Uo6_7mRMByQHr z?#oxMZiD_v{_R`$|B~i;sVUb)9Dqla;cMb)aw0#=|C}NUgL9>_zn( zH9rJ5sE7$Yj||^N7GlsROu6$H6*_Eo&(4R24fWjD;?b)lC#t;T2Kz#`a8cRL%^9@{ zxb&m(lVElLY<^?6IFYo7+jjXy4pz_;%aBY{ZIKIC9*aDTF>JsI30yjL0pj zs@%q~`Qc~^2k};XA@chplNP{C*6esa`k8pE~(vy)N!MG_CYt|OgC1}R54*&Tl*hHQf^ zzSsmSp#(yvlV8}L;QFuWlS1q>;)#@lkx;N8TKcxFyW0^)#DC*sF`3~*j6QuI3=e6b zQx4H>(`V_>flDWNH&VR`{_*|7XJ-()Vod|#Zl1*I5sDAGS4Gf;v`NWlawM+wj^y?W z^NZ+3Zk&O^!cRg{U1k2)@AD|4Vc(H2xyb~HA;X+AcnB4CNMBMrrHPnsH@csA&VsH6 z?biLZ5hR#>=XEwkv=N=e413LtJjz@!?Q^8mL2rJ(A{!#*-y7?XD0=AXA>I4LSEjyO zsH(A+%qlOHs9{gOOFo`JFj3i#HuE1wey?|~v$XS|)52CcfA=#XCyE2|l9l{u)4wG2 zfQSa+dL(FL5StQbO5V=CqoYJp_JdsF8}39*lr2~1%o4~j+w;Ck(?C1|RLt7X#(+cE z{b}bp1(d?_!broF2TgtYdq{b~lsHBgqI&u+8%o{1&Vf~wP@3RW~)J)#5C7wcz-?bbS zEYBkSmcEqDG!9gF$1KWV`x2skE~u4y!~k83w+G{@3#j|P)rZT;(rBZ3RsHI|0HWf# zS(GM^4-vzeA7#tG7v+uxCm%LpBs|v5qq#RpexJ&Ppf^uC;iaE@Y|?2}6p_m0S2?0X zY@U<|w)U;U5Bd8?tuwD6ZtBP6p|->Lz$XUgE0u~wkR3fAx-l+C0jocimovHTq z?P5X^1KsZr95qKvU-7w2qba;!o^49zw+taDtof)-n*kZIvijZ*dxC~q*MjrTQxQJV z6# zu>8EuxHlhCAfL5<{N^h0s&o6KWo$nv%C%g?7LA~`uSkWK)dd+=|GYVI?pu60w<|}WE(adOD;2)JPd~5Mn z|2uzkByD7)+M(Zsv-JnL)+j}Yx7!PHMfV8EIjCp!*@TLSE;)bbKoJG9_qNX5&Qn3x zzkWG*VtyD3YE2B8>LiF{J$dbHF+svbf$-UBOGC-#sU!Kl1JHEtfv(}F2Pl8s6wbWQ zgDcl*v}A*%kzb9UM&`;lAcglM@?U8ZOeZI2P9@TzkY;lQ31eC$*z4@wt+R$56jU@r zDx?wZ*(QnqjOkIlp3l_7*8k9f1#!FRR(td!_M8e2vo?C0En9v{=n!f@#z%cV{V>t* z@F92l85=TWc~5NDK2e& zbjaG0TIfwOH*s|1$p(RDfsC}1yc2U@34N&}hB`OCS)zvl-etX{GqGQP}HU%opMoi4mnh;Io#uRB^X=3Yc8 z;e%w-9ep^_ZEa1J*@nn2^<(m%zkoaiGae}iokGVWt~Ky&pCi_vTrIWX(j6BrBls*NUDUDX6 zOE*{_9g>VinFqf-&!~$-Ow{vDK~g`6fvehKis7|LAuMIUkIRuLVdu+EuUIEeZl2|O zT3rsI*ICdDlGl5ZtgQdya1L-+4po?v=2$ED3WZ;#W&_hpnt_@Kl0V$waM)C04#@8^ zhTqmHhJ&^m&Lqq)?4+!(kzNwEs`y1DX$g2BGGu+5w2u&~e5Vq^iXlPtcL&XKJ z6VmjRAVp&B)IRP6P8yC298S!HX2V^RmE=FfDV8hRyk-*UP>EI^MSCI2C1)6ZVtyW( zvHD-qc$19|K9xH8(d`m4`t@i}pM(#x|FiFBPK_8kG7#uDsu_>Yb4ttdnYg3ji;u^y zb$B7>QtH@X>S2QF&p=A}LLHHV(_*~tdl8ddk&)kI2Z-8l$~`fsLtu)LmznOWKg`{f z%)1}p1IcdNOXVZpK+m?c9o6d%KHPLEQ%C(k%>UB%7~2bQjk3QP@+trZp2YPwuSS4v z-chmWU*7P5%AD8PG8C59rM=5mL!o6&hH*(f95%|%na?Kp0ng>IH5!{Juv>fD=nP3P z3QRxZ{d-}xGqd_(w;xdxlmCO7+XtUo9e4hYUJ;S+-)ilYErVk~{t|<3BxmignK3>o#UWDbANhRi~2Ctn|_p z>#2vt&4b!z>y8pga&mCs`-CjP-_&ueu5MR)ELm%sxl#j@eKyQs1_i8=bwZau9AOFS z&|}-*)+!zivZl^<^FzEhNA@`bVNBL5E;*TNh)-Q%=TfzhC3(I)1|0vaRa|>+`lRN* z4t5RRj_7XZf*8U7&W|MOK(|NPzx9VD z>=p5E@6$Cws%NBL+H>A>K4SQ0W=X5Yk}fnQM$^5$rwGSrmqiNW ztvwSd1I-J0mJw>&;AF6NTXsR56ELN39`nf|$Ve z_iw3uA|iYuxX3#0p_y?t4;C*g;+^X0WkIek)GtP7-^^Wr9N8&nT0|eBftVCR{t-c( z7Z0SmcQq0^Gro73v-m^R2eP1k<`=MbsxWLp{W(08Bsf0~dxKzzMrvS^FR*d$DP3oM z4n&64bbv!3JZKnp7JeB4{4Z@@OPD=}Z4DmFT=@vtYrj=tWc~(5ey?OLs)T_~bb53E z>GR(xP#&TJYRnYTA^6`&b?ZB!? z-xRs06?CE~4;6&BfXgj$iHw>KQ2L-vNg+p?1L&OX?77$k3tstn%3~M?Z>+4%Z#07a z${q+K?GgMewUw*|Nx3`Mwy#%BN8s<|VBX+lKZx3}O&k*Y4*ma)yuC-7uO(P0{Nrxu z0>4E{U$N^WkiIX&J@xi5$erhwB2ONMk}0S76jJUc_t&300%^lAS|k|PqB%v%^|F<4 zZLY#;uG0&1D#Osmt157leI3MzE2cM1hb9#Y6&F-9x1u1J-Bv1kApsP{@+wb$Pk>gQ^# rd#2 z{{9z(WZ>()=F!0#3vn~Lb#M4%pvdM1MKZM&epzxk4f6ELjIXu64`A^!#3kg7XEYbg z;L%!oK$4&hw75;rZS~4ym-GUzmRS*e1?%2VPB+A^;b)Z2q?_TiJLG(M=R)!3LWN!N zxE~y`9uPSY;D?_G$zG#viNKMMa|7a%o$-?#xe_698|cim)w@%kjkAs&HVawI0nJ%n zW~Vd7I1%9Mb_d7@~Zmtrn}*I-j1=y_qGF=8{DG48)}Q++l5O@ z*@eIoS#_H7)GKgjp-uQsa}T;y144gY3czJH!5Wq>e!yGIOMfxq1t@GUHV!>kgegv% zjdMp{0G4dr<|27u?qr0T770h;S_!p*lE3eO`j+XrqgP2e2Aj&>n^GPiAU;FCmo%T_ z>yhMHs||)uipPEKPBCzzMeEQ@-ZUuQ3@EDYAmzXUXA_RLM1pO9wlPz27F5{Z*`jLy z2)ZX%tH|Fcz_Oif*kSrKU@5UGiZM!o_ibn1@@#(q?WEVQf9aM(5zGAP$%!}!9ofj? zk|gnc)E{@;i_8LgD-U9ajR5ELrgwWjllEB`HuLsBE`a?BAA}m_3c>wca&vK17W`Z< z?z)_gAwv1HGtR68inzyKMR$te&mWJ`FJCg?4)=Qv&&&DX=zE`g4=In4PyXc8baE$b zERRkmlJ?4WzeE4x@pc$3-!<^^Zvp;;$!w|W?cgXp=c{nN0cz?>e(Hxb!QY0#yUo5; z@KWHd+@7#`2((!9^*BBa_dHh54A{-XWv^kLKoip3^ZUFU86kk^*lX@*m~|2#A|JX!Iba=9nK{f7&m9kf5?h1?mE+N+OC1v zxYUc_owKOPd_9h1i2^x9=-r6gJc-TnSVQB)|B~i2 zhh*NRjv$>`X){HA2>C>@%i*9hC#mt2Ck_wBaBQ;k-oqAUD%T!0oPzkp%g5Ohim-Rafj42}rI1u@_$au) z7Yv=82edJ7lu@22$ z=Zaf!?N+X%RbVa93+5);D_i1=TLa`N-zPDj%)x!PBuM-+D|MAfF>+$|{I4i~(!S?2 zciJ!Bgb`qgX?#GVMMj9wBXx(rF>rxJUNQAi5@b}Lo{w=%gZFfiTQwyqm}A*Hy|a(x zgHbvDu1G$aloxEg9B}VB7|R>@PCSms*?WZe7dq3Rm%nA1_>qG%dZhG4{^o(C4z<0} zYCXvlT5dnW)BuOHo6>zhpYVmt)14!K&@u{Jz0ok0NZ~G1wU^d2L z!N7-cV35sGbV0cZKRBTOACuG%oFOxix4hbi9hW|>w?5jyi|?YJ4A5a5B=kpR!g>KG zc`B57kT`wID{rVPx4OV#Z>iXunFipVNS{+2-i!8};cMDSng!ify%Tk|8z2Qqp4w~& z5Svrn?;TOn`*e7$Ul8~?3-U>h`$cERp{t7` ziJbo#a3?&q{(N#8mY+(O#;43dO6L-xes35g`IRdCf;-{7J1=WE%^y%X(N=u)V;ckt z9}si|0S^vWL#LIXa6~Lc|dO}{Zltgim-7+KN3Yh-ulhBvu?qQ zmMLw>!nr_^pU-ihvUYwCTgD)5coH) zh6$m`?E7jADk^zNR~o+9Ebx^+a; zVt?%pbl>h3Shht-URok#LtPZPe_JgJxAH}QE>pc3w0K8svYWqr&>f3X-~0RR--#oX z8=biCpjf1RE#E<)FcytuOuq2%y@jZE2OdzilDwOPyfq)!{($Puj+fM3B=1wy9bhNr z0@K~biu3R)goIsjc4?zQw>ZHhr2YXXQ@>_9xY45zRt?TE zcQFXO-&UfZzm6z|66v3r{)CGgcWmabZ{kRcNfAG_Q|Q}&k#Tzp~(lR@JXC=q3Sgvyo%`)^_CkNu`Imu zx6cC+lqS=5zt5rUV%9a+t9y{i@Ex&+pUI#UTP1hYZxH8v8A!O0QG}f(4Ya-2vf!Xy zB@M0G2)4PgsLcI=w5R-;q;$}!7S2^X85b(Z!$n$AuDN%bA#$INAPZ*@0sZ0 zSVfR*qACN+X?(^0qbT9N@ACJHyo^XWCw@*ld>R<0O}2a|Yw+j!Q~WJotKh~pMW>PC zL&O11X5)j$X5lOC&;9YjTu7-QQ&ct#JF`OXR~p4u1=~RR8q+fnywn;c}{< z@z3dd0U>9`L0rpKyOsJU+&XTEeSgmbdHzN@xAjM;loA@^TIE4Qj&Cj5=(FMAi5!BA zhKp$SK0?!_GY?_w-mm_B6(d+pzqu+-FXLU^DVyWYzaU}qU4FV72eK-4ZrU?NLHrc@ z6{=UoK>RoJoXy~nB=N3g@BHZ#eVA{ZXt+oB51ed1y`%m`OB~8Nr9@>BN<6NU7*(e? zL`)pHo{1L>iM>MV9|Yz}JQX)bvpPe0RQKtL_0K$Q#I+?EdtYD!v>cb^L;1LfJ8z=| z#%^rF<0_|d&(3b>kEQqX{k;yYUp@LC&NYDIQ0g*Qz3rV_V1l%usekg`1AWs7w_92=tIIDp1V$pe$zvBK`stStp zDD&-&Az5p26nVan>7vgBv_4kTp+9#L%`|)cz?$Od%Jsri`#c5Fx99d@ajcw3dgr>h zxr7M%V*24f&D#w?H}vgA<#-(qD|vM|WM>H^#QUoMCio-8c{yplAa}yt*YcZOg)8DP z*ZKAPi6?RO0sr*vOb5ikxzT!s=RTrt=ykT*&rF1hXvu7m&L;Ar9&?VVl z{c{wNNbf!IVxVAN;kM3U!lALBRV$Ugt-YWOk#=DYQ$$H?rI#MwesXVflLpj0J$ z4E?H2;SbbSMtele<;Dw(5POW-qm2SiB)W9_gEmH3YvlgT2fa3Vxz*nd#l3XDzy%y`=&PehA=>D&-(8nHzFN6VedCkwV@(RsvL!xAzL9hT?yMBhuGKqqlEMg2fj;Ujf5 zBWVY?Up#rIUY$%#NDFUVjrAgIZ9T+R;5A`r8F1|4O-Cg0t+)H?{vlK~bIyI#d<4x( z*oYmrCJ^O0wPm~G1QJ@9%TPM=3ti^g*;Jy>K(qV@uSB*JsIy!vc6Klyt>@aN7`zWc zH71YVwr=<#nvbV`M1lA>qLK_ni~a?=7$2J5R*?^Rq@dG-9XIP>&@|5>q2^kstUxb|lk zg3|h%mc@VbD3I~3A@Qgiz3I8p#S}7(m?9`s(&)2L!_1k&KeN7A@cY6eR$5b>B67P? zfXfS4oJ|nD+U$YDeWy5T*F15Py6<}IgwK^2vN25 zpT6r}+ikuAS}<>-Lz z_9KkzL6!?p53{L2=^Swrs z&>6WZnX}yspAzq@7&CQ(mICP`WIqlaDM$ZsW_G}XAmwNc%|*zuS~!PqO@L=jTBh}t zS!m<`fa5QQmmf%KTAy?@PB^ z{9+Lz`m5bfT%7|O**hk|b2D(TkXrXf+d8!UIQmR;ivV5b%w<~MWccd&ud<3N4bGG- z+;?fuCOwbFeJl(rhU9B2bJ?1g}0jF^Hk%9rj%wlAo^O(S+Wg`-^x}T zvucLt>J5UssjWcnbcAjZR47uk8@4+QdEcpYz_9N3 zqZ*{=_6JJpC)G)PMX$rU(l2B;^17j>9j!{?K&obA~H?n*R4( ze6cMqI%2x^8dBuW3v11DIk*+gU5#1MtU8VOnai6{q3FkE)q`ixSqi3z2 zpK-m9gWoB5ET|{pvW;;0OL5_(xm%2j=a;AOr}KSUYQGQu)A+!ZV=E0$GhZ>{!FRw` zAt;-7)E)m(vi{|jB?E0i3JIKbX1Lv)oqIM9L$K!|6+xyVEM|+e3)a)Y_U4AbsXY}q z0uA~1JbH`A_-`Ut8gr-(+ddpa`4Ut(L<>Tncw)_l^u0@uqF}|7C6#ACX=C)p)~-y! z8ymOy-P4FRhmyQSlW|i`n3D$@o)up(+?zT1T08-$8Z&n?Jah07Ws1II2jV~^#~?qL zlf*BeTP#~)%7fiJiz91yf-#4hdr78u6o}i68~5=>VcUm7YYN`spv@jT_Omn}-;y{X zI6YhhK^k5AmyH|oXFl1&yNjQ}J|inYoi7=8j+SU1-Mx*6J3b7p{K>^9g9=3a??r<@ ztE6$7oe!vp&;_;gw zJaEo@@{&JZp5?Sq`t=-Jp2;`8kuhB1?2!|JD_!x!h&D^r`8YUsTXYV`yv1g574KU- zNM6fQ78cJ0sSQ!dbV#LK}JEWTOl+HMtj5l z_Vxy1{V}RXI!O`u@v{1W{I?A3FwnV=B{Kqht^{^6yOiT6zYEF#9o5DkLynAAtY(6` zI?sD=kp#?w^#sb_hT{m2NWn&jW+)}L--f2-LH3;6n;w}|+#BPPGi9HNC4x>;ipydc z;nC7pc=HyhsZ*QE5b>otv zK~XLG9^Ec`&}yf6V0aU04rqLOU#aXa1O;}eR^J(egHH@n7j-wGG^{?|h;9HAr9m^DSU{Tvar!w+#z-wxrIG{-#bvcAQbikh*HzQpm|Yh=$rvjnA14EfpC0 zHU0YsaaQ{eWRmjM!tO1HenbVs`xvW3FTOINXZAMtAAhAsg*tC|Oxbs!ea4zM-*5@K zxGayBaUMd0IhtY=zqrtzob{0#;v9%i?G3c7>_L1n9htegByZEQxI|PFIU1HfxVWk! zjzV1QXdaNfZVB-sJC3A$q}qS%-WPt3!f7TQ4N0|0sH^e~%4q)soGyWxkIqlPNrw`Z zBF6?ep5Rr#@8uW>dFuHg5|^f3&s*S;-%oJ4KC=3CsSp$mxpU$2AdpslnNoElaQ5#W zqmhrpz#3f@dfj6L-pG>0NS-H04@IRt%1OEPq1)EMY@%C`$R}?-Gu03LE{$CkWahXu69wq7vVSq94iG6~CLt8m6z?GI~859HT2?;X0?1dn(|a(5&DLI}5V8k;-? zst(R?eDApp2}4h(WDNUYf8J)o+cbKlu$g+wtGgR4O+k(o zl27VZ+Vz|H=j(B3dFI_B^DJz^F~c@#`T_E(X}se}9s!AOY~=n!$ykWFTz{^s1}l2F zj_*?SzzL435z99-uw9x?cSE)rm-ibQ8Q1q=suOds(~gwkn@+BymsqzecxmtcQdN5e zcGo`GejiB1$Cy5~-!>Wow(rH%7CrT(-q)z5;`Oh+r|6iVbJ=F08aQohKC93W>_+{+n=K0%vw*RZ6lDyrh@&;!ww9{AM#% zh-bbRM$Md(>iJqgG4wD8twR+lH*0$Jc~3iTayMHpZ|?!t7LMq&<6m%S4|`%NOAlDP zkh$rc&&NM0XDoDIWy4|r(jvVdg}8I2;$P|Q6!_leA|pFdhi@FH7JnHs2t_*HDzYi9 zcuQ_G>Pu`FP>5T%3v&Ih> zWtf8F`;Pi;(i?o51&X?*q|JmIRfkl&3%HLrQ{yc@$`PPbWHa~y-~YLPZfj@_hQ z^0hBaT_f15ygn@zNfRY$Z3aR zlGi{Gg;A&#R%ArIFnhA6nA=?0s%AOc|kz zi(yAk9Owq0Q1>0L1Ob%JS=adP?Kt=x&h(p)K8iN9+W31TNx9mLCpi&QQYdOfhIe9p z80d=%Mo;%xqP_pfDf5g?(Z0!FzaK81M_=1CLZhaQ(K)ilO?FE$b1a2##8 z@2Jd(*gi5{(OCHe#gFzp?ti-tP7>S8vg`#g;o_(Nm*W`Hu}yf?eWDN=BT~c3bLEhO z*N?*t>~iS1)<7#Q!%>v|e?xcv4`sgxV7#(*CLV*bl*UrRgOp;FxIZIVDpF%jN}Wh{ zCQ+6WCR-%tpcKY3S_oyA`k4}A8x}zZJCA9%9b_SR zCmXe4E^!bOJ@+NRMEN}?`1L4b#d`tsKehVe3huxJLc}^`l8vE(lrlcK*BHK&nnGmH z9D<=NFYOe83*h#@$IJ>l4*pcFH-GnuVVodW=~hRR0)cHz3E}g7gMn|S%x!PzXLPas&nq5ygQ~Usc>gLF9uK95CYAT(fDL%mQTd>I?SZ)`ae>t zk(k`dhX+=oqu8=gMNQU^{%%2w zdjBUE%QF$a8z;7cE3u5pd)!Cyr@A`j=`BAo<7CP|Ey}WB`fEXSptcBqcjRDDzP3K% z-g3-XSamZBo35ivJvI3u&JrW1o#@^kHXc^=6iY2|bA;PYL*ktlJAB&G|Tw!-D zVZkCjj`{MF*uq4H8N!uzXwiN9)XbsEE~ z<)?8x!<-RQnTeeW^BAm@>&IN58rlCyVc`5{a)P4o2=HjCfi;ZMFdA9qvBc{3^gecR z<#YWJFq4o=_UG%s@Tuk(q#-p>k2|lsH9!%4Fyv`>uBpSG&n*8s64-|)y%0LEb3_51 z6?wI9;Qb7~fm=f`dbl4%D#;?^ZklLA8U8+`2*7v4U5&b6YxvGc(fVsTgU3dVsQLEK z;a*?lo$fzgz~-&>!(+zBu==)W?bQ`RGCj?B zJY^YIk+iV1zPSZmxlQU0)a=KOG+wrxS}%;GC8nu`6NQ-h&b%;n)(UPrl`bT;T#Yqx z{+tXh8^-r*8=V%ph_F5H_@@IFh0ts7xW2Oiwb;66R#7B_U1&_2;w95>jo!o!FA_^7 zQS|rPG|fCkWW#e|xlg>t#nnsl6J7~IH+*G{m^5O=(~EY`n`NNUitQT1XvfShKk$(! zYodIo*~Hh*hDb?l-nGJW7c&1U81FrD5*ei1?4N~akd>blpsrSe!ad#PO$5#XC%d?5 zJRt|!7v47wU2g^Ru^TT{Cs~4|7;C*_bUsKNP9q+8%miSq^kv?*fLlQ#l!tSAFfh?T zrVBoSi{d3!S7>iQ^9lLd(d`~_L=a8#tb=1_J$x_fvzO?7Y-Uh0?HPYKK*qlWiux|`QgbPl*3)EXjD zN)w9vFJZeV7Q{TgY4fd=Yn;hkegOkwWJT-=U9UlXJAHniQEqxj_PTPLiDkH z4x6>KV97wZIG=k1*5yQpyorkd>b4)xlb2+`k?_I~h8i&00$VbL8v{jfTkKjxF5K2| zY;Lm`1lbJ!%Zu%Ga3#{()ps}*SmF(dvRk5%gRC;uRQ3)K%PL)RwHfHTq&8pFr2xb; z4iFQ)=}7aaX~KH1dQd4#JpXO75-p0RwyWM4gmiPdPORN;aCW_y`YS<{LcPOKj$toB zMD_ZWxq|_a(^kE!?-~;b#ISFlZud1PVgMG-v`@0tiQ;{zQppVex{>ZBA6G)=RTu!(#8s?Ne&X&B1g4sg6b-*+j zRkIzmx7E_%UMNXZhogg-iaMLKJ9Z#NuTSB^Ya-yVLS07d+dyCl<#JBkltRlb-WnM^ zanK@lKBsuo;k-{mL)VWSXy>8K*4!bCts<>oV zq@_i0?DNuSUQ3`b;+&26!oMKQt8YDL-yt|v^*x+0mkpg?s~A_uIlz6Z?&+fO6>UED zF+Om-3#_d#83qvYVcKD7fm#!U&XMCq|Jc)!yWwDj_|#c2WGFIQoBdF`pz`JUO=QrO z#B%s&WT5maQ?HHdjr_lsjvrDDKqtj$L5_Pg;osR~!qJi2fX)u{V#LyrS;m?uVNYZ^ehVN0EcXm1eW162{Q7v8Rj=V*$;Ta*QMg zMiC0_4`fNZfkRkCbfwfSMDSu2=_3w0pO Date: Wed, 22 Jul 2026 22:01:37 +0200 Subject: [PATCH 22/30] Fix uninitialized lfomo/homo in set_mo_occupation_3 (#5616) Co-authored-by: Johann Pototschnig --- src/qs_mo_occupation.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/qs_mo_occupation.F b/src/qs_mo_occupation.F index dcd2c88e4f..209dcba053 100644 --- a/src/qs_mo_occupation.F +++ b/src/qs_mo_occupation.F @@ -179,6 +179,11 @@ CONTAINS nelec_a = accurate_sum(occ_a(:)) nelec_b = accurate_sum(occ_b(:)) + lfomo_a = nmo_a + 1 + lfomo_b = nmo_b + 1 + homo_a = 0 + homo_b = 0 + DO i = 1, nmo_a IF (occ_a(i) < 1.0_dp) THEN lfomo_a = i From 2589a58106261948f41c93b9c9899b4033eea473 Mon Sep 17 00:00:00 2001 From: RitajTyagi <93324922+RitajTyagi@users.noreply.github.com> Date: Thu, 23 Jul 2026 10:09:18 +0200 Subject: [PATCH 23/30] RIRS: Fix RI-RS regtest issue with sdbg (#5622) Co-authored-by: Ritaj Tyagi Co-authored-by: Ritaj Tyagi --- src/input_cp2k_properties_dft.F | 4 +++- .../regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp | 7 +++---- tests/QS/regtest-gw-realspace/TEST_FILES.toml | 6 +++--- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index 8dfc723158..9d08365f9d 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -2484,7 +2484,9 @@ CONTAINS "use slurm, the number behind '--ntasks-per-node' is the number "// & "of MPI processes per node). Then calculate "// & "`MEMORY_PER_PROC` = mem_per_node / n_MPI_proc_per_node "// & - "(typically between 2 GB and 50 GB). Unit of keyword: Gigabyte (GB).", & + "(typically between 2 GB and 50 GB). Unit of keyword: Gigabyte (GB). "// & + "Note: This keyword is not used for GW calculations with RI-RS, "// & + "where the available memory is detected automatically.", & usage="MEMORY_PER_PROC 16", & default_r_val=2.0_dp) CALL section_add_keyword(section, keyword) diff --git a/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp b/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp index a390c6e1a9..995959e522 100644 --- a/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp +++ b/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp @@ -42,13 +42,12 @@ &PROPERTIES &BANDSTRUCTURE &GW - CUTOFF_RADIUS_RL_AO 1 - CUTOFF_RADIUS_RL_RI 1 - CUTOFF_RADIUS_RL_W 1 + CUTOFF_RADIUS_RL_AO 1.5 + CUTOFF_RADIUS_RL_RI 1.5 + CUTOFF_RADIUS_RL_W 1.5 GRID_SELECT 1 NUM_TIME_FREQ_POINTS 10 N_PANELS 2 - N_PROCS_PER_ATOM_Z_LP 2 RI_RS &END GW &END BANDSTRUCTURE diff --git a/tests/QS/regtest-gw-realspace/TEST_FILES.toml b/tests/QS/regtest-gw-realspace/TEST_FILES.toml index 2c5df16d06..0be69d8db7 100644 --- a/tests/QS/regtest-gw-realspace/TEST_FILES.toml +++ b/tests/QS/regtest-gw-realspace/TEST_FILES.toml @@ -18,8 +18,8 @@ {matcher="E_RIRS_LUMO", tol=1e-03, ref=17.425}, {matcher="E_G0W0_direct_gap", tol=1e-03, ref=23.517}] -"06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp" = [{matcher="E_RIRS_HOMO", tol=1e-03, ref=150.081}, - {matcher="E_RIRS_LUMO", tol=1e-03, ref=23.808}, - {matcher="E_G0W0_direct_gap", tol=1e-03, ref=-126.273}] +"06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp" = [{matcher="E_RIRS_HOMO", tol=1e-03, ref=-6.234}, + {matcher="E_RIRS_LUMO", tol=1e-03, ref=18.334}, + {matcher="E_G0W0_direct_gap", tol=1e-03, ref=24.567}] #EOF From a660c7f12871c28288de0bf8fe4aac17c1c84b59 Mon Sep 17 00:00:00 2001 From: SY Wang Date: Thu, 23 Jul 2026 21:17:52 +0800 Subject: [PATCH 24/30] Fix duplicated regtest duration accounting for multiple matchers (#5615) --- tests/do_regtest.py | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/tests/do_regtest.py b/tests/do_regtest.py index 045ce266f7..a065373ea0 100755 --- a/tests/do_regtest.py +++ b/tests/do_regtest.py @@ -209,7 +209,7 @@ async def main() -> None: print("\n".join(r.error for r in all_results if r.error)) print("\n------------------------------- Timings --------------------------------") - timings = sorted(r.duration for r in all_results) + timings = sorted(r.duration for r in all_results if r.duration) print('Plot: name="timings", title="Timing Distribution", ylabel="time [s]"') for p in (100, 99, 98, 95, 90, 80): y = percentile(timings, p / 100.0) @@ -219,7 +219,9 @@ async def main() -> None: if cfg.flag_slow: print("\n" + "-" * 15 + "--------------- Slow Tests ---------------" + "-" * 15) threshold = 2 * percentile(timings, 0.95) - outliers = [r for r in all_results if r.duration > 0.95 * threshold] + outliers = [ + r for r in all_results if r.duration and r.duration > 0.95 * threshold + ] maybe_slow = [r for r in outliers if r.fullname not in cfg.slow_suppressions] num_suppressed = len(outliers) - len(maybe_slow) rerun_tasks: List[Task[BatchResult]] = [] @@ -228,8 +230,14 @@ async def main() -> None: rerun_tasks.append(asyncio.get_event_loop().create_task(run_batch(b, cfg))) rerun_times: Dict[str, float] = {} for t in await asyncio.gather(*rerun_tasks): - rerun_times.update({r.fullname: r.duration for r in t.results}) - stats = {r.fullname: [r.duration, rerun_times[r.fullname]] for r in maybe_slow} + rerun_times.update( + {r.fullname: r.duration for r in t.results if r.duration} + ) + stats = { + r.fullname: [r.duration, rerun_times[r.fullname]] + for r in maybe_slow + if r.duration + } slow_tests = {k: v for k, v in stats.items() if mean(v) - stdev(v) > threshold} print(f"Duration threshold (2x 95th %ile): {threshold:.2f} sec") print(f"Found {len(slow_tests)} slow tests ({num_suppressed} suppressed):") @@ -424,7 +432,7 @@ class TestResult: batch: Batch, test: Union[Regtest, Unittest], spec: Optional[Dict[str, Any]], - duration: float, + duration: Optional[float], status: TestStatus, error: Optional[str] = None, value: Optional[float] = None, @@ -443,7 +451,8 @@ class TestResult: if self.spec and len(self.test.matcher_specs) > 1: display_name += f":{self.spec.get('matcher', '???')}" value = f"{self.value:.10g}" if self.value else "-" - return f" {display_name :<80s} {value :>17} {self.status :>12s} ( {self.duration:6.2f} sec)" + timing = f" ( {self.duration:6.2f} sec)" if self.duration else "" + return f" {display_name :<80s} {value :>17} {self.status :>12s}{timing}" # ====================================================================================== @@ -451,7 +460,7 @@ class BatchResult: def __init__(self, batch: Batch, results: List[TestResult]): self.batch = batch self.results = results - self.duration = sum(float(r.duration) for r in results) + self.duration = sum(r.duration for r in results if r.duration) # ====================================================================================== @@ -667,9 +676,10 @@ def eval_regtest( if not test.matcher_specs: return [TestResult(batch, test, None, duration, "OK")] - # run the matchers + # Only the first matcher carries the duration of the single test execution. results = [] - for spec in test.matcher_specs: + for i, spec in enumerate(test.matcher_specs): + matcher_duration = duration if i == 0 else None spec = dict(spec) # shallow copy so we can pop without mutating the original alt_file = spec.pop("file", None) if alt_file: @@ -677,7 +687,7 @@ def eval_regtest( if not alt_path.exists(): err = f"{error}Spec: {spec}\nExpected output file not found: {alt_path}" results += [ - TestResult(batch, test, spec, duration, "WRONG RESULT", err) + TestResult(batch, test, spec, matcher_duration, "WRONG RESULT", err) ] continue match_output = alt_path.read_bytes().decode("utf8", errors="replace") @@ -686,7 +696,9 @@ def eval_regtest( m = run_matcher(match_output, **spec) if m.error: m.error = f"{error}Spec: {spec}\n{m.error}" - results += [TestResult(batch, test, spec, duration, m.status, m.error, m.value)] + results += [ + TestResult(batch, test, spec, matcher_duration, m.status, m.error, m.value) + ] return results From 8e6f22232ba1677facd6f392b3f08bc324978318 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jonas=20H=C3=A4nseroth?= <126775544+jhaens@users.noreply.github.com> Date: Fri, 24 Jul 2026 11:33:43 +0200 Subject: [PATCH 25/30] Fix unix socket prefix - Make UNIX socket prefix configurable via DRIVER%PREFIX (#5559) --- src/ipi_driver.F | 12 ++++++++++-- src/ipi_server.F | 12 ++++++++++-- src/sockets.c | 8 +++++--- src/start/input_cp2k_motion.F | 10 +++++++++- tests/i-PI/ipi_client.inp | 1 + tests/i-PI/ipi_server.inp | 3 ++- tools/docker/scripts/test_i-pi.sh | 6 +++--- 7 files changed, 40 insertions(+), 12 deletions(-) diff --git a/src/ipi_driver.F b/src/ipi_driver.F index 19404bd82f..2cc3412c97 100644 --- a/src/ipi_driver.F +++ b/src/ipi_driver.F @@ -87,7 +87,7 @@ CONTAINS #else INTEGER, PARAMETER :: MSGLEN = 12 - CHARACTER(len=default_path_length) :: c_hostname, drv_hostname + CHARACTER(len=default_path_length) :: c_hostname, drv_hostname, drv_prefix CHARACTER(LEN=default_string_length) :: header INTEGER :: drv_port, handle, i_drv_unix, & idir, ii, inet, ip, iwait, & @@ -132,6 +132,7 @@ CONTAINS CALL section_vals_val_get(drv_section, "HOST", c_val=drv_hostname) CALL section_vals_val_get(drv_section, "PORT", i_val=drv_port) CALL section_vals_val_get(drv_section, "UNIX", l_val=drv_unix) + CALL section_vals_val_get(drv_section, "PREFIX", c_val=drv_prefix) CALL section_vals_val_get(drv_section, "SLEEP_TIME", r_val=sleeptime) CPASSERT(sleeptime >= 0) @@ -145,7 +146,14 @@ CONTAINS WRITE (output_unit, *) "@ INPUT DATA: ", TRIM(drv_hostname), drv_port, drv_unix END IF - c_hostname = TRIM(drv_hostname)//C_NULL_CHAR + IF (drv_unix) THEN + ! for UNIX sockets, HOST names the socket file which lives at + ! /tmp/_ (PREFIX must match the peer's convention, + ! e.g. "ipi" for i-PI) + c_hostname = "/tmp/"//TRIM(drv_prefix)//"_"//TRIM(drv_hostname)//C_NULL_CHAR + ELSE + c_hostname = TRIM(drv_hostname)//C_NULL_CHAR + END IF IF (ionode) CALL open_connect_socket(socket, i_drv_unix, drv_port, c_hostname) NULLIFY (wait_msg) diff --git a/src/ipi_server.F b/src/ipi_server.F index 488e5a19b4..14146f1a6d 100644 --- a/src/ipi_server.F +++ b/src/ipi_server.F @@ -87,7 +87,7 @@ CONTAINS CALL timeset(routineN, handle) CPABORT("CP2K was compiled with the __NO_SOCKETS option!") #else - CHARACTER(len=default_path_length) :: c_hostname, drv_hostname + CHARACTER(len=default_path_length) :: c_hostname, drv_hostname, drv_prefix INTEGER :: drv_port, handle, i_drv_unix, & output_unit, socket, comm_socket CHARACTER(len=msglength) :: msgbuffer @@ -102,6 +102,7 @@ CONTAINS CALL section_vals_val_get(driver_section, "HOST", c_val=drv_hostname) CALL section_vals_val_get(driver_section, "PORT", i_val=drv_port) CALL section_vals_val_get(driver_section, "UNIX", l_val=drv_unix) + CALL section_vals_val_get(driver_section, "PREFIX", c_val=drv_prefix) IF (output_unit > 0) THEN WRITE (output_unit, *) "@ i-PI SERVER BEING STARTED" WRITE (output_unit, *) "@ HOSTNAME: ", TRIM(drv_hostname) @@ -115,7 +116,14 @@ CONTAINS i_drv_unix = 1 ! a bit convoluted. socket.c uses a different convention... IF (drv_unix) i_drv_unix = 0 - c_hostname = TRIM(drv_hostname)//C_NULL_CHAR + IF (drv_unix) THEN + ! for UNIX sockets, HOST names the socket file which lives at + ! /tmp/_ (PREFIX must match the peer's convention, + ! e.g. "ipi" for i-PI) + c_hostname = "/tmp/"//TRIM(drv_prefix)//"_"//TRIM(drv_hostname)//C_NULL_CHAR + ELSE + c_hostname = TRIM(drv_hostname)//C_NULL_CHAR + END IF IF (ionode) THEN CALL open_bind_socket(socket, i_drv_unix, drv_port, c_hostname) CALL listen_socket(socket, 1_c_int) diff --git a/src/sockets.c b/src/sockets.c index dc2e00afe6..067635251f 100644 --- a/src/sockets.c +++ b/src/sockets.c @@ -61,7 +61,10 @@ * \param port The port number for the socket to be created. Low numbers are * often reserved for important channels, so use of numbers of 4 * or more digits is recommended. - * \param host The name of the host server. + * \param host The name of the host server (inet socket), or the full path + * of the UNIX socket file (unix socket). The caller is + * responsible for building this path, e.g. by prepending a + * prefix such as "/tmp/ipi_". * \note Fortran passes an extra argument for the string length, but this is * ignored here for C compatibility. ******************************************************************************/ @@ -105,8 +108,7 @@ void open_connect_socket(int *psockfd, int *inet, int *port, char *host) { // fills up details of the socket address memset(&serv_addr, 0, sizeof(serv_addr)); serv_addr.sun_family = AF_UNIX; - strcpy(serv_addr.sun_path, "/tmp/qiskit_"); - strcpy(serv_addr.sun_path + 12, host); + strcpy(serv_addr.sun_path, host); // creates the socket sockfd = socket(AF_UNIX, SOCK_STREAM, 0); diff --git a/src/start/input_cp2k_motion.F b/src/start/input_cp2k_motion.F index 550678a73f..cb9af737aa 100644 --- a/src/start/input_cp2k_motion.F +++ b/src/start/input_cp2k_motion.F @@ -1692,7 +1692,7 @@ CONTAINS CALL section_create(section, __LOCATION__, name="DRIVER", & description="This section defines the parameters needed to run in i-PI driver mode.", & citations=[Ceriotti2014, Kapil2016], & - n_keywords=3, n_subsections=0, repeats=.FALSE.) + n_keywords=4, n_subsections=0, repeats=.FALSE.) NULLIFY (keyword) CALL keyword_create(keyword, __LOCATION__, name="unix", & @@ -1716,6 +1716,14 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="PREFIX", & + description="Prefix used to build the path of the UNIX socket file, "// & + "as /tmp/_. Only relevant if UNIX is set to true.", & + usage="PREFIX ipi", & + default_c_val="ipi") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="SLEEP_TIME", & description="Sleeping time while waiting for for driver commands [s].", & usage="SLEEP_TIME 0.1", & diff --git a/tests/i-PI/ipi_client.inp b/tests/i-PI/ipi_client.inp index acce5d04fe..06bd0455fe 100644 --- a/tests/i-PI/ipi_client.inp +++ b/tests/i-PI/ipi_client.inp @@ -8,6 +8,7 @@ &DRIVER HOST myHost PORT 8421 + PREFIX ipi UNIX &END DRIVER &END MOTION diff --git a/tests/i-PI/ipi_server.inp b/tests/i-PI/ipi_server.inp index 1188cfb18e..db556e3fd5 100644 --- a/tests/i-PI/ipi_server.inp +++ b/tests/i-PI/ipi_server.inp @@ -6,8 +6,9 @@ &MOTION &DRIVER - HOST "/tmp/qiskit_myHost" + HOST myHost PORT 8421 + PREFIX ipi SLEEP_TIME 0.1 UNIX &END DRIVER diff --git a/tools/docker/scripts/test_i-pi.sh b/tools/docker/scripts/test_i-pi.sh index b5bb95951b..246160ef1b 100755 --- a/tools/docker/scripts/test_i-pi.sh +++ b/tools/docker/scripts/test_i-pi.sh @@ -40,7 +40,7 @@ ulimit -t ${TIMEOUT_SEC} # Limit cpu time. cd run_1 echo 42 > cp2k_exit_code sleep 10 # give i-pi some time to startup - OMP_NUM_THREADS=2 /opt/cp2k/build/bin/cp2k.ssmp ../in.cp2k + OMP_NUM_THREADS=2 timeout ${TIMEOUT_SEC} /opt/cp2k/build/bin/cp2k.ssmp ../in.cp2k echo $? > cp2k_exit_code ) & @@ -80,14 +80,14 @@ export OMP_NUM_THREADS=2 cd run_client echo 42 > cp2k_client_exit_code sleep 10 # give server some time to startup - /opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_client.inp + timeout ${TIMEOUT_SEC} /opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_client.inp echo $? > cp2k_client_exit_code ) & # launch cp2k in server mode mkdir -p run_server cd run_server -/opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_server.inp +timeout ${TIMEOUT_SEC} /opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_server.inp SERVER_EXIT_CODE=$? wait # for cp2k client to shutdown From 71c3ab0c0b558fd9ed8ea010a76e5cd388a72f96 Mon Sep 17 00:00:00 2001 From: Jiacheng Xu <13862180016@163.com> Date: Fri, 24 Jul 2026 17:35:44 +0800 Subject: [PATCH 26/30] build: drop UCC requirement for cuSOLVERMp 0.7+ (#5618) --- CMakeLists.txt | 7 ++-- cmake/modules/FindCuSolverMP.cmake | 11 +++--- docs/technologies/eigensolvers/cusolvermp.md | 1 - .../scripts/stage4/install_cusolvermp.sh | 36 ++++++++++--------- 4 files changed, 28 insertions(+), 27 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index cc5327c8b3..d9a6b3709f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1072,11 +1072,10 @@ if(CP2K_USE_CUSOLVER_MP) else() message(" - CAL Include directories: ${CP2K_CAL_INCLUDE_DIRS}\n" " - CAL Libraries: ${CP2K_CAL_LINK_LIBRARIES}") + message(" - UCC Include directories: ${CP2K_UCC_INCLUDE_DIRS}\n" + " - UCC Libraries: ${CP2K_UCC_LINK_LIBRARIES}\n" + " - UCX Libraries: ${CP2K_UCX_LINK_LIBRARIES}\n") endif() - - message(" - UCC Include directories: ${CP2K_UCC_INCLUDE_DIRS}\n" - " - UCC Libraries: ${CP2K_UCC_LINK_LIBRARIES}\n" - " - UCX Libraries: ${CP2K_UCX_LINK_LIBRARIES}\n") endif() if(CP2K_USE_LIBXC) diff --git a/cmake/modules/FindCuSolverMP.cmake b/cmake/modules/FindCuSolverMP.cmake index 4090c34311..86d171f3c6 100644 --- a/cmake/modules/FindCuSolverMP.cmake +++ b/cmake/modules/FindCuSolverMP.cmake @@ -12,8 +12,6 @@ include(FindPackageHandleStandardArgs) include(cp2k_utils) -find_package(ucc REQUIRED) - # First, find CuSolverMP library and headers cp2k_set_default_paths(CUSOLVER_MP "CUSOLVER_MP") cp2k_find_libraries(CUSOLVER_MP "cusolverMp") @@ -41,12 +39,13 @@ if(CP2K_CUSOLVER_MP_INCLUDE_DIRS) find_package(Nccl REQUIRED) set(CP2K_CUSOLVERMP_USE_NCCL ON - CACHE BOOL "CuSolverMP uses NCCL for communication") + CACHE BOOL "CuSolverMP uses NCCL for communication" FORCE) else() find_package(Cal REQUIRED) + find_package(ucc REQUIRED) set(CP2K_CUSOLVERMP_USE_NCCL OFF - CACHE BOOL "CuSolverMP uses Cal for communication") + CACHE BOOL "CuSolverMP uses Cal for communication" FORCE) endif() endif() @@ -64,13 +63,13 @@ if(NOT TARGET cp2k::CUSOLVER_MP::cusolver_mp) if(CP2K_CUSOLVERMP_USE_NCCL) set(_comm_lib "cp2k::NCCL::nccl") else() - set(_comm_lib "cp2k::CAL::cal") + set(_comm_lib "cp2k::CAL::cal;cp2k::UCC::ucc") endif() set_target_properties( cp2k::CUSOLVER_MP::cusolver_mp PROPERTIES INTERFACE_LINK_LIBRARIES - "${CP2K_CUSOLVER_MP_LINK_LIBRARIES};${_comm_lib};cp2k::UCC::ucc") + "${CP2K_CUSOLVER_MP_LINK_LIBRARIES};${_comm_lib}") set_target_properties( cp2k::CUSOLVER_MP::cusolver_mp PROPERTIES INTERFACE_INCLUDE_DIRECTORIES "${CP2K_CUSOLVER_MP_INCLUDE_DIRS}") diff --git a/docs/technologies/eigensolvers/cusolvermp.md b/docs/technologies/eigensolvers/cusolvermp.md index ac59195bdd..49861b5d94 100644 --- a/docs/technologies/eigensolvers/cusolvermp.md +++ b/docs/technologies/eigensolvers/cusolvermp.md @@ -13,7 +13,6 @@ tools for the solution of dense linear systems and eigenvalue problems. [cuSOLVERmp] >= 0.7 - [NCCL]: requires `libnccl.\*` in the `$PATH` -- [UCC]: requires `libucc.\*` and `libucs.\*` in the `$PATH` ## CMake diff --git a/tools/toolchain/scripts/stage4/install_cusolvermp.sh b/tools/toolchain/scripts/stage4/install_cusolvermp.sh index 2c08b8687f..be73615f2a 100755 --- a/tools/toolchain/scripts/stage4/install_cusolvermp.sh +++ b/tools/toolchain/scripts/stage4/install_cusolvermp.sh @@ -41,6 +41,10 @@ case "${with_cusolvermp}" in esac if [ "${with_cusolvermp}" != "__DONTUSE__" ]; then + # These values can be inherited from a previous toolchain run. Only export + # roots for the communication backend selected by the detected version. + unset NCCL_ROOT CAL_ROOT UCC_ROOT UCX_ROOT + if [ "${cusolvermp_header}" = "__FALSE__" ] || ! [ -f "${cusolvermp_header}" ]; then report_error ${LINENO} "Could not find cusolverMp.h." exit 1 @@ -57,6 +61,7 @@ if [ "${with_cusolvermp}" != "__DONTUSE__" ]; then cusolvermp_minor="${cusolvermp_minor:-0}" if [ "${cusolvermp_major}" -gt 0 ] || [ "${cusolvermp_minor}" -ge 7 ]; then + cusolvermp_comm_backend="nccl" nccl_lib="$(find_in_paths "libnccl.*" $LIB_PATHS)" if [ "${nccl_lib}" = "__FALSE__" ]; then report_error ${LINENO} "Could not find NCCL required by cuSOLVERMp ${cusolvermp_major}.${cusolvermp_minor}." @@ -64,43 +69,42 @@ if [ "${with_cusolvermp}" != "__DONTUSE__" ]; then fi NCCL_ROOT="$(dirname "$(dirname "${nccl_lib}")")" else + cusolvermp_comm_backend="cal" cal_lib="$(find_in_paths "libcal.*" $LIB_PATHS)" if [ "${cal_lib}" = "__FALSE__" ]; then report_error ${LINENO} "Could not find CAL required by cuSOLVERMp ${cusolvermp_major}.${cusolvermp_minor}." exit 1 fi CAL_ROOT="$(dirname "$(dirname "${cal_lib}")")" + ucc_lib="$(find_in_paths "libucc.*" $LIB_PATHS)" + ucx_lib="$(find_in_paths "libucs.*" $LIB_PATHS)" + if [ "${ucc_lib}" = "__FALSE__" ] || [ "${ucx_lib}" = "__FALSE__" ]; then + report_error ${LINENO} "Could not find UCC/UCX required by cuSOLVERMp ${cusolvermp_major}.${cusolvermp_minor}." + exit 1 + fi + UCC_ROOT="$(dirname "$(dirname "${ucc_lib}")")" + UCX_ROOT="$(dirname "$(dirname "${ucx_lib}")")" fi - ucc_lib="$(find_in_paths "libucc.*" $LIB_PATHS)" - ucx_lib="$(find_in_paths "libucs.*" $LIB_PATHS)" - if [ "${ucc_lib}" = "__FALSE__" ] || [ "${ucx_lib}" = "__FALSE__" ]; then - report_error ${LINENO} "Could not find UCC/UCX required by cuSOLVERMp." - exit 1 - fi - UCC_ROOT="$(dirname "$(dirname "${ucc_lib}")")" - UCX_ROOT="$(dirname "$(dirname "${ucx_lib}")")" - cat << EOF > "${BUILDDIR}/setup_cusolvermp" export CUSOLVERMP_VER="${cusolvermp_major}.${cusolvermp_minor}" export CUSOLVERMP_LIBS="${CUSOLVERMP_LIBS}" export CUSOLVER_MP_ROOT="${pkg_install_dir}" -export UCC_ROOT="${UCC_ROOT}" -export UCX_ROOT="${UCX_ROOT}" prepend_path CMAKE_PREFIX_PATH "${pkg_install_dir}" -prepend_path CMAKE_PREFIX_PATH "${UCC_ROOT}" -prepend_path CMAKE_PREFIX_PATH "${UCX_ROOT}" EOF - if [ -n "${NCCL_ROOT}" ]; then + if [ "${cusolvermp_comm_backend}" = "nccl" ]; then cat << EOF >> "${BUILDDIR}/setup_cusolvermp" export NCCL_ROOT="${NCCL_ROOT}" prepend_path CMAKE_PREFIX_PATH "${NCCL_ROOT}" EOF - fi - if [ -n "${CAL_ROOT}" ]; then + else cat << EOF >> "${BUILDDIR}/setup_cusolvermp" export CAL_ROOT="${CAL_ROOT}" prepend_path CMAKE_PREFIX_PATH "${CAL_ROOT}" +export UCC_ROOT="${UCC_ROOT}" +export UCX_ROOT="${UCX_ROOT}" +prepend_path CMAKE_PREFIX_PATH "${UCC_ROOT}" +prepend_path CMAKE_PREFIX_PATH "${UCX_ROOT}" EOF fi filter_setup "${BUILDDIR}/setup_cusolvermp" "${SETUPFILE}" From 79ce675bd20267a981d702c3c4569179730eacd9 Mon Sep 17 00:00:00 2001 From: SY Wang Date: Mon, 27 Jul 2026 16:59:23 +0800 Subject: [PATCH 27/30] Drop local Spack recipe of libxsmm (#5594) --- tools/spack/cp2k_deps_p.yaml | 4 -- tools/spack/cp2k_deps_s-static.yaml | 4 -- tools/spack/cp2k_deps_s.yaml | 4 -- .../cp2k_dev/packages/libxsmm/package.py | 60 ------------------- 4 files changed, 72 deletions(-) delete mode 100644 tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index 894db1cdb2..e0ad14f44b 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -70,10 +70,6 @@ spack: require: - "+fortran" - libxsmm: - require: - - "+fortran" - openblas: require: - "threads=openmp" diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index 3f3ef30670..58b5790d13 100644 --- a/tools/spack/cp2k_deps_s-static.yaml +++ b/tools/spack/cp2k_deps_s-static.yaml @@ -49,10 +49,6 @@ spack: - "+fortran" - "~shared" - libxsmm: - require: - - "+fortran" - openblas: require: - "+fortran" diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index f284738378..a13bdb0e29 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -56,10 +56,6 @@ spack: require: - "+fortran" - libxsmm: - require: - - "+fortran" - openblas: require: - "+fortran" diff --git a/tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py b/tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py deleted file mode 100644 index 308023e3b1..0000000000 --- a/tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py +++ /dev/null @@ -1,60 +0,0 @@ -# Copyright Spack Project Developers. See COPYRIGHT file for details. -# -# SPDX-License-Identifier: (Apache-2.0 OR MIT) - -from spack_repo.builtin.build_systems.cmake import CMakePackage - -from spack.package import * - - -class Libxsmm(CMakePackage): - """LIBXSMM is high performance library for small dense and sparse linear - algebra opertions incl. GEMM and elementwise primities often seen in deep - learning applications. It also serves as reference implementation of Tensor - Processing Primitives (TPP), a programming abstraction for efficient and - portable deep learning and HPC workloads. With version 2.0, LIBXSMM focuses - on providing a complete and architecture-portable set of TPPs (small dense - and sparse matrix operations as well as element-wise, GEMM, and BRGEMM - primitives) from which higher-level operators such as convolutions, - fully-connected layers, normalization, and pooling are composed. LIBXSMM - targets Intel Architecture with Intel SSE, Intel AVX, Intel AVX2, Intel - AVX‑512 (with VNNI and Bfloat16), and Intel AMX (Advanced Matrix - Extensions), AArch64 (NEON, SVE, and SME), and RISC‑V (RVV). Code generation - is mainly based on Just‑In‑Time (JIT) code specialization for - compiler-independent performance (matrix multiplications, matrix - transpose/copy, sparse functionality, and tensor primitives). LIBXSMM is - suitable for "build once and deploy everywhere", i.e., no special target - flags are needed to exploit the available performance. Supported GEMM - datatypes are: FP64, FP32, FP16, bfloat16, BF8, HF8, MXBF8, MXHF8, int16, - int8, MXBF6, MXHF6, MXFP4, int4, int2 and int1. Additionally, various - non-standard low precision combinations are supported.""" - - homepage = "https://github.com/libxsmm/libxsmm" - url = "https://github.com/libxsmm/libxsmm/archive/2.0.0.tar.gz" - git = "https://github.com/libxsmm/libxsmm.git" - - maintainers("hfp", "mkrack") - - license("BSD-3-Clause") - - version("main", branch="main") - version("2.0.0", sha256="7e532dc5520f864ce6d7f44f3fd50365e3edb23da97dbdc54fd53845d86a290b") - - variant("shared", default=False, description="With shared libraries.") - variant("fortran", default=True, description="With Fortran support.") - - depends_on("c", type="build") - depends_on("cxx", type="build") - depends_on("fortran", type="build", when="+fortran") - - depends_on("python", type="build") - depends_on("cmake@3.13:", type="build") - - requires("target=x86_64:", "target=aarch64:") - - def cmake_args(self): - spec = self.spec - return [ - self.define("BUILD_SHARED_LIBS", spec.satisfies("+shared")), - self.define("LIBXSMM_FORTRAN", spec.satisfies("+fortran")), - ] From 88ac9fdbaa27d593220004fed8cc76b291627b30 Mon Sep 17 00:00:00 2001 From: SY Wang Date: Tue, 28 Jul 2026 16:07:24 +0800 Subject: [PATCH 28/30] tblite v0.7.0 and trexio v2.6.1 (#5591) --- CMakeLists.txt | 6 +- src/arnoldi/arnoldi_geev.F | 22 +- src/tblite_interface.F | 2 +- tests/xTB/regtest-3-spglib/TEST_FILES.toml | 10 +- .../TEST_FILES.toml | 12 +- tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml | 8 +- .../xTB/regtest-tblite-ipea1/TEST_FILES.toml | 2 +- tools/spack/cp2k_deps_p.yaml | 4 +- tools/spack/cp2k_deps_s-static.yaml | 2 +- tools/spack/cp2k_deps_s.yaml | 4 +- .../cp2k_dev/packages/tblite/package.py | 57 +- .../stage8/dftd4-4.2.0-gradient-fixes.patch | 574 -------- .../scripts/stage8/install_tblite.sh | 16 +- .../simple-dftd3-1.4.0-gradient-fixes.patch | 1210 ----------------- tools/toolchain/scripts/tool_kit.sh | 2 +- 15 files changed, 65 insertions(+), 1866 deletions(-) delete mode 100644 tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch delete mode 100644 tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch diff --git a/CMakeLists.txt b/CMakeLists.txt index d9a6b3709f..f88fe00408 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -880,6 +880,7 @@ macro(cp2k_detect_dftd4_api) endmacro() if(CP2K_USE_DFTD4) + find_package(mctc-lib REQUIRED) # workaround: find mctc-lib first find_package(dftd4 REQUIRED) cp2k_detect_dftd4_api() endif() @@ -905,7 +906,10 @@ if(CP2K_USE_ACE) endif() if(CP2K_USE_TBLITE) - find_package(tblite REQUIRED) + find_package(tblite CONFIG REQUIRED) + if(tblite_VERSION VERSION_LESS "0.7.0") + message(FATAL_ERROR "tblite >= 0.7.0 is required; found ${tblite_VERSION}") + endif() add_library(cp2k::tblite INTERFACE IMPORTED) target_link_libraries( cp2k::tblite INTERFACE tblite::tblite mctc-lib::mctc-lib dftd4::dftd4 diff --git a/src/arnoldi/arnoldi_geev.F b/src/arnoldi/arnoldi_geev.F index 88390f9e2b..02af49f3c9 100644 --- a/src/arnoldi/arnoldi_geev.F +++ b/src/arnoldi/arnoldi_geev.F @@ -14,7 +14,12 @@ !> \author Florian Schiffmann ! ************************************************************************************************** MODULE arnoldi_geev - USE kinds, ONLY: dp +#if defined (__HAS_IEEE_EXCEPTIONS) + USE ieee_exceptions, ONLY: ieee_get_halting_mode, & + ieee_set_halting_mode, & + IEEE_ALL +#endif + USE kinds, ONLY: dp #include "../base/base_uses.f90" IMPLICIT NONE @@ -76,7 +81,9 @@ CONTAINS INTEGER :: ndim COMPLEX(dp), DIMENSION(:) :: evals COMPLEX(dp), DIMENSION(:, :) :: revec, levec - +#if defined (__HAS_IEEE_EXCEPTIONS) + LOGICAL, DIMENSION(5) :: halt +#endif INTEGER :: i, info REAL(dp) :: work(20*ndim) REAL(dp), DIMENSION(ndim) :: diag, offdiag @@ -93,8 +100,19 @@ CONTAINS END DO +#if defined (__HAS_IEEE_EXCEPTIONS) + CALL ieee_get_halting_mode(IEEE_ALL, halt) + CALL ieee_set_halting_mode(IEEE_ALL, .FALSE.) +#endif + CALL dstev(jobvr, ndim, diag, offdiag, evec_r, ndim, work, info) +#if defined (__HAS_IEEE_EXCEPTIONS) + CALL ieee_set_halting_mode(IEEE_ALL, halt) +#endif + + CPASSERT(info == 0) + DO i = 1, ndim revec(:, i) = CMPLX(evec_r(:, i), REAL(0.0, dp), dp) evals(i) = CMPLX(diag(i), 0.0, dp) diff --git a/src/tblite_interface.F b/src/tblite_interface.F index fe2be3e8d6..b0e92fde80 100644 --- a/src/tblite_interface.F +++ b/src/tblite_interface.F @@ -479,7 +479,7 @@ CONTAINS tb%mixer_memory = memory tb%mixer_solver = solver tb%mixer_damping = damping - tb%calc%mixer_damping = damping + tb%calc%mixer_input%damping = damping tb%mixer_omega0 = omega0 tb%mixer_min_weight = min_weight tb%mixer_max_weight = max_weight diff --git a/tests/xTB/regtest-3-spglib/TEST_FILES.toml b/tests/xTB/regtest-3-spglib/TEST_FILES.toml index 93d13db325..40cc925cc5 100644 --- a/tests/xTB/regtest-3-spglib/TEST_FILES.toml +++ b/tests/xTB/regtest-3-spglib/TEST_FILES.toml @@ -5,14 +5,14 @@ {matcher="N_special_kpoints", tol=0.0, ref=4}] "si_kp_tblite_mixer_spglib.inp" = [{matcher="E_total", tol=6.0E-7, ref=-14.73197235360055}, {matcher="N_special_kpoints", tol=0.0, ref=1}] -"bn_gfn1_kp_spglib_phase.inp" = [{matcher="E_total", tol=1.0E-10, ref=-18.86184474675449}, +"bn_gfn1_kp_spglib_phase.inp" = [{matcher="E_total", tol=1.0E-10, ref=-18.82000122976238}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"urea_gfn1_kp_spglib_boundary.inp" = [{matcher="E_total", tol=1.0E-10, ref=-30.88452203095506}, +"urea_gfn1_kp_spglib_boundary.inp" = [{matcher="E_total", tol=1.0E-10, ref=-30.89448648357339}, {matcher="N_special_kpoints", tol=0.0, ref=6}] -"urea_gfn1_kp_spglib_cellopt.inp" = [{matcher="M011", tol=1.0E-8, ref=-30.88891308320623}, +"urea_gfn1_kp_spglib_cellopt.inp" = [{matcher="M011", tol=1.0E-8, ref=-30.89506414487332}, {matcher="N_special_kpoints", tol=0.0, ref=6}] -"ice_viii_gfn2_kp_spglib_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-40.76699240612732}, +"ice_viii_gfn2_kp_spglib_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-40.71301330821884}, {matcher="N_special_kpoints", tol=0.0, ref=6}] -"ice_ix_gfn2_kp_k290_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-61.12461062282138}, +"ice_ix_gfn2_kp_k290_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-61.10270533472814}, {matcher="N_special_kpoints", tol=0.0, ref=14}] #EOF diff --git a/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml b/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml index b4bfd88fb4..c2523866db 100644 --- a/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml @@ -3,12 +3,12 @@ # e.g. 0 means do not compare anything, running is enough # 1 compares the last total energy in the file # for details see cp2k/tools/do_regtest -"COBe_gfn1_fd.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.4283186205}] -"CH2O_gfn1.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.8503584297}] -"Si_gfn1_fd.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.45211749988608}] -"Si_gfn1_kp.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.707430385147}] -"Si_gfn1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.722697896033}, +"COBe_gfn1_fd.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.42848707385935}] +"CH2O_gfn1.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.8504891036979}] +"Si_gfn1_fd.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.44320245934278}] +"Si_gfn1_kp.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.70433442694045}] +"Si_gfn1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.72017602003837}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Si_gfn1_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.722697896033}, +"Si_gfn1_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.72017602003837}, {matcher="N_special_kpoints", tol=0.0, ref=4}] #EOF diff --git a/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml b/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml index 267e910c69..f574587cde 100644 --- a/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml @@ -41,13 +41,13 @@ {matcher="N_special_kpoints", tol=0.0, ref=4}] "O2_gfn2_uks_kp_debug.inp" = [{matcher="DEBUG_stress_sum", tol=5.0E-6, ref=0.0000000}, {matcher="DEBUG_force_sum", tol=5.0E-6, ref=0.0000000}] -"Si_gfn2_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65677573470654}, +"Si_gfn2_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65663936611194}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Si_gfn2_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65677573470654}, +"Si_gfn2_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65663936611194}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Si_gfn2_kp_spglib_shifted.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65677573470655}, +"Si_gfn2_kp_spglib_shifted.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65663936611193}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Zn_fcc_gfn2_kp_k290.inp" = [{matcher="E_total", tol=1.0E-8, ref=-0.528740963544749}, +"Zn_fcc_gfn2_kp_k290.inp" = [{matcher="E_total", tol=1.0E-8, ref=-0.52857489142004}, {matcher="N_special_kpoints", tol=0.0, ref=4}] "Ar_fcc_gfn2_ls.inp" = [{matcher="M011", tol=5.0E-8, ref=-17.12154132132343}] "Ar_fcc_gfn2_force.inp" = [{matcher="M082", tol=1.0E-5, ref=0.0000000}] diff --git a/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml b/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml index e9b77d1cba..cfd0b34a94 100644 --- a/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml @@ -9,7 +9,7 @@ "CH2O_ipea1_force.inp" = [{matcher="M082", tol=1.0E-6, ref=0.0000000}] "COBe_ipea1_force.inp" = [{matcher="M082", tol=1.0E-6, ref=0.0000000}] "O2_ipea1_uks_force.inp" = [{matcher="M082", tol=1.0E-6, ref=0.0000000}] -"Si_ipea1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-15.179073369509}, +"Si_ipea1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-15.18478726953854}, {matcher="N_special_kpoints", tol=0.0, ref=4}] "Ar_fcc_ipea1_kp_debug.inp" = [{matcher="DEBUG_stress_sum", tol=1.0E-5, ref=0.0000000}, {matcher="DEBUG_force_sum", tol=1.0E-5, ref=0.0000000}, diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index e0ad14f44b..bf453fe460 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -227,8 +227,8 @@ spack: - "spfft@1.1.1" - "spglib@2.7.0" - "spla@1.6.1" - - "tblite@0.6.0" - - "trexio@2.5.0" + - "tblite@0.7.0" + - "trexio@2.6.1" view: default: diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index 58b5790d13..b6c58ab0ba 100644 --- a/tools/spack/cp2k_deps_s-static.yaml +++ b/tools/spack/cp2k_deps_s-static.yaml @@ -115,7 +115,7 @@ spack: - "openblas@0.3.33" - "pace@2025.12.4.1" - "spglib@2.7.0" - - "tblite@0.6.0" + - "tblite@0.7.0" view: default: diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index a13bdb0e29..af215c0c37 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -142,8 +142,8 @@ spack: - "pace@2025.12.4.1" - "py-torch@2.12.1" - "spglib@2.7.0" - - "tblite@0.6.0" - - "trexio@2.5.0" + - "tblite@0.7.0" + - "trexio@2.6.1" view: default: diff --git a/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py b/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py index 6d4f7c8177..88290e14a8 100644 --- a/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py +++ b/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py @@ -2,14 +2,13 @@ # # SPDX-License-Identifier: (Apache-2.0 OR MIT) -from spack_repo.builtin.build_systems import cmake, meson +from spack_repo.builtin.build_systems import cmake from spack_repo.builtin.build_systems.cmake import CMakePackage -from spack_repo.builtin.build_systems.meson import MesonPackage from spack.package import * -class Tblite(CMakePackage, MesonPackage): +class Tblite(CMakePackage): """Light-weight tight-binding framework""" homepage = "https://tblite.readthedocs.io" @@ -21,59 +20,31 @@ class Tblite(CMakePackage, MesonPackage): license("LGPL-3.0-or-later") version("main", branch="main") + version("0.7.0", sha256="3a7cb4602101e828caf41c38ca5e30f82de82d0d26d5db40168acdcad3462b92") version("0.6.0", sha256="372281aedb89234168d00eb691addb303197a9462a9c55d145c835f2cf5e8b42") version("0.5.0", sha256="e8a70b72ed0a0db0621c7958c63667a9cd008c97c868a4a417ff1bc262052ea8") version("0.4.0", sha256="5c2249b568bfd3b987d3b28f2cbfddd5c37f675b646e17c1e750428380af464b") version("0.3.0", sha256="46d77c120501ac55ed6a64dea8778d6593b26fb0653c591f8e8c985e35884f0a") - build_system("cmake", "meson", default="meson") - variant("openmp", default=True, description="Use OpenMP parallelisation") - variant("python", default=False, description="Build Python extension module") + variant("trexio", default=False, description="Enable TREXIO support", when="@0.7.0:") + variant("hdf5", default=False, description="Enable HDF5 support", when="@0.7.0:") depends_on("c", type="build") # generated depends_on("fortran", type="build") # generated depends_on("blas") depends_on("lapack") - - # for build_system in ["cmake", "meson"]: - # depends_on( - # f"mctc-lib@0.3: build_system={build_system}", when=f"build_system={build_system}" - # ) - # depends_on( - # f"simple-dftd3@0.3: build_system={build_system}", when=f"build_system={build_system}" - # ) - # depends_on(f"dftd4@3: build_system={build_system}", when=f"build_system={build_system}") - # depends_on(f"toml-f build_system={build_system}", when=f"build_system={build_system}") - - depends_on("dftd4@:3.7", when="@:0.5") - depends_on("meson@0.57.2:", type="build", when="build_system=meson") # mesonbuild/meson#8377 - depends_on("pkgconfig", type="build") - depends_on("py-cffi", when="+python") - depends_on("py-numpy", when="+python") - depends_on("python@3.6:", when="+python") - - extends("python", when="+python") - - -class MesonBuilder(meson.MesonBuilder): - def meson_args(self): - lapack = self.spec["lapack"].libs.names[0] - if lapack == "lapack": - lapack = "netlib" - elif lapack.startswith("mkl"): - lapack = "mkl" - elif lapack != "openblas": - lapack = "auto" - - return [ - "-Dlapack={0}".format(lapack), - "-Dopenmp={0}".format(str("+openmp" in self.spec).lower()), - "-Dpython={0}".format(str("+python" in self.spec).lower()), - ] + depends_on("trexio", when="+trexio") + depends_on("hdf5", when="+hdf5") class CMakeBuilder(cmake.CMakeBuilder): def cmake_args(self): - return [self.define_from_variant("WITH_OpenMP", "openmp")] + args = [self.define_from_variant("WITH_OpenMP", "openmp")] + if self.spec.satisfies("@0.7.0:"): + args += [ + self.define_from_variant("TBLITE_WITH_TREXIO", "trexio"), + self.define_from_variant("TBLITE_WITH_HDF5", "hdf5"), + ] + return args diff --git a/tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch b/tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch deleted file mode 100644 index e467cf852e..0000000000 --- a/tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch +++ /dev/null @@ -1,574 +0,0 @@ -diff --git a/src/dftd4/cutoff.f90 b/src/dftd4/cutoff.f90 -index 86a856b..40f299f 100644 ---- a/src/dftd4/cutoff.f90 -+++ b/src/dftd4/cutoff.f90 -@@ -20,7 +20,7 @@ module dftd4_cutoff - implicit none - private - -- public :: realspace_cutoff, get_lattice_points, smooth_cutoff -+ public :: realspace_cutoff, get_lattice_points, smooth_cutoff, apply_smooth_width_env - - - !> Coordination number cutoff -@@ -53,7 +53,7 @@ module dftd4_cutoff - real(wp) :: disp3 = disp3_default - - !> Width of smooth two-body interaction cutoff -- real(wp) :: width2 = 0.0_wp -+ real(wp) :: width2 = 0.05_wp - - !> Width of smooth three-body interaction cutoff - real(wp) :: width3 = 0.0_wp -@@ -70,6 +70,46 @@ module dftd4_cutoff - contains - - -+subroutine apply_smooth_width_env(cutoff) -+ -+ type(realspace_cutoff), intent(inout) :: cutoff -+ -+ call get_smooth_width("DFTD4_DISP2_SMOOTH_WIDTH", "TBLITE_D4_DISP2_SMOOTH_WIDTH", & -+ & cutoff%disp2, cutoff%width2) -+ call get_smooth_width("DFTD4_DISP3_SMOOTH_WIDTH", "TBLITE_D4_DISP3_SMOOTH_WIDTH", & -+ & cutoff%disp3, cutoff%width3) -+ -+end subroutine apply_smooth_width_env -+ -+ -+subroutine get_smooth_width(env1, env2, cutoff, width) -+ -+ character(len=*), intent(in) :: env1, env2 -+ real(wp), intent(in) :: cutoff -+ real(wp), intent(inout) :: width -+ -+ character(len=64) :: env -+ integer :: stat, io -+ real(wp) :: env_width -+ -+ call get_environment_variable(env1, env, status=stat) -+ if (stat /= 0 .or. len_trim(env) == 0) then -+ call get_environment_variable(env2, env, status=stat) -+ end if -+ if (stat == 0 .and. len_trim(env) > 0) then -+ read(env, *, iostat=io) env_width -+ if (io == 0) then -+ if (env_width > 0.0_wp .and. env_width < cutoff) then -+ width = env_width -+ else -+ width = 0.0_wp -+ end if -+ end if -+ end if -+ -+end subroutine get_smooth_width -+ -+ - !> Smooth polynomial switch for realspace cutoffs - pure subroutine smooth_cutoff(r, cutoff, width, sw, dswdr) - -diff --git a/src/dftd4/damping/atm.f90 b/src/dftd4/damping/atm.f90 -index c6162c9..3f4f46a 100644 ---- a/src/dftd4/damping/atm.f90 -+++ b/src/dftd4/damping/atm.f90 -@@ -145,23 +145,16 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, a1, a2, alp, - real(wp) :: r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang - real(wp) :: cutoff2, c9, dE, alp3, swij, swjk, swik, dswdr, sw - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - alp3 = alp / 3.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(dynamic) default(none) reduction(+:energy) & - !$omp shared(mol, trans, c6, s9, a1, a2, alp3, r4r2, cutoff2, cutoff, width) & - !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & - !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & - !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & -- !$omp& swij, swjk, swik, dswdr, sw) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(dynamic) -+ !$omp& swij, swjk, swik, dswdr, sw) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -212,20 +205,15 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, a1, a2, alp, - rr = ang*fdmp - - dE = rr * c9 * triple * third * sw -- energy_local(iat) = energy_local(iat) - dE -- energy_local(jat) = energy_local(jat) - dE -- energy_local(kat) = energy_local(kat) - dE -+ energy(iat) = energy(iat) - dE -+ energy(jat) = energy(jat) - dE -+ energy(kat) = energy(kat) - dE - end do - end do - end do - end do - end do -- !$omp end do -- !$omp critical (get_atm_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_atm_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_atm_dispersion_energy - -@@ -293,34 +281,19 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, a1, a2, alp, - real(wp) :: dGij(3), dGjk(3), dGik(3), dS(3, 3) - real(wp) :: swij, swjk, swik, dswijdr, dswjkdr, dswikdr, sw - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: dEdq_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - alp3 = alp / 3.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(dynamic) default(none) & -+ !$omp reduction(+:energy, gradient, sigma, dEdcn, dEdq) & - !$omp shared(mol, trans, c6, s9, a1, a2, alp, alp3, r4r2, cutoff2, & - !$omp& cutoff, width, dc6dcn, dc6dq) & - !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & - !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & - !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, dfdmp, ang, dang, & - !$omp& c9, dE, dE0, dE_third, dGij, dGjk, dGik, dS, swij, swjk, swik, & -- !$omp& dswijdr, dswjkdr, dswikdr, sw) & -- !$omp shared(energy, gradient, sigma, dEdcn, dEdq) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local, & -- !$omp& dEdq_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(dEdq_local(size(dEdq, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(dynamic) -+ !$omp& dswijdr, dswjkdr, dswikdr, sw) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -399,55 +372,42 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, a1, a2, alp, - - dE = dE0 * triple * sw - dE_third = dE * third -- energy_local(iat) = energy_local(iat) - dE_third -- energy_local(jat) = energy_local(jat) - dE_third -- energy_local(kat) = energy_local(kat) - dE_third -+ energy(iat) = energy(iat) - dE_third -+ energy(jat) = energy(jat) - dE_third -+ energy(kat) = energy(kat) - dE_third - -- gradient_local(:, iat) = gradient_local(:, iat) & -+ gradient(:, iat) = gradient(:, iat) & - & - (dGij + dGik) * triple -- gradient_local(:, jat) = gradient_local(:, jat) & -+ gradient(:, jat) = gradient(:, jat) & - & + (dGij - dGjk) * triple -- gradient_local(:, kat) = gradient_local(:, kat) & -+ gradient(:, kat) = gradient(:, kat) & - & + (dGik + dGjk) * triple - - dS(:, :) = spread(dGij, 1, 3) * spread(vij, 2, 3)& - & + spread(dGik, 1, 3) * spread(vik, 2, 3)& - & + spread(dGjk, 1, 3) * spread(vjk, 2, 3) - -- sigma_local(:, :) = sigma_local + dS * triple -+ sigma(:, :) = sigma(:, :) + dS * triple - -- dEdcn_local(iat) = dEdcn_local(iat) - dE * 0.5_wp & -+ dEdcn(iat) = dEdcn(iat) - dE * 0.5_wp & - & * (dc6dcn(iat, jat) / c6ij + dc6dcn(iat, kat) / c6ik) -- dEdcn_local(jat) = dEdcn_local(jat) - dE * 0.5_wp & -+ dEdcn(jat) = dEdcn(jat) - dE * 0.5_wp & - & * (dc6dcn(jat, iat) / c6ij + dc6dcn(jat, kat) / c6jk) -- dEdcn_local(kat) = dEdcn_local(kat) - dE * 0.5_wp & -+ dEdcn(kat) = dEdcn(kat) - dE * 0.5_wp & - & * (dc6dcn(kat, iat) / c6ik + dc6dcn(kat, jat) / c6jk) - -- dEdq_local(iat) = dEdq_local(iat) - dE * 0.5_wp & -+ dEdq(iat) = dEdq(iat) - dE * 0.5_wp & - & * (dc6dq(iat, jat) / c6ij + dc6dq(iat, kat) / c6ik) -- dEdq_local(jat) = dEdq_local(jat) - dE * 0.5_wp & -+ dEdq(jat) = dEdq(jat) - dE * 0.5_wp & - & * (dc6dq(jat, iat) / c6ij + dc6dq(jat, kat) / c6jk) -- dEdq_local(kat) = dEdq_local(kat) - dE * 0.5_wp & -+ dEdq(kat) = dEdq(kat) - dE * 0.5_wp & - & * (dc6dq(kat, iat) / c6ik + dc6dq(kat, jat) / c6jk) - end do - end do - end do - end do - end do -- !$omp end do -- !$omp critical (get_atm_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- dEdq(:) = dEdq(:) + dEdq_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_atm_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(dEdq_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_atm_dispersion_derivs - -diff --git a/src/dftd4/damping/rational.f90 b/src/dftd4/damping/rational.f90 -index 9d359c9..87e8f6b 100644 ---- a/src/dftd4/damping/rational.f90 -+++ b/src/dftd4/damping/rational.f90 -@@ -152,20 +152,13 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, r4r2, c6, ener - real(wp) :: vec(3), r2, r, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE - real(wp) :: sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r0ij, rrij, c6ij, & -- !$omp& t6, t8, edisp, dE, r, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& t6, t8, edisp, dE, r, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -188,19 +181,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, r4r2, c6, ener - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -+ energy(iat) = energy(iat) + dE - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -+ energy(jat) = energy(jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_energy - -@@ -256,29 +244,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, r4r2, c6, dc6d - real(wp) :: edisp0, gdisp0, edisp, gdisp, sw, dswdr - real(wp) :: dE, dG(3), dS(3, 3) - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: dEdq_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) & -+ !$omp reduction(+:energy, gradient, sigma, dEdcn, dEdq) & - !$omp shared(mol, self, c6, dc6dcn, dc6dq, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r0ij, rrij, c6ij, t6, t8, & -- !$omp& d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, r, sw, dswdr) & -- !$omp shared(energy, gradient, sigma, dEdcn, dEdq) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local, & -- !$omp& dEdq_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(dEdq_local(size(dEdq, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, r, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -310,35 +283,22 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, r4r2, c6, dc6d - dG(:) = -c6ij*gdisp*vec - dS(:, :) = spread(dG, 1, 3) * spread(vec, 2, 3) * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp -- dEdq_local(iat) = dEdq_local(iat) - dc6dq(iat, jat) * edisp -- sigma_local(:, :) = sigma_local + dS -+ energy(iat) = energy(iat) + dE -+ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp -+ dEdq(iat) = dEdq(iat) - dc6dq(iat, jat) * edisp -+ sigma(:, :) = sigma(:, :) + dS - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp -- dEdq_local(jat) = dEdq_local(jat) - dc6dq(jat, iat) * edisp -- gradient_local(:, iat) = gradient_local(:, iat) + dG -- gradient_local(:, jat) = gradient_local(:, jat) - dG -- sigma_local(:, :) = sigma_local + dS -+ energy(jat) = energy(jat) + dE -+ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp -+ dEdq(jat) = dEdq(jat) - dc6dq(jat, iat) * edisp -+ gradient(:, iat) = gradient(:, iat) + dG -+ gradient(:, jat) = gradient(:, jat) - dG -+ sigma(:, :) = sigma(:, :) + dS - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- dEdq(:) = dEdq(:) + dEdq_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(dEdq_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_derivs - -@@ -429,21 +389,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, r4r2, c6, e - real(wp) :: vec(3), r2, r, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE - real(wp) :: sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - if (abs(self%s6) < epsilon(1.0_wp) .and. abs(self%s8) < epsilon(1.0_wp)) return - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r0ij, rrij, c6ij, & -- !$omp& t6, t8, edisp, dE, r, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& t6, t8, edisp, dE, r, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -466,19 +419,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, r4r2, c6, e - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(jat, iat) = energy_local(jat, iat) + dE -+ energy(jat, iat) = energy(jat, iat) + dE - if (iat /= jat) then -- energy_local(iat, jat) = energy_local(iat, jat) + dE -+ energy(iat, jat) = energy(iat, jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion2_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion2_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion2 - -@@ -517,24 +465,17 @@ subroutine get_pairwise_dispersion3(self, mol, trans, cutoff, width, r4r2, c6, e - real(wp) :: r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang - real(wp) :: cutoff2, c9, dE, alp3, swij, swjk, swik, dswdr, sw - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - if (abs(self%s9) < epsilon(1.0_wp)) return - cutoff2 = cutoff*cutoff - alp3 = self%alp / 3.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, trans, c6, r4r2, cutoff2, cutoff, width, alp3, self) & - !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & - !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & - !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & -- !$omp& swij, swjk, swik, dswdr, sw) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& swij, swjk, swik, dswdr, sw) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -585,23 +526,18 @@ subroutine get_pairwise_dispersion3(self, mol, trans, cutoff, width, r4r2, c6, e - rr = ang*fdmp - - dE = rr * c9 * triple * sixth * sw -- energy_local(jat, iat) = energy_local(jat, iat) - dE -- energy_local(kat, iat) = energy_local(kat, iat) - dE -- energy_local(iat, jat) = energy_local(iat, jat) - dE -- energy_local(kat, jat) = energy_local(kat, jat) - dE -- energy_local(iat, kat) = energy_local(iat, kat) - dE -- energy_local(jat, kat) = energy_local(jat, kat) - dE -+ energy(jat, iat) = energy(jat, iat) - dE -+ energy(kat, iat) = energy(kat, iat) - dE -+ energy(iat, jat) = energy(iat, jat) - dE -+ energy(kat, jat) = energy(kat, jat) - dE -+ energy(iat, kat) = energy(iat, kat) - dE -+ energy(jat, kat) = energy(jat, kat) - dE - end do - end do - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion3_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion3_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion3 - -diff --git a/src/dftd4/disp.f90 b/src/dftd4/disp.f90 -index 73253ce..8524cef 100644 ---- a/src/dftd4/disp.f90 -+++ b/src/dftd4/disp.f90 -@@ -18,7 +18,7 @@ - module dftd4_disp - use, intrinsic :: iso_fortran_env, only : error_unit - use dftd4_blas, only : d4_gemv -- use dftd4_cutoff, only : realspace_cutoff, get_lattice_points -+ use dftd4_cutoff, only : realspace_cutoff, get_lattice_points, apply_smooth_width_env - use dftd4_damping, only : damping_param - use dftd4_data, only : get_covalent_rad - use dftd4_model, only : dispersion_model -@@ -70,9 +70,12 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) - real(wp), allocatable :: dEdcn(:), dEdq(:), energies(:) - real(wp), allocatable :: lattr(:, :) - type(error_type), allocatable :: error -+ type(realspace_cutoff) :: cutoff_eff - - mref = maxval(disp%ref) - grad = present(gradient).or.present(sigma) -+ cutoff_eff = cutoff -+ call apply_smooth_width_env(cutoff_eff) - - if (.not. allocated(disp%mchrg)) then - write(error_unit, '("[Error]:", 1x, a)') "Not supported for non-self-consistent D4 version" -@@ -80,8 +83,8 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) - end if - - allocate(cn(mol%nat)) -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) -- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, disp%en, cn) -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) -+ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, disp%en, cn) - - allocate(q(mol%nat)) - if (grad) allocate(dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat)) -@@ -109,8 +112,8 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) - sigma(:, :) = 0.0_wp - end if - -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) -- call param%get_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, disp%r4r2, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) -+ call param%get_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, disp%r4r2, & - & c6, dc6dcn, dc6dq, energies, dEdcn, dEdq, gradient, sigma) - if (grad) then - call d4_gemv(dqdr, dEdq, gradient, beta=1.0_wp) -@@ -121,11 +124,11 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) - call disp%weight_references(mol, cn, q, gwvec, gwdcn, gwdq) - call disp%get_atomic_c6(mol, gwvec, gwdcn, gwdq, c6, dc6dcn, dc6dq) - -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) -- call param%get_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, disp%r4r2, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) -+ call param%get_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, disp%r4r2, & - & c6, dc6dcn, dc6dq, energies, dEdcn, dEdq, gradient, sigma) - if (grad) then -- call add_coordination_number_derivs(mol, lattr, cutoff%cn, & -+ call add_coordination_number_derivs(mol, lattr, cutoff_eff%cn, & - & disp%rcov, disp%en, dEdcn, gradient, sigma) - end if - -@@ -213,6 +216,7 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) - integer :: mref - real(wp), allocatable :: cn(:), q(:), gwvec(:, :, :), c6(:, :), lattr(:, :) - type(error_type), allocatable :: error -+ type(realspace_cutoff) :: cutoff_eff - - if (.not. allocated(disp%mchrg)) then - write(error_unit, '("[Error]:", 1x, a)') "Not supported for non-self-consistent D4 version" -@@ -220,10 +224,12 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) - end if - - mref = maxval(disp%ref) -+ cutoff_eff = cutoff -+ call apply_smooth_width_env(cutoff_eff) - - allocate(cn(mol%nat)) -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) -- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, disp%en, cn) -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) -+ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, disp%en, cn) - - allocate(q(mol%nat)) - call get_charges(disp%mchrg, mol, error, q) -@@ -240,16 +246,16 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) - - energy2(:, :) = 0.0_wp - energy3(:, :) = 0.0_wp -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) -- call param%get_pairwise_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) -+ call param%get_pairwise_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, & - & disp%r4r2, c6, energy2) - - q(:) = 0.0_wp - call disp%weight_references(mol, cn, q, gwvec) - call disp%get_atomic_c6(mol, gwvec, c6=c6) - -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) -- call param%get_pairwise_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) -+ call param%get_pairwise_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, & - & disp%r4r2, c6, energy3) - - end subroutine get_pairwise_dispersion diff --git a/tools/toolchain/scripts/stage8/install_tblite.sh b/tools/toolchain/scripts/stage8/install_tblite.sh index 9c9654af8f..5932f6034c 100755 --- a/tools/toolchain/scripts/stage8/install_tblite.sh +++ b/tools/toolchain/scripts/stage8/install_tblite.sh @@ -6,10 +6,8 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -tblite_ver="0.6.0" -tblite_sha256="372281aedb89234168d00eb691addb303197a9462a9c55d145c835f2cf5e8b42" -tblite_sdftd3_ver="1.4.0" -tblite_dftd4_ver="4.2.0" +tblite_ver="0.7.0" +tblite_sha256="3a7cb4602101e828caf41c38ca5e30f82de82d0d26d5db40168acdcad3462b92" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh @@ -36,12 +34,6 @@ case "$with_tblite" in [ -d tblite-${tblite_ver} ] && rm -rf tblite-${tblite_ver} tar -xJf tblite-${tblite_ver}.tar.xz cd tblite-${tblite_ver} - - patch -l -d subprojects/s-dftd3 -p1 < "${SCRIPT_DIR}/stage8/simple-dftd3-${tblite_sdftd3_ver}-gradient-fixes.patch" \ - > simple_dftd3_gradient_fixes.patch.log 2>&1 || tail_excerpt simple_dftd3_gradient_fixes.patch.log - patch -l -d subprojects/dftd4 -p1 < "${SCRIPT_DIR}/stage8/dftd4-${tblite_dftd4_ver}-gradient-fixes.patch" \ - > dftd4_gradient_fixes.patch.log 2>&1 || tail_excerpt dftd4_gradient_fixes.patch.log - mkdir -p build && cd build cmake \ -DCMAKE_INSTALL_PREFIX="${pkg_install_dir}" \ @@ -52,9 +44,7 @@ case "$with_tblite" in .. \ > cmake.log 2>&1 || tail_excerpt cmake.log make install -j $(get_nprocs) > make.log 2>&1 || tail_excerpt make.log - write_checksums "${install_lock_file}" "${SCRIPT_DIR}/stage8/$(basename ${SCRIPT_NAME})" \ - "${SCRIPT_DIR}/stage8/simple-dftd3-${tblite_sdftd3_ver}-gradient-fixes.patch" \ - "${SCRIPT_DIR}/stage8/dftd4-${tblite_dftd4_ver}-gradient-fixes.patch" + write_checksums "${install_lock_file}" "${SCRIPT_DIR}/stage8/$(basename ${SCRIPT_NAME})" cd .. fi ;; diff --git a/tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch b/tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch deleted file mode 100644 index 05fa3542f9..0000000000 --- a/tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch +++ /dev/null @@ -1,1210 +0,0 @@ -diff --git a/src/dftd3/cutoff.f90 b/src/dftd3/cutoff.f90 -index 743774e..da2a0df 100644 ---- a/src/dftd3/cutoff.f90 -+++ b/src/dftd3/cutoff.f90 -@@ -18,7 +18,7 @@ module dftd3_cutoff - use mctc_env, only : wp - implicit none - -- public :: realspace_cutoff, get_lattice_points, smooth_cutoff -+ public :: realspace_cutoff, get_lattice_points, smooth_cutoff, apply_smooth_width_env - - - !> Coordination number cutoff -@@ -51,7 +51,7 @@ module dftd3_cutoff - real(wp) :: disp3 = disp3_default - - !> Width of smooth two-body interaction cutoff -- real(wp) :: width2 = 0.0_wp -+ real(wp) :: width2 = 0.05_wp - - !> Width of smooth three-body interaction cutoff - real(wp) :: width3 = 0.0_wp -@@ -68,6 +68,47 @@ module dftd3_cutoff - contains - - -+subroutine apply_smooth_width_env(cutoff) -+ type(realspace_cutoff), intent(inout) :: cutoff -+ -+ call get_smooth_width("SDFTD3_DISP2_SMOOTH_WIDTH", "DFTD3_DISP2_SMOOTH_WIDTH", & -+ & "TBLITE_D3_DISP2_SMOOTH_WIDTH", cutoff%disp2, cutoff%width2) -+ call get_smooth_width("SDFTD3_DISP3_SMOOTH_WIDTH", "DFTD3_DISP3_SMOOTH_WIDTH", & -+ & "TBLITE_D3_DISP3_SMOOTH_WIDTH", cutoff%disp3, cutoff%width3) -+ -+end subroutine apply_smooth_width_env -+ -+ -+subroutine get_smooth_width(env1, env2, env3, cutoff, width) -+ character(len=*), intent(in) :: env1, env2, env3 -+ real(wp), intent(in) :: cutoff -+ real(wp), intent(inout) :: width -+ -+ character(len=64) :: env -+ integer :: stat, io -+ real(wp) :: env_width -+ -+ call get_environment_variable(env1, env, status=stat) -+ if (stat /= 0 .or. len_trim(env) == 0) then -+ call get_environment_variable(env2, env, status=stat) -+ end if -+ if (stat /= 0 .or. len_trim(env) == 0) then -+ call get_environment_variable(env3, env, status=stat) -+ end if -+ if (stat == 0 .and. len_trim(env) > 0) then -+ read(env, *, iostat=io) env_width -+ if (io == 0) then -+ if (env_width > 0.0_wp .and. env_width < cutoff) then -+ width = env_width -+ else -+ width = 0.0_wp -+ end if -+ end if -+ end if -+ -+end subroutine get_smooth_width -+ -+ - !> Smooth polynomial switch for realspace cutoffs - pure subroutine smooth_cutoff(r, cutoff, width, sw, dswdr) - real(wp), intent(in) :: r -diff --git a/src/dftd3/damping/atm.f90 b/src/dftd3/damping/atm.f90 -index 419561a..9ce6521 100644 ---- a/src/dftd3/damping/atm.f90 -+++ b/src/dftd3/damping/atm.f90 -@@ -128,23 +128,16 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, rs9, alp, rv - real(wp) :: cutoff2, c9, dE, alp3 - real(wp) :: swij, swjk, swik, dswdr, sw - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - alp3 = alp / 3.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, trans, c6, s9, rs9, alp3, rvdw, cutoff2, cutoff, width) & - !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & - !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & - !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & -- !$omp& swij, swjk, swik, dswdr, sw) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& swij, swjk, swik, dswdr, sw) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -190,20 +183,15 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, rs9, alp, rv - rr = ang*fdmp - - dE = rr * c9 * triple * sw / 3.0_wp -- energy_local(iat) = energy_local(iat) - dE -- energy_local(jat) = energy_local(jat) - dE -- energy_local(kat) = energy_local(kat) - dE -+ energy(iat) = energy(iat) - dE -+ energy(jat) = energy(jat) - dE -+ energy(kat) = energy(kat) - dE - end do - end do - end do - end do - end do -- !$omp end do -- !$omp critical (get_atm_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_atm_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_atm_dispersion_energy - -@@ -262,30 +250,17 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, rs9, alp, rv - real(wp) :: alp3, r0r1alp3 - real(wp) :: swij, swjk, swik, dswijdr, dswjkdr, dswikdr, sw - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - alp3 = alp / 3.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & - !$omp shared(mol, trans, c6, s9, rs9, alp, alp3, rvdw, cutoff2, cutoff, width, dc6dcn) & - !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, ic, jc, vij, vjk, vik, & - !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & - !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, dfdmp, ang, & - !$omp& dang, c9, dE, dE0, dGij, dGjk, dGik, dS, r0r1alp3, swij, & -- !$omp& swjk, swik, dswijdr, dswjkdr, dswikdr, sw) & -- !$omp shared(energy, gradient, sigma, dEdcn) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& swjk, swik, dswijdr, dswjkdr, dswikdr, sw) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -359,13 +334,13 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, rs9, alp, rv - & - dE0 * dswjkdr / rjk * swij * swik * vjk - - dE = dE0 * triple * sw -- energy_local(iat) = energy_local(iat) - dE/3.0_wp -- energy_local(jat) = energy_local(jat) - dE/3.0_wp -- energy_local(kat) = energy_local(kat) - dE/3.0_wp -+ energy(iat) = energy(iat) - dE/3.0_wp -+ energy(jat) = energy(jat) - dE/3.0_wp -+ energy(kat) = energy(kat) - dE/3.0_wp - -- gradient_local(:, iat) = gradient_local(:, iat) - (dGij + dGik) * triple -- gradient_local(:, jat) = gradient_local(:, jat) + (dGij - dGjk) * triple -- gradient_local(:, kat) = gradient_local(:, kat) + (dGik + dGjk) * triple -+ gradient(:, iat) = gradient(:, iat) - (dGij + dGik) * triple -+ gradient(:, jat) = gradient(:, jat) + (dGij - dGjk) * triple -+ gradient(:, kat) = gradient(:, kat) + (dGik + dGjk) * triple - - do ic = 1, 3 - do jc = 1, 3 -@@ -374,31 +349,20 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, rs9, alp, rv - end do - end do - -- sigma_local(:, :) = sigma_local + dS * triple -+ sigma(:, :) = sigma(:, :) + dS * triple - -- dEdcn_local(iat) = dEdcn_local(iat) - dE * 0.5_wp & -+ dEdcn(iat) = dEdcn(iat) - dE * 0.5_wp & - & * (dc6dcn(iat, jat) / c6ij + dc6dcn(iat, kat) / c6ik) -- dEdcn_local(jat) = dEdcn_local(jat) - dE * 0.5_wp & -+ dEdcn(jat) = dEdcn(jat) - dE * 0.5_wp & - & * (dc6dcn(jat, iat) / c6ij + dc6dcn(jat, kat) / c6jk) -- dEdcn_local(kat) = dEdcn_local(kat) - dE * 0.5_wp & -+ dEdcn(kat) = dEdcn(kat) - dE * 0.5_wp & - & * (dc6dcn(kat, iat) / c6ik + dc6dcn(kat, jat) / c6jk) - end do - end do - end do - end do - end do -- !$omp end do -- !$omp critical (get_atm_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_atm_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_atm_dispersion_derivs - -@@ -444,24 +408,17 @@ subroutine get_atm_pairwise_dispersion(mol, trans, cutoff, width, s9, rs9, alp, - real(wp) :: cutoff2, c9, dE, alp3 - real(wp) :: swij, swjk, swik, dswdr, sw - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - if (abs(s9) < epsilon(1.0_wp)) return - cutoff2 = cutoff*cutoff - alp3 = alp / 3.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, trans, c6, cutoff2, cutoff, width, s9, rs9, alp3, rvdw) & - !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & - !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & - !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & -- !$omp& swij, swjk, swik, dswdr, sw) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& swij, swjk, swik, dswdr, sw) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -507,23 +464,18 @@ subroutine get_atm_pairwise_dispersion(mol, trans, cutoff, width, s9, rs9, alp, - rr = ang*fdmp - - dE = rr * c9 * triple * sw / 6.0_wp -- energy_local(jat, iat) = energy_local(jat, iat) - dE -- energy_local(kat, iat) = energy_local(kat, iat) - dE -- energy_local(iat, jat) = energy_local(iat, jat) - dE -- energy_local(kat, jat) = energy_local(kat, jat) - dE -- energy_local(iat, kat) = energy_local(iat, kat) - dE -- energy_local(jat, kat) = energy_local(jat, kat) - dE -+ energy(jat, iat) = energy(jat, iat) - dE -+ energy(kat, iat) = energy(kat, iat) - dE -+ energy(iat, jat) = energy(iat, jat) - dE -+ energy(kat, jat) = energy(kat, jat) - dE -+ energy(iat, kat) = energy(iat, kat) - dE -+ energy(jat, kat) = energy(jat, kat) - dE - end do - end do - end do - end do - end do -- !$omp end do -- !$omp critical (get_atm_pairwise_dispersion_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_atm_pairwise_dispersion_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_atm_pairwise_dispersion - -diff --git a/src/dftd3/damping/cso.f90 b/src/dftd3/damping/cso.f90 -index 4253577..8fc4032 100644 ---- a/src/dftd3/damping/cso.f90 -+++ b/src/dftd3/damping/cso.f90 -@@ -172,20 +172,13 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: c6ij, edisp, dE, sw, dswdr - real(wp) :: d6_6, a2r0ij, r4 - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, rrij, r0ij, rij, d6, ef, & -- !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -213,19 +206,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -+ energy(iat) = energy(iat) + dE - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -+ energy(jat) = energy(jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_energy_cso_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_dispersion_energy_cso_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_energy - -@@ -279,27 +267,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: dE, dG(3), dS(3, 3) - real(wp) :: d6_6, a2r0ij, r4 - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & - !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, rrij, r0ij, rij, d6, ef, & - !$omp& sf, sig, t6, c6ij, dsig, dt6, edisp0, gdisp0, edisp, gdisp, dE, & -- !$omp& dG, dS, d6_6, a2r0ij, r4, sw, dswdr) & -- !$omp shared(energy, gradient, sigma, dEdcn) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& dG, dS, d6_6, a2r0ij, r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -339,31 +314,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - end do - end do - -- energy_local(iat) = energy_local(iat) + dE -- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp -- sigma_local(:, :) = sigma_local(:, :) + dS -+ energy(iat) = energy(iat) + dE -+ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp -+ sigma(:, :) = sigma(:, :) + dS - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp -- gradient_local(:, iat) = gradient_local(:, iat) + dG -- gradient_local(:, jat) = gradient_local(:, jat) - dG -- sigma_local(:, :) = sigma_local(:, :) + dS -+ energy(jat) = energy(jat) + dE -+ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp -+ gradient(:, iat) = gradient(:, iat) + dG -+ gradient(:, jat) = gradient(:, jat) - dG -+ sigma(:, :) = sigma(:, :) + dS - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_derivs_cso_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_dispersion_derivs_cso_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_derivs - -@@ -452,20 +416,13 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - real(wp) :: c6ij, edisp, dE, sw, dswdr - real(wp) :: d6_6, a2r0ij, r4 - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, rrij, r0ij, rij, d6, ef, & -- !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -493,19 +450,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(jat, iat) = energy_local(jat, iat) + dE -+ energy(jat, iat) = energy(jat, iat) + dE - if (iat /= jat) then -- energy_local(iat, jat) = energy_local(iat, jat) + dE -+ energy(iat, jat) = energy(iat, jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion2_cso_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion2_cso_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion2 - -diff --git a/src/dftd3/damping/mzero.f90 b/src/dftd3/damping/mzero.f90 -index 301aaf1..230c965 100644 ---- a/src/dftd3/damping/mzero.f90 -+++ b/src/dftd3/damping/mzero.f90 -@@ -172,22 +172,15 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE - real(wp) :: irs6r0, irs8r0, betr0, sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - alp6 = self%alp - alp8 = self%alp + 2.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & -- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, irs6r0, irs8r0, betr0, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, irs6r0, irs8r0, betr0, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -218,19 +211,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -+ energy(iat) = energy(iat) + dE - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -+ energy(jat) = energy(jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_energy - -@@ -283,29 +271,16 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: edisp0, gdisp0, edisp, gdisp, cutoff2, r0ij, rrij, c6ij, dE, dG(3), dS(3, 3) - real(wp) :: irs6r0, irs8r0, betr0, betr02rs6, betr02rs8, sw, dswdr - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - alp6 = self%alp - alp8 = self%alp + 2.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & - !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r6, r8, t6, t8, d6, & - !$omp& d8, f6, f8, edisp0, gdisp0, edisp, gdisp, r0ij, rrij, c6ij, & -- !$omp& dE, dG, dS, irs6r0, irs8r0, betr0, betr02rs6, betr02rs8, sw, dswdr) & -- !$omp shared(energy, gradient, sigma, dEdcn) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& dE, dG, dS, irs6r0, irs8r0, betr0, betr02rs6, betr02rs8, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -352,31 +327,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - end do - end do - -- energy_local(iat) = energy_local(iat) + dE -- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp -- sigma_local(:, :) = sigma_local + dS -+ energy(iat) = energy(iat) + dE -+ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp -+ sigma(:, :) = sigma(:, :) + dS - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp -- gradient_local(:, iat) = gradient_local(:, iat) + dG -- gradient_local(:, jat) = gradient_local(:, jat) - dG -- sigma_local(:, :) = sigma_local + dS -+ energy(jat) = energy(jat) + dE -+ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp -+ gradient(:, iat) = gradient(:, iat) + dG -+ gradient(:, jat) = gradient(:, jat) - dG -+ sigma(:, :) = sigma(:, :) + dS - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_derivs - -@@ -464,22 +428,15 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - real(wp) :: vec(3), r2, r1, r6, r8, t6, t8, f6, f8, alp6, alp8 - real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE, sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - cutoff2 = cutoff*cutoff - alp6 = self%alp - alp8 = self%alp + 2.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & -- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -507,19 +464,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(jat, iat) = energy_local(jat, iat) + dE -+ energy(jat, iat) = energy(jat, iat) + dE - if (iat /= jat) then -- energy_local(iat, jat) = energy_local(iat, jat) + dE -+ energy(iat, jat) = energy(iat, jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion2_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion2_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion2 - -diff --git a/src/dftd3/damping/optimizedpower.f90 b/src/dftd3/damping/optimizedpower.f90 -index 9f365ac..0def41c 100644 ---- a/src/dftd3/damping/optimizedpower.f90 -+++ b/src/dftd3/damping/optimizedpower.f90 -@@ -172,21 +172,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4 - real(wp) :: sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & - !$omp& t8, edisp, dE, rb, ab, r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, & -- !$omp& r4, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -216,19 +209,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -+ energy(iat) = energy(iat) + dE - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -+ energy(jat) = energy(jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_energy - -@@ -282,27 +270,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: dE, dG(3), dS(3, 3), rb, ab - real(wp) :: r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4 - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & - !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r0ij, rrij, c6ij, & - !$omp& t6, t8, d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, rb, ab, & -- !$omp& r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4, sw, dswdr) & -- !$omp shared(energy, gradient, sigma, dEdcn) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -344,31 +319,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - end do - end do - -- energy_local(iat) = energy_local(iat) + dE -- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp -- sigma_local(:, :) = sigma_local + dS -+ energy(iat) = energy(iat) + dE -+ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp -+ sigma(:, :) = sigma(:, :) + dS - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp -- gradient_local(:, iat) = gradient_local(:, iat) + dG -- gradient_local(:, jat) = gradient_local(:, jat) - dG -- sigma_local(:, :) = sigma_local + dS -+ energy(jat) = energy(jat) + dE -+ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp -+ gradient(:, iat) = gradient(:, iat) + dG -+ gradient(:, jat) = gradient(:, jat) - dG -+ sigma(:, :) = sigma(:, :) + dS - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_derivs - -@@ -456,20 +420,13 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - real(wp) :: vec(3), r2, r1, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE, rb, ab - real(wp) :: sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & -- !$omp& t8, edisp, dE, rb, ab, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& t8, edisp, dE, rb, ab, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -493,19 +450,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(jat, iat) = energy_local(jat, iat) + dE -+ energy(jat, iat) = energy(jat, iat) + dE - if (iat /= jat) then -- energy_local(iat, jat) = energy_local(iat, jat) + dE -+ energy(iat, jat) = energy(iat, jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion2_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion2_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion2 - -diff --git a/src/dftd3/damping/rational.f90 b/src/dftd3/damping/rational.f90 -index a8edb7c..32aac1e 100644 ---- a/src/dftd3/damping/rational.f90 -+++ b/src/dftd3/damping/rational.f90 -@@ -170,20 +170,13 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: sw, dswdr - real(wp) :: r0ij2, r0ij6, r0ij8, r4 - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & -- !$omp& t8, edisp, dE, r0ij2, r0ij6, r0ij8, r4, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& t8, edisp, dE, r0ij2, r0ij6, r0ij8, r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -209,19 +202,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -+ energy(iat) = energy(iat) + dE - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -+ energy(jat) = energy(jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_energy - -@@ -275,27 +263,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: dE, dG(3), dS(3, 3) - real(wp) :: r0ij2, r0ij6, r0ij8, r4 - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & - !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r0ij, rrij, c6ij, & - !$omp& t6, t8, d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, & -- !$omp& r0ij2, r0ij6, r0ij8, r4, sw, dswdr) & -- !$omp shared(energy, gradient, sigma, dEdcn) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& r0ij2, r0ij6, r0ij8, r4, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -333,31 +308,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - end do - end do - -- energy_local(iat) = energy_local(iat) + dE -- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp -- sigma_local(:, :) = sigma_local + dS -+ energy(iat) = energy(iat) + dE -+ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp -+ sigma(:, :) = sigma(:, :) + dS - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp -- gradient_local(:, iat) = gradient_local(:, iat) + dG -- gradient_local(:, jat) = gradient_local(:, jat) - dG -- sigma_local(:, :) = sigma_local + dS -+ energy(jat) = energy(jat) + dE -+ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp -+ gradient(:, iat) = gradient(:, iat) + dG -+ gradient(:, jat) = gradient(:, jat) - dG -+ sigma(:, :) = sigma(:, :) + dS - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_derivs - -@@ -445,20 +409,13 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - real(wp) :: vec(3), r2, r1, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE - real(wp) :: sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - cutoff2 = cutoff*cutoff - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & -- !$omp& t8, edisp, dE, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& t8, edisp, dE, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -480,19 +437,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(jat, iat) = energy_local(jat, iat) + dE -+ energy(jat, iat) = energy(jat, iat) + dE - if (iat /= jat) then -- energy_local(iat, jat) = energy_local(iat, jat) + dE -+ energy(iat, jat) = energy(iat, jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion2_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion2_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion2 - -diff --git a/src/dftd3/damping/zero.f90 b/src/dftd3/damping/zero.f90 -index 2e3ed6e..e5b78ad 100644 ---- a/src/dftd3/damping/zero.f90 -+++ b/src/dftd3/damping/zero.f90 -@@ -170,22 +170,15 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE - real(wp) :: rs6r0, rs8r0, sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) - - cutoff2 = cutoff*cutoff - alp6 = self%alp - alp8 = self%alp + 2.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & -- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -215,19 +208,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(iat) = energy_local(iat) + dE -+ energy(iat) = energy(iat) + dE - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -+ energy(jat) = energy(jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_energy_) -- energy(:) = energy(:) + energy_local(:) -- !$omp end critical (get_dispersion_energy_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_energy - -@@ -280,29 +268,16 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - real(wp) :: edisp0, gdisp0, edisp, gdisp, cutoff2, r0ij, rrij, c6ij, dE, dG(3), dS(3, 3) - real(wp) :: rs6r0, rs8r0, sw, dswdr - -- ! Thread-private arrays for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:) -- real(wp), allocatable :: dEdcn_local(:) -- real(wp), allocatable :: gradient_local(:, :) -- real(wp), allocatable :: sigma_local(:, :) - - cutoff2 = cutoff*cutoff - alp6 = self%alp - alp8 = self%alp + 2.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & - !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, alp6, alp8, r4r2, rvdw) & - !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r6, r8, t6, t8, d6, & - !$omp& d8, f6, f8, edisp0, gdisp0, edisp, gdisp, r0ij, rrij, c6ij, dE, & -- !$omp& dG, dS, rs6r0, rs8r0, sw, dswdr) & -- !$omp shared(energy, gradient, sigma, dEdcn) & -- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) -- allocate(energy_local(size(energy, 1)), source=0.0_wp) -- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) -- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) -- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& dG, dS, rs6r0, rs8r0, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -346,31 +321,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 - end do - end do - -- energy_local(iat) = energy_local(iat) + dE -- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp -- sigma_local(:, :) = sigma_local + dS -+ energy(iat) = energy(iat) + dE -+ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp -+ sigma(:, :) = sigma(:, :) + dS - if (iat /= jat) then -- energy_local(jat) = energy_local(jat) + dE -- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp -- gradient_local(:, iat) = gradient_local(:, iat) + dG -- gradient_local(:, jat) = gradient_local(:, jat) - dG -- sigma_local(:, :) = sigma_local + dS -+ energy(jat) = energy(jat) + dE -+ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp -+ gradient(:, iat) = gradient(:, iat) + dG -+ gradient(:, jat) = gradient(:, jat) - dG -+ sigma(:, :) = sigma(:, :) + dS - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_dispersion_derivs_) -- energy(:) = energy(:) + energy_local(:) -- dEdcn(:) = dEdcn(:) + dEdcn_local(:) -- gradient(:, :) = gradient(:, :) + gradient_local(:, :) -- sigma(:, :) = sigma(:, :) + sigma_local(:, :) -- !$omp end critical (get_dispersion_derivs_) -- deallocate(energy_local) -- deallocate(dEdcn_local) -- deallocate(gradient_local) -- deallocate(sigma_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_dispersion_derivs - -@@ -459,22 +423,15 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE - real(wp) :: rs6r0, rs8r0, sw, dswdr - -- ! Thread-private array for reduction -- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) -- real(wp), allocatable :: energy_local(:, :) - - cutoff2 = cutoff*cutoff - alp6 = self%alp - alp8 = self%alp + 2.0_wp - -- !$omp parallel default(none) & -+ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & - !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & - !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & -- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) & -- !$omp shared(energy) & -- !$omp private(energy_local) -- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) -- !$omp do schedule(runtime) -+ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) - do iat = 1, mol%nat - izp = mol%id(iat) - do jat = 1, iat -@@ -504,19 +461,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, - - dE = -c6ij*edisp * 0.5_wp - -- energy_local(jat, iat) = energy_local(jat, iat) + dE -+ energy(jat, iat) = energy(jat, iat) + dE - if (iat /= jat) then -- energy_local(iat, jat) = energy_local(iat, jat) + dE -+ energy(iat, jat) = energy(iat, jat) + dE - end if - end do - end do - end do -- !$omp end do -- !$omp critical (get_pairwise_dispersion2_) -- energy(:, :) = energy(:, :) + energy_local(:, :) -- !$omp end critical (get_pairwise_dispersion2_) -- deallocate(energy_local) -- !$omp end parallel -+ !$omp end parallel do - - end subroutine get_pairwise_dispersion2 - -diff --git a/src/dftd3/disp.f90 b/src/dftd3/disp.f90 -index 413683f..c75fec8 100644 ---- a/src/dftd3/disp.f90 -+++ b/src/dftd3/disp.f90 -@@ -15,7 +15,7 @@ - ! along with s-dftd3. If not, see . - - module dftd3_disp -- use dftd3_cutoff, only : realspace_cutoff, get_lattice_points -+ use dftd3_cutoff, only : realspace_cutoff, get_lattice_points, apply_smooth_width_env - use dftd3_damping, only : damping_param - use dftd3_model, only : d3_model - use dftd3_ncoord, only : get_coordination_number, add_coordination_number_derivs -@@ -69,13 +69,16 @@ subroutine get_dispersion_atomic(mol, disp, param, cutoff, energies, gradient, s - real(wp), allocatable :: c6(:, :), dc6dcn(:, :) - real(wp), allocatable :: dEdcn(:) - real(wp), allocatable :: lattr(:, :) -+ type(realspace_cutoff) :: cutoff_eff - - mref = maxval(disp%ref) - grad = present(gradient).and.present(sigma) -+ cutoff_eff = cutoff -+ call apply_smooth_width_env(cutoff_eff) - - allocate(cn(mol%nat)) -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) -- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, cn) -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) -+ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, cn) - - allocate(gwvec(mref, mol%nat)) - if (grad) allocate(gwdcn(mref, mol%nat)) -@@ -92,15 +95,15 @@ subroutine get_dispersion_atomic(mol, disp, param, cutoff, energies, gradient, s - gradient(:, :) = 0.0_wp - sigma(:, :) = 0.0_wp - end if -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) -- call param%get_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, disp%rvdw, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) -+ call param%get_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, disp%rvdw, & - & disp%r4r2, c6, dc6dcn, energies, dEdcn, gradient, sigma) -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) -- call param%get_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, disp%rvdw, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) -+ call param%get_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, disp%rvdw, & - & disp%r4r2, c6, dc6dcn, energies, dEdcn, gradient, sigma) - if (grad) then -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) -- call add_coordination_number_derivs(mol, lattr, cutoff%cn, disp%rcov, dEdcn, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) -+ call add_coordination_number_derivs(mol, lattr, cutoff_eff%cn, disp%rcov, dEdcn, & - & gradient, sigma) - end if - -@@ -165,12 +168,15 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) - - integer :: mref - real(wp), allocatable :: cn(:), gwvec(:, :), c6(:, :), lattr(:, :) -+ type(realspace_cutoff) :: cutoff_eff - - mref = maxval(disp%ref) -+ cutoff_eff = cutoff -+ call apply_smooth_width_env(cutoff_eff) - - allocate(cn(mol%nat)) -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) -- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, cn) -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) -+ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, cn) - - allocate(gwvec(mref, mol%nat)) - call disp%weight_references(mol, cn, gwvec) -@@ -180,12 +186,12 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) - - energy2(:, :) = 0.0_wp - energy3(:, :) = 0.0_wp -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) -- call param%get_pairwise_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) -+ call param%get_pairwise_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, & - & disp%rvdw, disp%r4r2, c6, energy2) - -- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) -- call param%get_pairwise_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, & -+ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) -+ call param%get_pairwise_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, & - & disp%rvdw, disp%r4r2, c6, energy3) - - end subroutine get_pairwise_dispersion diff --git a/tools/toolchain/scripts/tool_kit.sh b/tools/toolchain/scripts/tool_kit.sh index 359faad536..f307b6d2f0 100644 --- a/tools/toolchain/scripts/tool_kit.sh +++ b/tools/toolchain/scripts/tool_kit.sh @@ -157,7 +157,7 @@ get_nprocs() { if [ -n "${NPROCS_OVERWRITE}" ]; then echo ${NPROCS_OVERWRITE} | sed 's/^0*//' elif $(command -v nproc > /dev/null 2>&1); then - echo $(nproc --all) + echo $(nproc) elif $(command -v sysctl > /dev/null 2>&1); then echo $(sysctl -n hw.ncpu) else From 9cbee8b47c1da0f8cb9f698eee35879e16dacdd6 Mon Sep 17 00:00:00 2001 From: Max Graml <78024843+MGraml@users.noreply.github.com> Date: Tue, 28 Jul 2026 17:10:00 +0200 Subject: [PATCH 29/30] Initial commit of linearized real time propagation of the Bethe Salpeter equation (linRTBSE) and open-shell for the existing BSE module (#5627) Co-authored-by: Copilot Co-authored-by: Claude Opus 4.7 --- src/CMakeLists.txt | 2 + src/bse_full_diag.F | 534 +++- src/bse_main.F | 309 +- src/bse_print.F | 126 +- src/bse_util.F | 363 ++- src/cp_control_utils.F | 43 +- src/emd/rt_bse.F | 282 +- src/emd/rt_bse_io.F | 521 ++- src/emd/rt_bse_linearized.F | 2841 +++++++++++++++++ src/emd/rt_bse_ri_rs.F | 759 +++++ src/emd/rt_bse_types.F | 665 +++- src/emd/rt_propagation_ft.F | 30 +- src/emd/rt_propagation_output.F | 192 +- src/greenx_interface.F | 33 +- src/gw_large_cell_gamma.F | 18 +- src/gw_large_cell_gamma_ri_rs.F | 49 +- src/gw_non_periodic_ri_rs.F | 15 +- src/gw_small_cell_full_kp.F | 2 +- src/gw_utils.F | 98 +- src/input_constants.F | 7 +- src/input_cp2k_dft.F | 145 +- src/input_cp2k_properties_dft.F | 14 +- src/mp2_gpw.F | 41 +- src/mp2_grids.F | 9 + src/mp2_integrals.F | 124 +- src/post_scf_bandstructure_types.F | 36 +- src/post_scf_bandstructure_utils.F | 36 +- src/rpa_gw_sigma_x.F | 2 +- src/rpa_main.F | 158 +- src/start/cp2k_runs.F | 8 +- tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp | 78 + tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp | 83 + tests/QS/regtest-bse/BASIS_def2_TZVP_orb | 47 + tests/QS/regtest-bse/BASIS_def2_TZVP_rifit | 61 + tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp | 79 + tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp | 83 + tests/QS/regtest-bse/TEST_FILES.toml | 11 + .../BASIS_MINIMAL | 31 + .../TEST_FILES.toml | 18 + .../h2_linrtbse_abba_rirs_open_shell.inp | 106 + .../h2_linrtbse_tda_full_rirs_open_shell.inp | 108 + .../h2_linrtbse_tda_open_shell_restart.inp | 107 + ...2_linrtbse_tda_open_shell_restart_cont.inp | 107 + .../BASIS_MINIMAL | 31 + .../TEST_FILES.toml | 44 + .../h2_linrtbse_abba_restart.inp | 103 + .../h2_linrtbse_abba_restart_cont.inp | 103 + .../h2_linrtbse_tda_enforce_restart.inp | 104 + .../h2_linrtbse_tda_enforce_restart_cont.inp | 104 + .../h2_linrtbse_tda_restart_chain.inp | 103 + .../h2_linrtbse_tda_restart_chain_cont1.inp | 103 + .../h2_linrtbse_tda_restart_chain_cont2.inp | 103 + .../h2_linrtbse_tda_rirs_restart.inp | 104 + .../h2_linrtbse_tda_rirs_restart_cont.inp | 104 + ..._linrtbse_tda_static_pol_shift_restart.inp | 109 + ...tbse_tda_static_pol_shift_restart_cont.inp | 109 + .../BASIS_MINIMAL | 31 + .../TEST_FILES.toml | 17 + .../h2_linrtbse_abba_full_rirs.inp | 103 + .../h2_linrtbse_abba_rirs.inp | 101 + .../h2_linrtbse_tda_full_rirs.inp | 103 + .../h2_linrtbse_tda_full_rirs_gridsel3.inp | 107 + .../ri_rs_grid/H_rirs.ion | 178 ++ .../QS/regtest-rtbse-linearized/BASIS_MINIMAL | 31 + .../regtest-rtbse-linearized/TEST_FILES.toml | 28 + .../h2_linrtbse_abba.inp | 100 + .../h2_linrtbse_abba_cutoff.inp | 102 + .../h2_linrtbse_abba_kernels_off.inp | 103 + .../h2_linrtbse_tda.inp | 100 + .../h2_linrtbse_tda_kernels_off.inp | 103 + .../h2_linrtbse_tda_static_pol_enforce_dt.inp | 105 + ...nrtbse_tda_static_pol_shift_enforce_dt.inp | 108 + tests/QS/regtest-rtbse/h2_delta_cont.inp | 4 + tests/SLOW_TESTS_SUPPRESSIONS | 7 + tests/TEST_DIRS | 4 + tests/matchers.py | 46 + 76 files changed, 10371 insertions(+), 715 deletions(-) create mode 100644 src/emd/rt_bse_linearized.F create mode 100644 src/emd/rt_bse_ri_rs.F create mode 100644 tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp create mode 100644 tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp create mode 100644 tests/QS/regtest-bse/BASIS_def2_TZVP_orb create mode 100644 tests/QS/regtest-bse/BASIS_def2_TZVP_rifit create mode 100644 tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp create mode 100644 tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp create mode 100644 tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL create mode 100644 tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml create mode 100644 tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp create mode 100644 tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp create mode 100644 tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp create mode 100644 tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL create mode 100644 tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp create mode 100644 tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp create mode 100644 tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion create mode 100644 tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL create mode 100644 tests/QS/regtest-rtbse-linearized/TEST_FILES.toml create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp create mode 100644 tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index c21217a7ac..92b24bfd04 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1053,7 +1053,9 @@ list( emd/rt_propagation_utils.F emd/rt_propagator_init.F emd/rt_bse.F + emd/rt_bse_linearized.F emd/rt_bse_io.F + emd/rt_bse_ri_rs.F emd/rt_bse_types.F) list( diff --git a/src/bse_full_diag.F b/src/bse_full_diag.F index b2d0ad2626..cf267f5bb4 100644 --- a/src/bse_full_diag.F +++ b/src/bse_full_diag.F @@ -22,8 +22,10 @@ MODULE bse_full_diag exciton_descr_type,& get_exciton_descriptors,& get_oscillator_strengths - USE bse_util, ONLY: comp_eigvec_coeff_BSE,& + USE bse_util, ONLY: assemble_joint_ov_slab,& + comp_eigvec_coeff_BSE,& fm_general_add_bse,& + get_bse_spin_block_layout,& get_multipoles_mo,& reshuffle_eigvec USE cp_blacs_env, ONLY: cp_blacs_env_create,& @@ -39,9 +41,11 @@ MODULE bse_full_diag cp_fm_struct_type USE cp_fm_types, ONLY: cp_fm_create,& cp_fm_get_info,& + cp_fm_get_submatrix,& cp_fm_release,& cp_fm_set_all,& cp_fm_to_fm,& + cp_fm_to_fm_submat,& cp_fm_type USE exstates_types, ONLY: excited_energy_type USE input_constants, ONLY: bse_screening_alpha,& @@ -92,32 +96,44 @@ CONTAINS homo, virtual, dimen_RI, mp2_env, & para_env, qs_env) - TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ij_bse, & + TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ij_bse, & fm_mat_S_ab_bse TYPE(cp_fm_type), INTENT(INOUT) :: fm_A - REAL(KIND=dp), DIMENSION(:) :: Eigenval - INTEGER, INTENT(IN) :: unit_nr, homo, virtual, dimen_RI + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval + INTEGER, INTENT(IN) :: unit_nr + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual + INTEGER, INTENT(IN) :: dimen_RI TYPE(mp2_type), INTENT(INOUT) :: mp2_env TYPE(mp_para_env_type), INTENT(INOUT) :: para_env TYPE(qs_environment_type), POINTER :: qs_env CHARACTER(LEN=*), PARAMETER :: routineN = 'create_A' - INTEGER :: a_virt_row, handle, i_occ_row, & - i_row_global, ii, j_col_global, jj, & - ncol_local_A, nrow_local_A, sizeeigen + INTEGER :: a_virt_row, handle, i_occ_row, i_row_global, ii, isp, j_col_global, jj, k_isp, & + k_ov, n_ov_joint, ncol_local_A, nrow_local_A, nspins, sizeeigen + INTEGER, ALLOCATABLE, DIMENSION(:) :: eig_offsets, n_ov, offsets INTEGER, DIMENSION(4) :: reordering INTEGER, DIMENSION(:), POINTER :: col_indices_A, row_indices_A REAL(KIND=dp) :: alpha, alpha_screening, eigen_diff TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_fm_struct_type), POINTER :: fm_struct_A, fm_struct_W - TYPE(cp_fm_type) :: fm_A_copy, fm_W + TYPE(cp_fm_struct_type), POINTER :: fm_struct_A, fm_struct_S_joint, & + fm_struct_W + TYPE(cp_fm_type) :: fm_A_copy, fm_S_joint, fm_W TYPE(dft_control_type), POINTER :: dft_control TYPE(excited_energy_type), POINTER :: ex_env TYPE(tddfpt2_control_type), POINTER :: tddfpt_control CALL timeset(routineN, handle) + nspins = SIZE(homo) + ALLOCATE (n_ov(nspins), offsets(nspins), eig_offsets(nspins)) + CALL get_bse_spin_block_layout(homo, virtual, n_ov, offsets, n_ov_joint) + ! Flat Eigenval layout: sigma-block isp at eig_offsets(isp)+1 .. eig_offsets(isp)+homo(isp)+virtual(isp) + eig_offsets(1) = 0 + DO isp = 2, nspins + eig_offsets(isp) = eig_offsets(isp - 1) + homo(isp - 1) + virtual(isp - 1) + END DO + NULLIFY (dft_control, tddfpt_control) CALL get_qs_env(qs_env, dft_control=dft_control) tddfpt_control => dft_control%tddfpt2_control @@ -133,6 +149,12 @@ CONTAINS CASE (bse_triplet) alpha = 0.0_dp END SELECT + ! For open-shell (nspins>1): each spin block contributes once; SPIN_CONFIG is ignored. + IF (nspins > 1) THEN + CALL cp_warn(__LOCATION__, & + "BSE: SPIN_CONFIG ignored for open-shell reference; using alpha=1.") + alpha = 1.0_dp + END IF IF (mp2_env%bse%screening_method == bse_screening_alpha) THEN alpha_screening = mp2_env%bse%screening_factor @@ -149,115 +171,141 @@ CONTAINS ! We create v_ia,jb and W_ij,ab, then we communicate entries from local W_ij,ab ! to the full matrix v_ia,jb. By adding these and the energy diffenences: v_ia,jb -> A_ia,jb ! We use the A matrix already from the start instead of v - CALL cp_fm_struct_create(fm_struct_A, context=fm_mat_S_ia_bse%matrix_struct%context, nrow_global=homo*virtual, & - ncol_global=homo*virtual, para_env=fm_mat_S_ia_bse%matrix_struct%para_env) + CALL cp_fm_struct_create(fm_struct_A, context=fm_mat_S_ia_bse(1)%matrix_struct%context, & + nrow_global=n_ov_joint, ncol_global=n_ov_joint, & + para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) CALL cp_fm_create(fm_A, fm_struct_A, name="fm_A_iajb") CALL cp_fm_set_all(fm_A, 0.0_dp) - IF (tddfpt_control%do_bse_w_only) THEN + ! fm_A_copy only used in the TDDFPT do_bse_w_only path (closed-shell only) + IF (tddfpt_control%do_bse_w_only .AND. nspins == 1) THEN CALL cp_fm_create(fm_A_copy, fm_struct_A, name="fm_A_iajb") CALL cp_fm_set_all(fm_A_copy, 0.0_dp) END IF - CALL cp_fm_struct_create(fm_struct_W, context=fm_mat_S_ab_bse%matrix_struct%context, nrow_global=homo**2, & - ncol_global=virtual**2, para_env=fm_mat_S_ab_bse%matrix_struct%para_env) - CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ijab") - CALL cp_fm_set_all(fm_W, 0.0_dp) - - ! Create A matrix from GW Energies, v_ia,jb and W_ij,ab (different blacs_env!) - ! v_ia,jb, which is directly initialized in A (with a factor of alpha) - ! v_ia,jb = \sum_P B^P_ia B^P_jb + ! Create A matrix from GW Energies, v_ia,jb and W_ij,ab + ! v_ia,jb = \sum_P B^P_ia B^P_jb (Coulomb) IF ((.NOT. tddfpt_control%do_bse) .AND. (.NOT. tddfpt_control%do_bse_w_only)) THEN - CALL parallel_gemm(transa="T", transb="N", m=homo*virtual, n=homo*virtual, k=dimen_RI, alpha=alpha, & - matrix_a=fm_mat_S_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, & - matrix_c=fm_A) + IF (nspins > 1) THEN + ! Assemble joint ia-slab for a single Coulomb gemm across all spin blocks + CALL cp_fm_struct_create(fm_struct_S_joint, & + context=fm_mat_S_ia_bse(1)%matrix_struct%context, & + nrow_global=dimen_RI, ncol_global=n_ov_joint, & + para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) + CALL cp_fm_create(fm_S_joint, fm_struct_S_joint, name="fm_S_ia_joint") + CALL cp_fm_set_all(fm_S_joint, 0.0_dp) + CALL assemble_joint_ov_slab(fm_mat_S_ia_bse, offsets, n_ov, dimen_RI, fm_S_joint) + CALL parallel_gemm(transa="T", transb="N", m=n_ov_joint, n=n_ov_joint, k=dimen_RI, & + alpha=alpha, matrix_a=fm_S_joint, matrix_b=fm_S_joint, beta=0.0_dp, & + matrix_c=fm_A) + CALL cp_fm_release(fm_S_joint) + CALL cp_fm_struct_release(fm_struct_S_joint) + ELSE + CALL parallel_gemm(transa="T", transb="N", m=homo(1)*virtual(1), n=homo(1)*virtual(1), & + k=dimen_RI, alpha=alpha, & + matrix_a=fm_mat_S_ia_bse(1), matrix_b=fm_mat_S_ia_bse(1), & + beta=0.0_dp, matrix_c=fm_A) + END IF END IF IF (unit_nr > 0 .AND. mp2_env%bse%bse_debug_print) THEN WRITE (unit_nr, '(T2,A10,T13,A16)') 'BSE|DEBUG|', 'Allocated A_iajb' END IF - ! If infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals - IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN - !W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab - CALL parallel_gemm(transa="T", transb="N", m=homo**2, n=virtual**2, k=dimen_RI, alpha=alpha_screening, & - matrix_a=fm_mat_S_bar_ij_bse, matrix_b=fm_mat_S_ab_bse, beta=0.0_dp, & - matrix_c=fm_W) - END IF + ! W term on sigma-diagonal blocks only: W^sigma_ij,ab = sum_P barB^P_ij B^P_ab + ! offsets(isp) places each block at the correct position in joint A. + ! For nspins=1: offsets(1)=0, equivalent to the original code. + DO isp = 1, nspins + IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN + CALL cp_fm_struct_create(fm_struct_W, context=fm_mat_S_ab_bse(isp)%matrix_struct%context, & + nrow_global=homo(isp)**2, ncol_global=virtual(isp)**2, & + para_env=fm_mat_S_ab_bse(isp)%matrix_struct%para_env) + CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ijab") + CALL cp_fm_set_all(fm_W, 0.0_dp) + !W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab + CALL parallel_gemm(transa="T", transb="N", m=homo(isp)**2, n=virtual(isp)**2, & + k=dimen_RI, alpha=alpha_screening, & + matrix_a=fm_mat_S_bar_ij_bse(isp), matrix_b=fm_mat_S_ab_bse(isp), & + beta=0.0_dp, matrix_c=fm_W) + reordering = [1, 3, 2, 4] + CALL fm_general_add_bse(fm_A, fm_W, -1.0_dp, homo(isp), virtual(isp), & + virtual(isp), virtual(isp), unit_nr, reordering, mp2_env, & + row_offset=offsets(isp), col_offset=offsets(isp)) + IF (nspins == 1 .AND. tddfpt_control%do_bse_w_only) THEN + CALL fm_general_add_bse(fm_A_copy, fm_W, -1.0_dp, homo(1), virtual(1), & + virtual(1), virtual(1), unit_nr, reordering, mp2_env) + END IF + ! W and A stash for TDDFPT path (closed-shell only; open-shell deferred) + IF (nspins == 1) THEN + IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. & + tddfpt_control%do_bse_gw_only) THEN + NULLIFY (ex_env) + CALL get_qs_env(qs_env, exstate_env=ex_env) + IF (.NOT. tddfpt_control%do_bse_gw_only) THEN + ALLOCATE (ex_env%bse_w_matrix_MO(1, 1)) + ALLOCATE (ex_env%bse_a_matrix_MO(1, 1)) + CALL cp_fm_create(ex_env%bse_w_matrix_MO(1, 1), fm_struct_W) + CALL cp_fm_create(ex_env%bse_a_matrix_MO(1, 1), fm_struct_A) + CALL cp_fm_to_fm(fm_W, ex_env%bse_w_matrix_MO(1, 1)) + IF (tddfpt_control%do_bse_w_only) THEN + CALL cp_fm_to_fm(fm_A_copy, ex_env%bse_a_matrix_MO(1, 1)) + ELSE + CALL cp_fm_to_fm(fm_A, ex_env%bse_a_matrix_MO(1, 1)) + END IF + END IF + END IF + END IF + CALL cp_fm_release(fm_W) + CALL cp_fm_struct_release(fm_struct_W) + END IF + END DO IF (unit_nr > 0 .AND. mp2_env%bse%bse_debug_print) THEN WRITE (unit_nr, '(T2,A10,T13,A16)') 'BSE|DEBUG|', 'Allocated W_ijab' END IF + IF (nspins == 1 .AND. tddfpt_control%do_bse_w_only) CALL cp_fm_release(fm_A_copy) - ! We start by moving data from local parts of W_ij,ab to the full matrix A_ia,jb using buffers - CALL cp_fm_get_info(matrix=fm_A, & - nrow_local=nrow_local_A, & - ncol_local=ncol_local_A, & - row_indices=row_indices_A, & - col_indices=col_indices_A) - ! Writing -1.0_dp * W_ij,ab to A_ia,jb, i.e. beta = -1.0_dp, - ! W_ij,ab: nrow_secidx_in = homo, ncol_secidx_in = virtual - ! A_ia,jb: nrow_secidx_out = virtual, ncol_secidx_out = virtual + ! Get local row/col indices for direct diagonal access + CALL cp_fm_get_info(matrix=fm_A, nrow_local=nrow_local_A, ncol_local=ncol_local_A, & + row_indices=row_indices_A, col_indices=col_indices_A) - ! If infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals - IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN - reordering = [1, 3, 2, 4] - CALL fm_general_add_bse(fm_A, fm_W, -1.0_dp, homo, virtual, & - virtual, virtual, unit_nr, reordering, mp2_env) - IF (tddfpt_control%do_bse_w_only) THEN - CALL fm_general_add_bse(fm_A_copy, fm_W, -1.0_dp, homo, virtual, & - virtual, virtual, unit_nr, reordering, mp2_env) - END IF - END IF - !full matrix W is not needed anymore, release it to save memory - IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. & - tddfpt_control%do_bse_gw_only) THEN - NULLIFY (ex_env) - CALL get_qs_env(qs_env, exstate_env=ex_env) - IF (.NOT. tddfpt_control%do_bse_gw_only) THEN - ALLOCATE (ex_env%bse_w_matrix_MO(1, 1)) ! for now only closed-shell - ALLOCATE (ex_env%bse_a_matrix_MO(1, 1)) ! for now only closed-shell - CALL cp_fm_create(ex_env%bse_w_matrix_MO(1, 1), fm_struct_W) - CALL cp_fm_create(ex_env%bse_a_matrix_MO(1, 1), fm_struct_A) - CALL cp_fm_to_fm(fm_W, ex_env%bse_w_matrix_MO(1, 1)) - IF (tddfpt_control%do_bse_w_only) THEN - CALL cp_fm_to_fm(fm_A_copy, ex_env%bse_a_matrix_MO(1, 1)) - ELSE - CALL cp_fm_to_fm(fm_A, ex_env%bse_a_matrix_MO(1, 1)) - END IF - END IF - END IF - CALL cp_fm_release(fm_W) - IF (tddfpt_control%do_bse_w_only) CALL cp_fm_release(fm_A_copy) - - !Now add the energy differences (ε_a-ε_i) on the diagonal (i.e. δ_ij δ_ab) of A_ia,jb + !Add (ε_a-ε_i) on the diagonal of each sigma-block; cross-spin blocks have no ε contribution. IF (.NOT. tddfpt_control%do_bse) THEN - DO ii = 1, nrow_local_A - - i_row_global = row_indices_A(ii) - - DO jj = 1, ncol_local_A - - j_col_global = col_indices_A(jj) - - IF (i_row_global == j_col_global) THEN - i_occ_row = (i_row_global - 1)/virtual + 1 - a_virt_row = MOD(i_row_global - 1, virtual) + 1 - eigen_diff = Eigenval(a_virt_row + homo) - Eigenval(i_occ_row) - fm_A%local_data(ii, jj) = fm_A%local_data(ii, jj) + eigen_diff - - END IF + DO ii = 1, nrow_local_A + i_row_global = row_indices_A(ii) + DO jj = 1, ncol_local_A + j_col_global = col_indices_A(jj) + IF (i_row_global == j_col_global) THEN + ! Decode spin: isp such that i_row_global in [offsets(isp)+1, offsets(isp)+n_ov(isp)] + isp = nspins + DO k_isp = 1, nspins - 1 + IF (i_row_global <= offsets(k_isp) + n_ov(k_isp)) THEN + isp = k_isp + EXIT + END IF + END DO + k_ov = i_row_global - offsets(isp) + i_occ_row = (k_ov - 1)/virtual(isp) + 1 + a_virt_row = MOD(k_ov - 1, virtual(isp)) + 1 + eigen_diff = Eigenval(eig_offsets(isp) + a_virt_row + homo(isp)) - & + Eigenval(eig_offsets(isp) + i_occ_row) + fm_A%local_data(ii, jj) = fm_A%local_data(ii, jj) + eigen_diff + END IF + END DO END DO - END DO END IF - IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. tddfpt_control%do_bse_gw_only) THEN - sizeeigen = SIZE(Eigenval) - ALLOCATE (ex_env%gw_eigen(sizeeigen)) ! for now only closed-shell - ex_env%gw_eigen(:) = Eigenval(:) + ! GW eigenvalue stash for TDDFPT path (closed-shell only) + IF (nspins == 1) THEN + IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. & + tddfpt_control%do_bse_gw_only) THEN + sizeeigen = SIZE(Eigenval) + ALLOCATE (ex_env%gw_eigen(sizeeigen)) + ex_env%gw_eigen(:) = Eigenval(:) + END IF END IF CALL cp_fm_struct_release(fm_struct_A) - CALL cp_fm_struct_release(fm_struct_W) + DEALLOCATE (n_ov, offsets, eig_offsets) CALL cp_blacs_env_release(blacs_env) @@ -283,32 +331,41 @@ CONTAINS SUBROUTINE create_B(fm_mat_S_ia_bse, fm_mat_S_bar_ia_bse, fm_B, & homo, virtual, dimen_RI, unit_nr, mp2_env) - TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ia_bse + TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ia_bse TYPE(cp_fm_type), INTENT(INOUT) :: fm_B - INTEGER, INTENT(IN) :: homo, virtual, dimen_RI, unit_nr + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual + INTEGER, INTENT(IN) :: dimen_RI, unit_nr TYPE(mp2_type), INTENT(INOUT) :: mp2_env CHARACTER(LEN=*), PARAMETER :: routineN = 'create_B' - INTEGER :: handle + INTEGER :: handle, isp, n_ov_joint, nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_ov, offsets INTEGER, DIMENSION(4) :: reordering REAL(KIND=dp) :: alpha, alpha_screening - TYPE(cp_fm_struct_type), POINTER :: fm_struct_v - TYPE(cp_fm_type) :: fm_W + TYPE(cp_fm_struct_type), POINTER :: fm_struct_B, fm_struct_S_joint, & + fm_struct_W + TYPE(cp_fm_type) :: fm_S_joint, fm_W CALL timeset(routineN, handle) + nspins = SIZE(homo) + ALLOCATE (n_ov(nspins), offsets(nspins)) + CALL get_bse_spin_block_layout(homo, virtual, n_ov, offsets, n_ov_joint) + IF (unit_nr > 0 .AND. mp2_env%bse%bse_debug_print) THEN WRITE (unit_nr, '(T2,A10,T13,A10)') 'BSE|DEBUG|', 'Creating B' END IF - ! Determines factor of exchange term, depending on requested spin configuration (cf. input_constants.F) + ! Coulomb prefactor: SPIN_CONFIG sector for closed shell; for open shell each spin block + ! contributes once (alpha=1). create_A already emits the SPIN_CONFIG-ignored warning. SELECT CASE (mp2_env%bse%bse_spin_config) CASE (bse_singlet) alpha = 2.0_dp CASE (bse_triplet) alpha = 0.0_dp END SELECT + IF (nspins > 1) alpha = 1.0_dp IF (mp2_env%bse%screening_method == bse_screening_alpha) THEN alpha_screening = mp2_env%bse%screening_factor @@ -316,40 +373,68 @@ CONTAINS alpha_screening = 1.0_dp END IF - CALL cp_fm_struct_create(fm_struct_v, context=fm_mat_S_ia_bse%matrix_struct%context, nrow_global=homo*virtual, & - ncol_global=homo*virtual, para_env=fm_mat_S_ia_bse%matrix_struct%para_env) - CALL cp_fm_create(fm_B, fm_struct_v, name="fm_B_iajb") + ! Joint B over all spin blocks: B_ia,jb = alpha*(ia|bj) - W^sigma_ib,aj (W spin-diagonal) + NULLIFY (fm_struct_B) + CALL cp_fm_struct_create(fm_struct_B, context=fm_mat_S_ia_bse(1)%matrix_struct%context, & + nrow_global=n_ov_joint, ncol_global=n_ov_joint, & + para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) + CALL cp_fm_create(fm_B, fm_struct_B, name="fm_B_iajb") CALL cp_fm_set_all(fm_B, 0.0_dp) - CALL cp_fm_create(fm_W, fm_struct_v, name="fm_W_ibaj") - CALL cp_fm_set_all(fm_W, 0.0_dp) + ! Coulomb v_ia,jb = sum_P B^P_ia B^P_jb (= (ia|bj)); cross-spin blocks filled automatically. + IF (nspins > 1) THEN + NULLIFY (fm_struct_S_joint) + CALL cp_fm_struct_create(fm_struct_S_joint, & + context=fm_mat_S_ia_bse(1)%matrix_struct%context, & + nrow_global=dimen_RI, ncol_global=n_ov_joint, & + para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) + CALL cp_fm_create(fm_S_joint, fm_struct_S_joint, name="fm_S_ia_joint") + CALL cp_fm_set_all(fm_S_joint, 0.0_dp) + CALL assemble_joint_ov_slab(fm_mat_S_ia_bse, offsets, n_ov, dimen_RI, fm_S_joint) + CALL parallel_gemm(transa="T", transb="N", m=n_ov_joint, n=n_ov_joint, k=dimen_RI, & + alpha=alpha, matrix_a=fm_S_joint, matrix_b=fm_S_joint, beta=0.0_dp, & + matrix_c=fm_B) + CALL cp_fm_release(fm_S_joint) + CALL cp_fm_struct_release(fm_struct_S_joint) + ELSE + CALL parallel_gemm(transa="T", transb="N", m=homo(1)*virtual(1), n=homo(1)*virtual(1), & + k=dimen_RI, alpha=alpha, & + matrix_a=fm_mat_S_ia_bse(1), matrix_b=fm_mat_S_ia_bse(1), & + beta=0.0_dp, matrix_c=fm_B) + END IF IF (unit_nr > 0 .AND. mp2_env%bse%bse_debug_print) THEN WRITE (unit_nr, '(T2,A10,T13,A16)') 'BSE|DEBUG|', 'Allocated B_iajb' END IF - ! v_ia,jb = \sum_P B^P_ia B^P_jb - CALL parallel_gemm(transa="T", transb="N", m=homo*virtual, n=homo*virtual, k=dimen_RI, alpha=alpha, & - matrix_a=fm_mat_S_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, & - matrix_c=fm_B) - ! If infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals + ! W^sigma_ib,aj = sum_P barB^P_ib B^P_aj on sigma-diagonal blocks only (offsets place them). + ! reordering [1,4,3,2] maps W_ib,ja -> B_ia,jb. For nspins=1: offsets(1)=0 (original code). IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN - ! W_ib,aj = \sum_P \bar{B}^P_ib B^P_aj - CALL parallel_gemm(transa="T", transb="N", m=homo*virtual, n=homo*virtual, k=dimen_RI, alpha=alpha_screening, & - matrix_a=fm_mat_S_bar_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, & - matrix_c=fm_W) - - ! from W_ib,ja to A_ia,jb (formally: W_ib,aj, but our internal indexorder is different) - ! Writing -1.0_dp * W_ib,ja to A_ia,jb, i.e. beta = -1.0_dp, - ! W_ib,ja: nrow_secidx_in = virtual, ncol_secidx_in = virtual - ! A_ia,jb: nrow_secidx_out = virtual, ncol_secidx_out = virtual - reordering = [1, 4, 3, 2] - CALL fm_general_add_bse(fm_B, fm_W, -1.0_dp, virtual, virtual, & - virtual, virtual, unit_nr, reordering, mp2_env) + DO isp = 1, nspins + NULLIFY (fm_struct_W) + CALL cp_fm_struct_create(fm_struct_W, & + context=fm_mat_S_ia_bse(isp)%matrix_struct%context, & + nrow_global=homo(isp)*virtual(isp), & + ncol_global=homo(isp)*virtual(isp), & + para_env=fm_mat_S_ia_bse(isp)%matrix_struct%para_env) + CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ibaj") + CALL cp_fm_set_all(fm_W, 0.0_dp) + CALL parallel_gemm(transa="T", transb="N", m=homo(isp)*virtual(isp), & + n=homo(isp)*virtual(isp), k=dimen_RI, alpha=alpha_screening, & + matrix_a=fm_mat_S_bar_ia_bse(isp), matrix_b=fm_mat_S_ia_bse(isp), & + beta=0.0_dp, matrix_c=fm_W) + reordering = [1, 4, 3, 2] + CALL fm_general_add_bse(fm_B, fm_W, -1.0_dp, virtual(isp), virtual(isp), & + virtual(isp), virtual(isp), unit_nr, reordering, mp2_env, & + row_offset=offsets(isp), col_offset=offsets(isp)) + CALL cp_fm_release(fm_W) + CALL cp_fm_struct_release(fm_struct_W) + END DO END IF - CALL cp_fm_release(fm_W) - CALL cp_fm_struct_release(fm_struct_v) + CALL cp_fm_struct_release(fm_struct_B) + DEALLOCATE (n_ov, offsets) + CALL timestop(handle) END SUBROUTINE create_B @@ -364,20 +449,18 @@ CONTAINS !> \param fm_C ... !> \param fm_sqrt_A_minus_B ... !> \param fm_inv_sqrt_A_minus_B ... -!> \param homo ... -!> \param virtual ... !> \param unit_nr ... !> \param mp2_env ... !> \param diag_est ... ! ************************************************************************************************** SUBROUTINE create_hermitian_form_of_ABBA(fm_A, fm_B, fm_C, & fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - homo, virtual, unit_nr, mp2_env, diag_est) + unit_nr, mp2_env, diag_est) TYPE(cp_fm_type), INTENT(IN) :: fm_A, fm_B TYPE(cp_fm_type), INTENT(INOUT) :: fm_C, fm_sqrt_A_minus_B, & fm_inv_sqrt_A_minus_B - INTEGER, INTENT(IN) :: homo, virtual, unit_nr + INTEGER, INTENT(IN) :: unit_nr TYPE(mp2_type), INTENT(INOUT) :: mp2_env REAL(KIND=dp), INTENT(IN) :: diag_est @@ -446,7 +529,7 @@ CONTAINS ! We keep fm_inv_sqrt_A_minus_B for print of singleparticle transitions of ABBA ! We further create (A-B)^0.5 for the singleparticle transitions of ABBA ! Create (A-B)^0.5= (A-B)^-0.5 * (A-B) (EQ.Ia) - dim_mat = homo*virtual + CALL cp_fm_get_info(fm_A, nrow_global=dim_mat) CALL parallel_gemm("N", "N", dim_mat, dim_mat, dim_mat, 1.0_dp, fm_inv_sqrt_A_minus_B, fm_A_minus_B, 0.0_dp, & fm_sqrt_A_minus_B) @@ -494,7 +577,7 @@ CONTAINS unit_nr, diag_est, mp2_env, qs_env, mo_coeff) TYPE(cp_fm_type), INTENT(INOUT) :: fm_C - INTEGER, INTENT(IN) :: homo, virtual, homo_irred + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred TYPE(cp_fm_type), INTENT(INOUT) :: fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B INTEGER, INTENT(IN) :: unit_nr REAL(KIND=dp), INTENT(IN) :: diag_est @@ -504,7 +587,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'diagonalize_C' - INTEGER :: diag_info, handle + INTEGER :: diag_info, handle, n_ov_joint, nspins REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Exc_ens TYPE(cp_fm_type) :: fm_eigvec_X, fm_eigvec_Y, fm_eigvec_Z, & fm_mat_eigvec_transform_diff, & @@ -512,6 +595,9 @@ CONTAINS CALL timeset(routineN, handle) + nspins = SIZE(homo) + n_ov_joint = SUM(homo*virtual) + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A4,T7,A17,A22,ES6.0,A3)') 'BSE|', 'Diagonalizing C. ', & 'This will take around ', diag_est, ' s.' @@ -521,7 +607,7 @@ CONTAINS !Now: Diagonalize it CALL cp_fm_create(fm_eigvec_Z, fm_C%matrix_struct) - ALLOCATE (Exc_ens(homo*virtual)) + ALLOCATE (Exc_ens(n_ov_joint)) CALL choose_eigv_solver(fm_C, fm_eigvec_Z, Exc_ens, diag_info) @@ -553,7 +639,7 @@ CONTAINS ! First, Eq. I from (A10) from Furche: (X+Y)_n = (Ω_n)^-0.5 (A-B)^0.5 T_n CALL cp_fm_create(fm_mat_eigvec_transform_sum, fm_C%matrix_struct) CALL cp_fm_set_all(fm_mat_eigvec_transform_sum, 0.0_dp) - CALL parallel_gemm(transa="N", transb="N", m=homo*virtual, n=homo*virtual, k=homo*virtual, alpha=1.0_dp, & + CALL parallel_gemm(transa="N", transb="N", m=n_ov_joint, n=n_ov_joint, k=n_ov_joint, alpha=1.0_dp, & matrix_a=fm_sqrt_A_minus_B, matrix_b=fm_eigvec_Z, beta=0.0_dp, & matrix_c=fm_mat_eigvec_transform_sum) CALL cp_fm_release(fm_sqrt_A_minus_B) @@ -563,7 +649,7 @@ CONTAINS ! Second, Eq. II from (A10) from Furche: (X-Y)_n = (Ω_n)^0.5 (A-B)^-0.5 T_n CALL cp_fm_create(fm_mat_eigvec_transform_diff, fm_C%matrix_struct) CALL cp_fm_set_all(fm_mat_eigvec_transform_diff, 0.0_dp) - CALL parallel_gemm(transa="N", transb="N", m=homo*virtual, n=homo*virtual, k=homo*virtual, alpha=1.0_dp, & + CALL parallel_gemm(transa="N", transb="N", m=n_ov_joint, n=n_ov_joint, k=n_ov_joint, alpha=1.0_dp, & matrix_a=fm_inv_sqrt_A_minus_B, matrix_b=fm_eigvec_Z, beta=0.0_dp, & matrix_c=fm_mat_eigvec_transform_diff) CALL cp_fm_release(fm_inv_sqrt_A_minus_B) @@ -588,9 +674,15 @@ CONTAINS CALL cp_fm_release(fm_mat_eigvec_transform_diff) CALL cp_fm_release(fm_mat_eigvec_transform_sum) - CALL postprocess_bse(Exc_ens, fm_eigvec_X, mp2_env, qs_env, mo_coeff, & - homo, virtual, homo_irred, unit_nr, & - .FALSE., fm_eigvec_Y) + IF (nspins == 1) THEN + CALL postprocess_bse(Exc_ens, fm_eigvec_X, mp2_env, qs_env, mo_coeff, & + homo(1), virtual(1), homo_irred(1), unit_nr, & + .FALSE., fm_eigvec_Y) + ELSE + ! Open-shell ABBA: helper forms X+Y internally and prints amplitudes (X and Y). + CALL bse_open_shell_optical(Exc_ens, fm_eigvec_X, homo, virtual, homo_irred, & + .FALSE., qs_env, mo_coeff, mp2_env, unit_nr, fm_eigvec_Y) + END IF DEALLOCATE (Exc_ens) CALL cp_fm_release(fm_eigvec_X) @@ -616,7 +708,8 @@ CONTAINS unit_nr, diag_est, mp2_env, qs_env, mo_coeff) TYPE(cp_fm_type), INTENT(INOUT) :: fm_A - INTEGER, INTENT(IN) :: homo, virtual, homo_irred, unit_nr + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred + INTEGER, INTENT(IN) :: unit_nr REAL(KIND=dp), INTENT(IN) :: diag_est TYPE(mp2_type), INTENT(INOUT) :: mp2_env TYPE(qs_environment_type), POINTER :: qs_env @@ -624,23 +717,23 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'diagonalize_A' - INTEGER :: diag_info, handle + INTEGER :: diag_info, handle, n_ov_joint, nspins REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Exc_ens TYPE(cp_fm_type) :: fm_eigvec CALL timeset(routineN, handle) - !Continue with formatting of subroutine create_A + nspins = SIZE(homo) + n_ov_joint = SUM(homo*virtual) + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A4,T7,A17,A22,ES6.0,A3)') 'BSE|', 'Diagonalizing A. ', & 'This will take around ', diag_est, ' s.' END IF - !We have now the full matrix A_iajb, distributed over all ranks - !Now: Diagonalize it CALL cp_fm_create(fm_eigvec, fm_A%matrix_struct) - ALLOCATE (Exc_ens(homo*virtual)) + ALLOCATE (Exc_ens(n_ov_joint)) CALL choose_eigv_solver(fm_A, fm_eigvec, Exc_ens, diag_info) @@ -649,8 +742,13 @@ CONTAINS "Diagonalization of A failed in TDA-BSE") END IF - CALL postprocess_bse(Exc_ens, fm_eigvec, mp2_env, qs_env, mo_coeff, & - homo, virtual, homo_irred, unit_nr, .TRUE.) + IF (nspins == 1) THEN + CALL postprocess_bse(Exc_ens, fm_eigvec, mp2_env, qs_env, mo_coeff, & + homo(1), virtual(1), homo_irred(1), unit_nr, .TRUE.) + ELSE + CALL bse_open_shell_optical(Exc_ens, fm_eigvec, homo, virtual, homo_irred, & + .TRUE., qs_env, mo_coeff, mp2_env, unit_nr) + END IF CALL cp_fm_release(fm_eigvec) DEALLOCATE (Exc_ens) @@ -659,6 +757,154 @@ CONTAINS END SUBROUTINE diagonalize_A +! ************************************************************************************************** +!> \brief Open-shell (UKS) spin-summed post-processing for the joint spin-block space: joint +!> excitation energies, per-spin transition amplitudes, and oscillator strengths. Mirrors +!> postprocess_bse but spin-summed; exciton descriptors and NTOs are not yet implemented (CPWARN). +!> \param Exc_ens joint excitation energies +!> \param fm_eigvec_X joint X eigenvectors (excitations) +!> \param homo per-spin reduced/active occupied counts +!> \param virtual per-spin reduced/active virtual counts +!> \param homo_irred per-spin full occupied counts (absolute-MO labels; N_e = sum) +!> \param flag_tda .TRUE. -> TDA (coeff=X), .FALSE. -> ABBA (coeff=X+Y) +!> \param qs_env ... +!> \param mo_coeff per-spin MO coefficients +!> \param mp2_env ... +!> \param unit_nr ... +!> \param fm_eigvec_Y joint Y eigenvectors (deexcitations; ABBA only) +! ************************************************************************************************** + SUBROUTINE bse_open_shell_optical(Exc_ens, fm_eigvec_X, homo, virtual, homo_irred, & + flag_tda, qs_env, mo_coeff, mp2_env, unit_nr, fm_eigvec_Y) + + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Exc_ens + TYPE(cp_fm_type), INTENT(IN) :: fm_eigvec_X + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred + LOGICAL, INTENT(IN) :: flag_tda + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: mo_coeff + TYPE(mp2_type), INTENT(INOUT) :: mp2_env + INTEGER, INTENT(IN) :: unit_nr + TYPE(cp_fm_type), INTENT(IN), OPTIONAL :: fm_eigvec_Y + + CHARACTER(LEN=*), PARAMETER :: routineN = 'bse_open_shell_optical' + + CHARACTER(LEN=10) :: info_approximation, multiplet + INTEGER :: handle, idir, isp, jdir, n, n_ov_joint, & + nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_ov_sp, offsets_sp + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: oscill_str_joint, ref_pt + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: pol_res_joint, trans_mom_joint + TYPE(cp_fm_struct_type), POINTER :: fm_struct_dip_reord, fm_struct_sp, & + fm_struct_tmom + TYPE(cp_fm_type) :: fm_dip_reord_sp, fm_eigvec_sp, & + fm_trans_coeff + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_dip_ab_sp, fm_dip_ai_sp, fm_dip_ij_sp + TYPE(cp_fm_type), DIMENSION(3) :: fm_trans_mom_joint + + CALL timeset(routineN, handle) + + nspins = SIZE(homo) + ALLOCATE (n_ov_sp(nspins), offsets_sp(nspins)) + CALL get_bse_spin_block_layout(homo, virtual, n_ov_sp, offsets_sp, n_ov_joint) + + ! LEN=10 locals auto-pad short literals with spaces (avoids the L-15 short-literal trap); + ! print_excitation_energies prints A6 of these, print_optical_properties prints them as-is. + multiplet = "UKS" + IF (flag_tda) THEN + info_approximation = " -TDA- " + ELSE + info_approximation = "-ABBA-" + END IF + + IF (unit_nr > 0) THEN + WRITE (unit_nr, '(T2,A4,T7,A43)') 'BSE|', 'Joint open-shell BSE excitation energies:' + END IF + CALL print_excitation_energies(Exc_ens, n_ov_joint, 1, flag_tda, multiplet, & + info_approximation, mp2_env, unit_nr) + + ! Per-spin single-particle transition amplitudes (X via =>, Y via <=). + CALL print_transition_amplitudes(fm_eigvec_X, homo, virtual, homo_irred, & + info_approximation, mp2_env, unit_nr, fm_eigvec_Y) + + ! Transition coefficient for the spin-summed moment: X (TDA) or X+Y (ABBA). + CALL cp_fm_create(fm_trans_coeff, fm_eigvec_X%matrix_struct) + CALL cp_fm_to_fm(fm_eigvec_X, fm_trans_coeff) + IF (PRESENT(fm_eigvec_Y)) CALL cp_fm_scale_and_add(1.0_dp, fm_trans_coeff, 1.0_dp, fm_eigvec_Y) + + ! Spin-summed transition moments: D^n_dir = sum_σ sum_{ia,σ} D^{dir,σ}_{ai} C_{ia,σ,n} + ! with C = X (TDA) or X+Y (ABBA); explicit spin sum, factor 1.0. + ALLOCATE (fm_dip_ai_sp(3), fm_dip_ij_sp(3), fm_dip_ab_sp(3), ref_pt(3)) + ALLOCATE (oscill_str_joint(n_ov_joint), trans_mom_joint(3, 1, n_ov_joint)) + ALLOCATE (pol_res_joint(3, 3, n_ov_joint)) + trans_mom_joint(:, :, :) = 0.0_dp + NULLIFY (fm_struct_dip_reord, fm_struct_sp, fm_struct_tmom) + CALL cp_fm_struct_create(fm_struct_tmom, fm_trans_coeff%matrix_struct%para_env, & + fm_trans_coeff%matrix_struct%context, 1, n_ov_joint) + DO idir = 1, 3 + CALL cp_fm_create(fm_trans_mom_joint(idir), fm_struct_tmom) + CALL cp_fm_set_all(fm_trans_mom_joint(idir), 0.0_dp) + END DO + DO isp = 1, nspins + CALL get_multipoles_mo(fm_dip_ai_sp, fm_dip_ij_sp, fm_dip_ab_sp, & + qs_env, mo_coeff(isp:isp), ref_pt, 1, & + homo(isp), virtual(isp), fm_trans_coeff%matrix_struct%context, & + ispin=isp) + NULLIFY (fm_struct_sp, fm_struct_dip_reord) + CALL cp_fm_struct_create(fm_struct_sp, fm_trans_coeff%matrix_struct%para_env, & + fm_trans_coeff%matrix_struct%context, n_ov_sp(isp), n_ov_joint) + CALL cp_fm_create(fm_eigvec_sp, fm_struct_sp) + CALL cp_fm_set_all(fm_eigvec_sp, 0.0_dp) + CALL cp_fm_to_fm_submat(fm_trans_coeff, fm_eigvec_sp, n_ov_sp(isp), n_ov_joint, & + offsets_sp(isp) + 1, 1, 1, 1) + CALL cp_fm_struct_create(fm_struct_dip_reord, fm_trans_coeff%matrix_struct%para_env, & + fm_trans_coeff%matrix_struct%context, 1, n_ov_sp(isp)) + DO idir = 1, 3 + CALL cp_fm_create(fm_dip_reord_sp, fm_struct_dip_reord, name="bse_dip_reord") + CALL cp_fm_set_all(fm_dip_reord_sp, 0.0_dp) + CALL fm_general_add_bse(fm_dip_reord_sp, fm_dip_ai_sp(idir), 1.0_dp, & + 1, 1, 1, virtual(isp), unit_nr, [2, 4, 3, 1], mp2_env) + CALL parallel_gemm('N', 'N', 1, n_ov_joint, n_ov_sp(isp), 1.0_dp, & + fm_dip_reord_sp, fm_eigvec_sp, 1.0_dp, fm_trans_mom_joint(idir)) + CALL cp_fm_release(fm_dip_reord_sp) + CALL cp_fm_release(fm_dip_ai_sp(idir)) + CALL cp_fm_release(fm_dip_ij_sp(idir)) + CALL cp_fm_release(fm_dip_ab_sp(idir)) + END DO + CALL cp_fm_release(fm_eigvec_sp) + CALL cp_fm_struct_release(fm_struct_sp) + NULLIFY (fm_struct_sp) + CALL cp_fm_struct_release(fm_struct_dip_reord) + NULLIFY (fm_struct_dip_reord) + END DO + DO idir = 1, 3 + CALL cp_fm_get_submatrix(fm_trans_mom_joint(idir), trans_mom_joint(idir, :, :)) + CALL cp_fm_release(fm_trans_mom_joint(idir)) + END DO + CALL cp_fm_struct_release(fm_struct_tmom) + DO n = 1, n_ov_joint + DO idir = 1, 3 + DO jdir = 1, 3 + pol_res_joint(idir, jdir, n) = 2.0_dp*Exc_ens(n)*trans_mom_joint(idir, 1, n) & + *trans_mom_joint(jdir, 1, n) + END DO + END DO + oscill_str_joint(n) = 2.0_dp/3.0_dp*Exc_ens(n)*SUM(ABS(trans_mom_joint(:, 1, n))**2) + END DO + CALL print_optical_properties(Exc_ens, oscill_str_joint, trans_mom_joint, pol_res_joint, & + n_ov_joint, 1, SUM(homo_irred), flag_tda, info_approximation, & + mp2_env, unit_nr, open_shell=.TRUE.) + ! Open-shell post-processing is partial: energies, amplitudes, spin-summed oscillator strengths. + CALL cp_warn(__LOCATION__, & + "Open-shell (UKS) BSE: exciton descriptors and NTO analysis are not yet "// & + "implemented and have been skipped.") + CALL cp_fm_release(fm_trans_coeff) + DEALLOCATE (fm_dip_ai_sp, fm_dip_ij_sp, fm_dip_ab_sp, ref_pt) + DEALLOCATE (n_ov_sp, offsets_sp, oscill_str_joint, trans_mom_joint, pol_res_joint) + + CALL timestop(handle) + + END SUBROUTINE bse_open_shell_optical + ! ************************************************************************************************** !> \brief Prints the success message (incl. energies) for full diag of BSE (TDA/full ABBA via flag) !> \param Exc_ens ... @@ -783,7 +1029,7 @@ CONTAINS info_approximation, mp2_env, unit_nr) ! Print single particle transition amplitudes, i.e. components of eigenvectors X and Y - CALL print_transition_amplitudes(fm_eigvec_X, homo, virtual, homo_irred, & + CALL print_transition_amplitudes(fm_eigvec_X, [homo], [virtual], [homo_irred], & info_approximation, mp2_env, unit_nr, fm_eigvec_Y) ! Prints optical properties, if state is a singlet diff --git a/src/bse_main.F b/src/bse_main.F index 0aea47722c..c47efa401f 100644 --- a/src/bse_main.F +++ b/src/bse_main.F @@ -23,12 +23,16 @@ MODULE bse_main USE bse_print, ONLY: print_BSE_start_flag USE bse_util, ONLY: adapt_BSE_input_params,& deallocate_matrices_bse,& + determine_bse_combined_window,& estimate_BSE_resources,& + get_bse_spin_block_layout,& mult_B_with_W,& truncate_BSE_matrices USE cp_control_types, ONLY: dft_control_type,& tddfpt2_control_type - USE cp_fm_types, ONLY: cp_fm_release,& + USE cp_fm_types, ONLY: cp_fm_create,& + cp_fm_release,& + cp_fm_to_fm,& cp_fm_type USE cp_log_handling, ONLY: cp_get_default_logger,& cp_logger_type @@ -84,13 +88,14 @@ CONTAINS homo, virtual, dimen_RI, dimen_RI_red, bse_lev_virt, & gd_array, color_sub, mp2_env, qs_env, mo_coeff, unit_nr) - TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_ij_bse, & + TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_ij_bse, & fm_mat_S_ab_bse TYPE(cp_fm_type), INTENT(INOUT) :: fm_mat_Q_static_bse_gemm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & INTENT(IN) :: Eigenval, Eigenval_scf INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual - INTEGER, INTENT(IN) :: dimen_RI, dimen_RI_red, bse_lev_virt + INTEGER, INTENT(IN) :: dimen_RI, dimen_RI_red + INTEGER, DIMENSION(:), INTENT(IN) :: bse_lev_virt TYPE(group_dist_d1_type), INTENT(IN) :: gd_array INTEGER, INTENT(IN) :: color_sub TYPE(mp2_type) :: mp2_env @@ -100,16 +105,24 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'start_bse_calculation' - INTEGER :: handle, homo_red, virtual_red + INTEGER :: first_active_mo, handle, ispin, & + last_active_mo, n_ov_joint, nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: homo_red_arr, n_ov_arr, offsets_arr, & + virt_red_arr LOGICAL :: my_do_abba, my_do_fulldiag, & my_do_iterat_diag, my_do_tda REAL(KIND=dp) :: diag_runtime_est - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Eigenval_reduced + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Eigenval_reduced, Eigenval_reduced_1, & + Eigenval_reduced_2, & + Eigenval_reduced_joint REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: B_abQ_bse_local, B_bar_iaQ_bse_local, & B_bar_ijQ_bse_local, B_iaQ_bse_local - TYPE(cp_fm_type) :: fm_A_BSE, fm_B_BSE, fm_C_BSE, fm_inv_sqrt_A_minus_B, fm_mat_S_ab_trunc, & - fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, & - fm_sqrt_A_minus_B + TYPE(cp_fm_type) :: fm_A_BSE, fm_B_BSE, fm_C_BSE, & + fm_inv_sqrt_A_minus_B, fm_Q_copy, & + fm_sqrt_A_minus_B + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_S_ab_trunc_arr, & + fm_mat_S_bar_ia_bse_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ia_trunc_arr, & + fm_mat_S_ij_trunc_arr TYPE(cp_logger_type), POINTER :: logger TYPE(dft_control_type), POINTER :: dft_control TYPE(mp_para_env_type), POINTER :: para_env @@ -117,7 +130,8 @@ CONTAINS CALL timeset(routineN, handle) - para_env => fm_mat_S_ia_bse%matrix_struct%para_env + nspins = SIZE(homo) + para_env => fm_mat_S_ia_bse(1)%matrix_struct%para_env my_do_fulldiag = .FALSE. my_do_iterat_diag = .FALSE. @@ -151,117 +165,202 @@ CONTAINS mp2_env%bse%bse_debug_print = .TRUE. END IF - CALL fm_mat_S_ia_bse%matrix_struct%para_env%sync() - ! We apply the BSE cutoffs using the DFT Eigenenergies - ! Reduce matrices in case of energy cutoff for occupied and unoccupied in A/B-BSE-matrices - CALL truncate_BSE_matrices(fm_mat_S_ia_bse, fm_mat_S_ij_bse, fm_mat_S_ab_bse, & - fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & - Eigenval_scf(:, 1, 1), Eigenval(:, 1, 1), Eigenval_reduced, & - homo(1), virtual(1), dimen_RI, unit_nr, & - bse_lev_virt, & - homo_red, virtual_red, & - mp2_env) - ! \bar{B}^P_rs = \sum_R W_PR B^R_rs where B^R_rs = \sum_T [1/sqrt(v)]_RT (T|rs) - ! r,s: MO-index, P,R,T: RI-index - ! B: fm_mat_S_..., W: fm_mat_Q_... - CALL mult_B_with_W(fm_mat_S_ij_trunc, fm_mat_S_ia_trunc, fm_mat_S_bar_ia_bse, & - fm_mat_S_bar_ij_bse, fm_mat_Q_static_bse_gemm, & - dimen_RI_red, homo_red, virtual_red) + CALL fm_mat_S_ia_bse(1)%matrix_struct%para_env%sync() - IF (my_do_iterat_diag) THEN - CALL fill_local_3c_arrays(fm_mat_S_ab_trunc, fm_mat_S_ia_trunc, & - fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, & - B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & - B_iaQ_bse_local, dimen_RI_red, homo_red, virtual_red, & - gd_array, color_sub, para_env) - END IF + ALLOCATE (homo_red_arr(nspins), virt_red_arr(nspins)) + ALLOCATE (fm_mat_S_ia_trunc_arr(nspins), fm_mat_S_ij_trunc_arr(nspins), fm_mat_S_ab_trunc_arr(nspins)) + ALLOCATE (fm_mat_S_bar_ia_bse_arr(nspins), fm_mat_S_bar_ij_bse_arr(nspins)) - CALL adapt_BSE_input_params(homo_red, virtual_red, unit_nr, mp2_env, qs_env) + IF (nspins > 1) THEN + CALL cp_warn(__LOCATION__, & + "Open-shell (UKS/LSD) BSE is a recent addition and has not been "// & + "extensively validated. Verify results carefully before using them "// & + "for production calculations.") + ! === Open-shell path: combined-window cutoff, per-spin truncation, joint A (+B for ABBA) === + ! Determine union of per-spin active MO windows + CALL determine_bse_combined_window(Eigenval_scf(:, 1, :), homo, virtual, & + mp2_env%bse%bse_cutoff_occ, & + mp2_env%bse%bse_cutoff_empty, & + first_active_mo, last_active_mo) + DO ispin = 1, nspins + CALL truncate_BSE_matrices(fm_mat_S_ia_bse(ispin), fm_mat_S_ij_bse(ispin), & + fm_mat_S_ab_bse(ispin), & + fm_mat_S_ia_trunc_arr(ispin), fm_mat_S_ij_trunc_arr(ispin), & + fm_mat_S_ab_trunc_arr(ispin), & + Eigenval_scf(:, 1, ispin), Eigenval(:, 1, ispin), & + Eigenval_reduced, homo(ispin), virtual(ispin), dimen_RI, & + unit_nr, bse_lev_virt(ispin), homo_red_arr(ispin), & + virt_red_arr(ispin), mp2_env, & + homo_incl_in=first_active_mo, & + virt_incl_in=last_active_mo - homo(ispin)) + IF (ispin == 1) THEN + ALLOCATE (Eigenval_reduced_1(SIZE(Eigenval_reduced))) + Eigenval_reduced_1(:) = Eigenval_reduced(:) + ELSE + ALLOCATE (Eigenval_reduced_2(SIZE(Eigenval_reduced))) + Eigenval_reduced_2(:) = Eigenval_reduced(:) + END IF + DEALLOCATE (Eigenval_reduced) + END DO + ! Flat eigenvalue layout: [sigma=1 levels, sigma=2 levels] + ALLOCATE (Eigenval_reduced_joint(SIZE(Eigenval_reduced_1) + SIZE(Eigenval_reduced_2))) + Eigenval_reduced_joint(1:SIZE(Eigenval_reduced_1)) = Eigenval_reduced_1 + Eigenval_reduced_joint(SIZE(Eigenval_reduced_1) + 1:) = Eigenval_reduced_2 + DEALLOCATE (Eigenval_reduced_1, Eigenval_reduced_2) - IF (my_do_fulldiag) THEN - ! Quick estimate of memory consumption and runtime of diagonalizations - CALL estimate_BSE_resources(homo_red, virtual_red, unit_nr, my_do_abba, & - para_env, diag_runtime_est) - ! Matrix A constructed from GW energies and 3c-B-matrices (cf. subroutine mult_B_with_W) - ! A_ia,jb = (ε_a-ε_i) δ_ij δ_ab + α * v_ia,jb - W_ij,ab - ! ε_a, ε_i are GW singleparticle energies from Eigenval_reduced - ! α is a spin-dependent factor - ! v_ia,jb = \sum_P B^P_ia B^P_jb (unscreened Coulomb interaction) - ! W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab (screened Coulomb interaction) + ALLOCATE (n_ov_arr(nspins), offsets_arr(nspins)) + CALL get_bse_spin_block_layout(homo_red_arr, virt_red_arr, n_ov_arr, offsets_arr, n_ov_joint) - ! For unscreened W matrix, we need fm_mat_S_ij_trunc - IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & - mp2_env%bse%screening_method == bse_screening_alpha) THEN - CALL create_A(fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & - fm_A_BSE, Eigenval_reduced, unit_nr, & - homo_red, virtual_red, dimen_RI, mp2_env, & - para_env, qs_env) - ELSE - CALL create_A(fm_mat_S_ia_trunc, fm_mat_S_bar_ij_bse, fm_mat_S_ab_trunc, & - fm_A_BSE, Eigenval_reduced, unit_nr, & - homo_red, virtual_red, dimen_RI, mp2_env, & - para_env, qs_env) - END IF - IF (my_do_abba) THEN - ! Matrix B constructed from 3c-B-matrices (cf. subroutine mult_B_with_W) - ! B_ia,jb = α * v_ia,jb - W_ib,aj - ! α is a spin-dependent factor - ! v_ia,jb = \sum_P B^P_ia B^P_jb (unscreened Coulomb interaction) - ! W_ib,aj = \sum_P \bar{B}^P_ib B^P_aj (screened Coulomb interaction) + CALL adapt_BSE_input_params(n_ov_joint, 1, unit_nr, mp2_env, qs_env) - ! For unscreened W matrix, we need fm_mat_S_ia_trunc + ! W: mult_B_with_W modifies Q in-place (Cholesky); copy the original Q for each spin call + DO ispin = 1, nspins + CALL cp_fm_create(fm_Q_copy, fm_mat_Q_static_bse_gemm%matrix_struct) + CALL cp_fm_to_fm(fm_mat_Q_static_bse_gemm, fm_Q_copy) + CALL mult_B_with_W(fm_mat_S_ij_trunc_arr(ispin), fm_mat_S_ia_trunc_arr(ispin), & + fm_mat_S_bar_ia_bse_arr(ispin), fm_mat_S_bar_ij_bse_arr(ispin), & + fm_Q_copy, dimen_RI_red, homo_red_arr(ispin), virt_red_arr(ispin)) + CALL cp_fm_release(fm_Q_copy) + END DO + CALL cp_fm_release(fm_mat_Q_static_bse_gemm) + + IF (my_do_fulldiag) THEN + CALL estimate_BSE_resources(n_ov_joint, unit_nr, my_do_abba, para_env, diag_runtime_est) IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & mp2_env%bse%screening_method == bse_screening_alpha) THEN - CALL create_B(fm_mat_S_ia_trunc, fm_mat_S_ia_trunc, fm_B_BSE, & - homo_red, virtual_red, dimen_RI, unit_nr, mp2_env) + CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr, & + fm_A_BSE, Eigenval_reduced_joint, unit_nr, & + homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) ELSE - CALL create_B(fm_mat_S_ia_trunc, fm_mat_S_bar_ia_bse, fm_B_BSE, & - homo_red, virtual_red, dimen_RI, unit_nr, mp2_env) + CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ab_trunc_arr, & + fm_A_BSE, Eigenval_reduced_joint, unit_nr, & + homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) + END IF + IF (my_do_abba) THEN + IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & + mp2_env%bse%screening_method == bse_screening_alpha) THEN + CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_ia_trunc_arr, fm_B_BSE, & + homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) + ELSE + CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ia_bse_arr, fm_B_BSE, & + homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) + END IF + CALL create_hermitian_form_of_ABBA(fm_A_BSE, fm_B_BSE, fm_C_BSE, & + fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & + unit_nr, mp2_env, diag_runtime_est) + CALL cp_fm_release(fm_B_BSE) + END IF + NULLIFY (dft_control, tddfpt_control) + CALL get_qs_env(qs_env, dft_control=dft_control) + tddfpt_control => dft_control%tddfpt2_control + ! 4th arg (homo_irred) = full per-spin occupied counts: per-spin absolute-MO labels for + ! the amplitude table, and N_e = SUM(homo_irred) for the TRK print. + IF (my_do_tda .AND. (.NOT. tddfpt_control%do_bse)) THEN + CALL diagonalize_A(fm_A_BSE, homo_red_arr, virt_red_arr, homo, & + unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + END IF + CALL cp_fm_release(fm_A_BSE) + IF (my_do_abba) THEN + CALL diagonalize_C(fm_C_BSE, homo_red_arr, virt_red_arr, homo, & + fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & + unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + CALL cp_fm_release(fm_C_BSE) END IF - ! Construct Matrix C=(A-B)^0.5 (A+B) (A-B)^0.5 to solve full BSE matrix as a hermitian problem - ! (cf. Eq. (A7) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001)). - ! We keep fm_sqrt_A_minus_B and fm_inv_sqrt_A_minus_B for print of singleparticle transitions - ! of ABBA as described in Eq. (A10) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001). - CALL create_hermitian_form_of_ABBA(fm_A_BSE, fm_B_BSE, fm_C_BSE, & - fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - homo_red, virtual_red, unit_nr, mp2_env, diag_runtime_est) END IF - CALL cp_fm_release(fm_B_BSE) - NULLIFY (dft_control, tddfpt_control) - CALL get_qs_env(qs_env, dft_control=dft_control) - tddfpt_control => dft_control%tddfpt2_control - IF ((my_do_tda) .AND. (.NOT. tddfpt_control%do_bse)) THEN - ! Solving the hermitian eigenvalue equation A X^n = Ω^n X^n - CALL diagonalize_A(fm_A_BSE, homo_red, virtual_red, homo(1), & - unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + DO ispin = 1, nspins + CALL cp_fm_release(fm_mat_S_bar_ia_bse_arr(ispin)) + CALL cp_fm_release(fm_mat_S_bar_ij_bse_arr(ispin)) + CALL cp_fm_release(fm_mat_S_ia_trunc_arr(ispin)) + CALL cp_fm_release(fm_mat_S_ij_trunc_arr(ispin)) + CALL cp_fm_release(fm_mat_S_ab_trunc_arr(ispin)) + END DO + IF (mp2_env%bse%do_nto_analysis) DEALLOCATE (mp2_env%bse%bse_nto_state_list_final) + DEALLOCATE (Eigenval_reduced_joint, n_ov_arr, offsets_arr) + + ELSE + ! === Closed-shell n_spin=1 path (bit-identical) === + CALL truncate_BSE_matrices(fm_mat_S_ia_bse(1), fm_mat_S_ij_bse(1), fm_mat_S_ab_bse(1), & + fm_mat_S_ia_trunc_arr(1), fm_mat_S_ij_trunc_arr(1), & + fm_mat_S_ab_trunc_arr(1), & + Eigenval_scf(:, 1, 1), Eigenval(:, 1, 1), Eigenval_reduced, & + homo(1), virtual(1), dimen_RI, unit_nr, & + bse_lev_virt(1), homo_red_arr(1), virt_red_arr(1), mp2_env) + CALL mult_B_with_W(fm_mat_S_ij_trunc_arr(1), fm_mat_S_ia_trunc_arr(1), & + fm_mat_S_bar_ia_bse_arr(1), fm_mat_S_bar_ij_bse_arr(1), & + fm_mat_Q_static_bse_gemm, dimen_RI_red, homo_red_arr(1), virt_red_arr(1)) + + IF (my_do_iterat_diag) THEN + CALL fill_local_3c_arrays(fm_mat_S_ab_trunc_arr(1), fm_mat_S_ia_trunc_arr(1), & + fm_mat_S_bar_ia_bse_arr(1), fm_mat_S_bar_ij_bse_arr(1), & + B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & + B_iaQ_bse_local, dimen_RI_red, homo_red_arr(1), & + virt_red_arr(1), gd_array, color_sub, para_env) END IF - ! Release to avoid faulty use of changed A matrix - CALL cp_fm_release(fm_A_BSE) - IF (my_do_abba) THEN - ! Solving eigenvalue equation C Z^n = (Ω^n)^2 Z^n . - ! Here, the eigenvectors Z^n relate to X^n via - ! Eq. (A10) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001). - CALL diagonalize_C(fm_C_BSE, homo_red, virtual_red, homo(1), & - fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + + CALL adapt_BSE_input_params(homo_red_arr(1), virt_red_arr(1), unit_nr, mp2_env, qs_env) + + IF (my_do_fulldiag) THEN + n_ov_joint = homo_red_arr(1)*virt_red_arr(1) + CALL estimate_BSE_resources(n_ov_joint, unit_nr, my_do_abba, para_env, diag_runtime_est) + IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & + mp2_env%bse%screening_method == bse_screening_alpha) THEN + CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr, & + fm_A_BSE, Eigenval_reduced, unit_nr, & + homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) + ELSE + CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ab_trunc_arr, & + fm_A_BSE, Eigenval_reduced, unit_nr, & + homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) + END IF + IF (my_do_abba) THEN + IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & + mp2_env%bse%screening_method == bse_screening_alpha) THEN + CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_ia_trunc_arr, fm_B_BSE, & + homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) + ELSE + CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ia_bse_arr, fm_B_BSE, & + homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) + END IF + CALL create_hermitian_form_of_ABBA(fm_A_BSE, fm_B_BSE, fm_C_BSE, & + fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & + unit_nr, mp2_env, diag_runtime_est) + END IF + CALL cp_fm_release(fm_B_BSE) + + NULLIFY (dft_control, tddfpt_control) + CALL get_qs_env(qs_env, dft_control=dft_control) + tddfpt_control => dft_control%tddfpt2_control + IF (my_do_tda .AND. (.NOT. tddfpt_control%do_bse)) THEN + CALL diagonalize_A(fm_A_BSE, homo_red_arr, virt_red_arr, homo, & + unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + END IF + CALL cp_fm_release(fm_A_BSE) + IF (my_do_abba) THEN + CALL diagonalize_C(fm_C_BSE, homo_red_arr, virt_red_arr, homo, & + fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & + unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + END IF + CALL cp_fm_release(fm_C_BSE) END IF - ! Release to avoid faulty use of changed C matrix - CALL cp_fm_release(fm_C_BSE) + + CALL deallocate_matrices_bse(fm_mat_S_bar_ia_bse_arr(1), fm_mat_S_bar_ij_bse_arr(1), & + fm_mat_S_ia_trunc_arr(1), fm_mat_S_ij_trunc_arr(1), & + fm_mat_S_ab_trunc_arr(1), fm_mat_Q_static_bse_gemm, mp2_env) + DEALLOCATE (Eigenval_reduced) + IF (my_do_iterat_diag) THEN + CALL do_subspace_iterations(B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & + B_iaQ_bse_local, homo(1), virtual(1), & + mp2_env%bse%bse_spin_config, unit_nr, & + Eigenval(:, 1, 1), para_env, mp2_env) + DEALLOCATE (B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, B_iaQ_bse_local) + END IF + END IF - CALL deallocate_matrices_bse(fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, & - fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & - fm_mat_Q_static_bse_gemm, mp2_env) - DEALLOCATE (Eigenval_reduced) - IF (my_do_iterat_diag) THEN - ! Contains untested Block-Davidson algorithm - CALL do_subspace_iterations(B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & - B_iaQ_bse_local, homo(1), virtual(1), mp2_env%bse%bse_spin_config, unit_nr, & - Eigenval(:, 1, 1), para_env, mp2_env) - ! Deallocate local 3c-B-matrices - DEALLOCATE (B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, B_iaQ_bse_local) - END IF + DEALLOCATE (homo_red_arr, virt_red_arr) + DEALLOCATE (fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr) + DEALLOCATE (fm_mat_S_bar_ia_bse_arr, fm_mat_S_bar_ij_bse_arr) IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A4,T7,A53)') 'BSE|', 'The BSE was successfully calculated. Have a nice day!' diff --git a/src/bse_print.F b/src/bse_print.F index 4ee98507c5..877c6eab1c 100644 --- a/src/bse_print.F +++ b/src/bse_print.F @@ -17,7 +17,8 @@ MODULE bse_print cite_reference USE bse_properties, ONLY: compute_and_print_absorption_spectrum,& exciton_descr_type - USE bse_util, ONLY: filter_eigvec_contrib + USE bse_util, ONLY: filter_eigvec_contrib,& + get_bse_spin_block_layout USE cp_fm_types, ONLY: cp_fm_get_info,& cp_fm_type USE input_constants, ONLY: bse_screening_alpha,& @@ -239,8 +240,8 @@ CONTAINS WRITE (unit_nr, '(T2,A4,T7,A57)') 'BSE|', 'Excitation energies from solving the BSE without the TDA:' END IF WRITE (unit_nr, '(T2,A4)') 'BSE|' - WRITE (unit_nr, '(T2,A4,T11,A12,T26,A11,T44,A8,T55,A27)') 'BSE|', & - 'Excitation n', "Spin Config", 'TDA/ABBA', 'Excitation energy Ω^n (eV)' + WRITE (unit_nr, '(T2,A4,T11,A12,T30,A7,T44,A8,T55,A27)') 'BSE|', & + 'Excitation n', multiplet, 'TDA/ABBA', 'Excitation energy Ω^n (eV)' END IF !prints actual energies values IF (unit_nr > 0) THEN @@ -269,7 +270,7 @@ CONTAINS info_approximation, mp2_env, unit_nr, fm_eigvec_Y) TYPE(cp_fm_type), INTENT(IN) :: fm_eigvec_X - INTEGER, INTENT(IN) :: homo, virtual, homo_irred + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred CHARACTER(LEN=10), INTENT(IN) :: info_approximation TYPE(mp2_type), INTENT(INOUT) :: mp2_env INTEGER, INTENT(IN) :: unit_nr @@ -277,10 +278,15 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'print_transition_amplitudes' - INTEGER :: handle, i_exc + INTEGER :: handle, i_exc, isp, n_ov_joint, nspins + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_ov, offsets CALL timeset(routineN, handle) + nspins = SIZE(homo) + ALLOCATE (n_ov(nspins), offsets(nspins)) + CALL get_bse_spin_block_layout(homo, virtual, n_ov, offsets, n_ov_joint) + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A4)') 'BSE|' WRITE (unit_nr, '(T2,A4,T7,A61)') & @@ -300,27 +306,41 @@ CONTAINS 'BSE|', "i.e. |X_ia^n| > ", mp2_env%bse%eps_x, " or |Y_ia^n| > ", & mp2_env%bse%eps_x, ", respectively :" - WRITE (unit_nr, '(T2,A4,T15,A27,I5,A13,I5,A3)') 'BSE|', '-- Quick reminder: HOMO i =', & - homo_irred, ' and LUMO a =', homo_irred + 1, " --" - WRITE (unit_nr, '(T2,A4)') 'BSE|' - WRITE (unit_nr, '(T2,A4,T7,A12,T30,A1,T32,A5,T42,A1,T49,A8,T64,A17)') & - "BSE|", "Excitation n", "i", "=>/<=", "a", 'TDA/ABBA', "|X_ia^n|/|Y_ia^n|" + IF (nspins == 1) THEN + WRITE (unit_nr, '(T2,A4,T15,A27,I5,A13,I5,A3)') 'BSE|', '-- Quick reminder: HOMO i =', & + homo_irred(1), ' and LUMO a =', homo_irred(1) + 1, " --" + WRITE (unit_nr, '(T2,A4)') 'BSE|' + WRITE (unit_nr, '(T2,A4,T7,A12,T30,A1,T32,A5,T42,A1,T49,A8,T64,A17)') & + "BSE|", "Excitation n", "i", "=>/<=", "a", 'TDA/ABBA', "|X_ia^n|/|Y_ia^n|" + ELSE + ! bare A (no width) for sigma-bearing literals: explicit widths count bytes, and the + ! 2-byte UTF-8 sigma would otherwise truncate. + DO isp = 1, nspins + WRITE (unit_nr, '(T2,A4,T15,A,I2,A,I5,A,I5,A)') 'BSE|', & + '-- Quick reminder: σ =', isp, ', HOMO i =', homo_irred(isp), & + ' and LUMO a =', homo_irred(isp) + 1, " --" + END DO + WRITE (unit_nr, '(T2,A4)') 'BSE|' + WRITE (unit_nr, '(T2,A4,T7,A12,T22,A,T30,A1,T32,A5,T42,A1,T49,A8,T64,A)') & + "BSE|", "Excitation n", "σ", "i", "=>/<=", "a", 'TDA/ABBA', "|X_iaσ^n|/|Y_iaσ^n|" + END IF END IF - DO i_exc = 1, MIN(homo*virtual, mp2_env%bse%num_print_exc) + DO i_exc = 1, MIN(n_ov_joint, mp2_env%bse%num_print_exc) IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A4)') 'BSE|' END IF !Iterate through eigenvector and print values above threshold CALL print_transition_amplitudes_core(fm_eigvec_X, "=>", info_approximation, & i_exc, virtual, homo, homo_irred, & - unit_nr, mp2_env) + unit_nr, mp2_env, offsets) IF (PRESENT(fm_eigvec_Y)) THEN CALL print_transition_amplitudes_core(fm_eigvec_Y, "<=", info_approximation, & i_exc, virtual, homo, homo_irred, & - unit_nr, mp2_env) + unit_nr, mp2_env, offsets) END IF END DO + DEALLOCATE (n_ov, offsets) CALL timestop(handle) END SUBROUTINE print_transition_amplitudes @@ -338,10 +358,11 @@ CONTAINS !> \param info_approximation ... !> \param mp2_env ... !> \param unit_nr ... +!> \param open_shell if .TRUE., print spin-summed (UKS) dipole formula instead of the sqrt(2) one ! ************************************************************************************************** SUBROUTINE print_optical_properties(Exc_ens, oscill_str, trans_mom_bse, polarizability_residues, & homo, virtual, homo_irred, flag_TDA, & - info_approximation, mp2_env, unit_nr) + info_approximation, mp2_env, unit_nr, open_shell) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Exc_ens, oscill_str REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: trans_mom_bse, polarizability_residues @@ -350,13 +371,18 @@ CONTAINS CHARACTER(LEN=10), INTENT(IN) :: info_approximation TYPE(mp2_type), INTENT(INOUT) :: mp2_env INTEGER, INTENT(IN) :: unit_nr + LOGICAL, INTENT(IN), OPTIONAL :: open_shell CHARACTER(LEN=*), PARAMETER :: routineN = 'print_optical_properties' INTEGER :: handle, i_exc + LOGICAL :: my_open_shell CALL timeset(routineN, handle) + my_open_shell = .FALSE. + IF (PRESENT(open_shell)) my_open_shell = open_shell + ! Discriminate between singlet and triplet, since triplet state can't couple to light ! and therefore calculations of dipoles etc are not necessary IF (mp2_env%bse%bse_spin_config == 0) THEN @@ -367,12 +393,22 @@ CONTAINS WRITE (unit_nr, '(T2,A4,T7,A67)') & 'BSE|', "and oscillator strength f^n of excitation level n are obtained from" WRITE (unit_nr, '(T2,A4)') 'BSE|' - IF (flag_TDA) THEN - WRITE (unit_nr, '(T2,A4,T10,A)') & - 'BSE|', "d_r^n = sqrt(2) sum_ia < ψ_i | r | ψ_a > X_ia^n" + IF (my_open_shell) THEN + IF (flag_TDA) THEN + WRITE (unit_nr, '(T2,A4,T10,A)') & + 'BSE|', "d_r^n = sum_σ sum_ia < ψ_iσ | r | ψ_aσ > X_iaσ^n" + ELSE + WRITE (unit_nr, '(T2,A4,T10,A)') & + 'BSE|', "d_r^n = sum_σ sum_ia < ψ_iσ | r | ψ_aσ > ( X_iaσ^n + Y_iaσ^n )" + END IF ELSE - WRITE (unit_nr, '(T2,A4,T10,A)') & - 'BSE|', "d_r^n = sum_ia sqrt(2) < ψ_i | r | ψ_a > ( X_ia^n + Y_ia^n )" + IF (flag_TDA) THEN + WRITE (unit_nr, '(T2,A4,T10,A)') & + 'BSE|', "d_r^n = sqrt(2) sum_ia < ψ_i | r | ψ_a > X_ia^n" + ELSE + WRITE (unit_nr, '(T2,A4,T10,A)') & + 'BSE|', "d_r^n = sum_ia sqrt(2) < ψ_i | r | ψ_a > ( X_ia^n + Y_ia^n )" + END IF END IF WRITE (unit_nr, '(T2,A4)') 'BSE|' WRITE (unit_nr, '(T2,A4,T14,A)') & @@ -415,8 +451,10 @@ CONTAINS WRITE (unit_nr, '(T2,A4,T35,A15)') 'BSE|', & 'N_e = Σ_n f^n' WRITE (unit_nr, '(T2,A4)') 'BSE|' + ! Open shell: caller passes homo_irred = n_alpha + n_beta (total electrons). + ! Closed shell: homo_irred = n_occ, i.e. 2 electrons per occupied orbital. WRITE (unit_nr, '(T2,A4,T7,A24,T65,I16)') 'BSE|', & - 'Number of electrons N_e:', homo_irred*2 + 'Number of electrons N_e:', MERGE(homo_irred, homo_irred*2, my_open_shell) WRITE (unit_nr, '(T2,A4,T7,A40,T66,F16.3)') 'BSE|', & 'Sum over oscillator strengths Σ_n f^n :', SUM(oscill_str) WRITE (unit_nr, '(T2,A4)') 'BSE|' @@ -458,36 +496,58 @@ CONTAINS !> \param homo_irred ... !> \param unit_nr ... !> \param mp2_env ... +!> \param offsets ... ! ************************************************************************************************** SUBROUTINE print_transition_amplitudes_core(fm_eigvec, direction_excitation, info_approximation, & i_exc, virtual, homo, homo_irred, & - unit_nr, mp2_env) + unit_nr, mp2_env, offsets) TYPE(cp_fm_type), INTENT(IN) :: fm_eigvec CHARACTER(LEN=2), INTENT(IN) :: direction_excitation CHARACTER(LEN=10), INTENT(IN) :: info_approximation - INTEGER :: i_exc, virtual, homo, homo_irred + INTEGER, INTENT(IN) :: i_exc + INTEGER, DIMENSION(:), INTENT(IN) :: virtual, homo, homo_irred INTEGER, INTENT(IN) :: unit_nr TYPE(mp2_type), INTENT(INOUT) :: mp2_env + INTEGER, DIMENSION(:), INTENT(IN) :: offsets CHARACTER(LEN=*), PARAMETER :: routineN = 'print_transition_amplitudes_core' + CHARACTER(LEN=2), DIMENSION(2), PARAMETER :: spin_label = ["α", "β"] - INTEGER :: handle, k, num_entries - INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_homo, idx_virt + INTEGER :: handle, isp, k, num_entries + INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_homo, idx_spin, idx_virt REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eigvec_entries +! 2-byte UTF-8 glyphs (LEN=1 would truncate both alpha/beta to the shared 0xCE byte) + CALL timeset(routineN, handle) - CALL filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, & - i_exc, virtual, num_entries, mp2_env) ! direction_excitation can be either => (means excitation; from fm_eigvec_X) ! or <= (means deexcitation; from fm_eigvec_Y) - IF (unit_nr > 0) THEN - DO k = 1, num_entries - WRITE (unit_nr, '(T2,A4,T14,I5,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') & - "BSE|", i_exc, homo_irred - homo + idx_homo(k), direction_excitation, & - homo_irred + idx_virt(k), info_approximation, ABS(eigvec_entries(k)) - END DO + IF (SIZE(homo) == 1) THEN + CALL filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, & + i_exc, virtual(1), num_entries, mp2_env) + IF (unit_nr > 0) THEN + DO k = 1, num_entries + WRITE (unit_nr, '(T2,A4,T14,I5,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') & + "BSE|", i_exc, homo_irred(1) - homo(1) + idx_homo(k), direction_excitation, & + homo_irred(1) + idx_virt(k), info_approximation, ABS(eigvec_entries(k)) + END DO + END IF + ELSE + CALL filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, & + i_exc, virtual(1), num_entries, mp2_env, & + offsets=offsets, virtual_per_spin=virtual, idx_spin=idx_spin) + IF (unit_nr > 0) THEN + DO k = 1, num_entries + isp = idx_spin(k) + WRITE (unit_nr, '(T2,A4,T14,I5,T22,A2,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') & + "BSE|", i_exc, spin_label(isp), & + homo_irred(isp) - homo(isp) + idx_homo(k), direction_excitation, & + homo_irred(isp) + idx_virt(k), info_approximation, ABS(eigvec_entries(k)) + END DO + END IF + DEALLOCATE (idx_spin) END IF DEALLOCATE (idx_homo) DEALLOCATE (idx_virt) @@ -587,7 +647,7 @@ CONTAINS 'where c_n = < 𝚿_n | 𝚿_n > = 1 within TDA.' ELSE WRITE (unit_nr, '(T2,A4,T7,A)') prefix_output, & - 'where c_n = < 𝚿_n | 𝚿_n > deviates from 1 without TDA.' + 'where c_n = < 𝚿_n | 𝚿_n > ≥ 1 without TDA.' END IF WRITE (unit_nr, '(T2,A4)') prefix_output WRITE (unit_nr, '(T2,A4)') prefix_output diff --git a/src/bse_util.F b/src/bse_util.F index 3de6d00855..c134e7c215 100644 --- a/src/bse_util.F +++ b/src/bse_util.F @@ -92,7 +92,8 @@ MODULE bse_util deallocate_matrices_bse, comp_eigvec_coeff_BSE, sort_excitations, & estimate_BSE_resources, filter_eigvec_contrib, truncate_BSE_matrices, & determine_cutoff_indices, adapt_BSE_input_params, get_multipoles_mo, & - reshuffle_eigvec, print_bse_nto_cubes, trace_exciton_descr + reshuffle_eigvec, print_bse_nto_cubes, trace_exciton_descr, & + get_bse_spin_block_layout, determine_bse_combined_window, assemble_joint_ov_slab CONTAINS @@ -193,9 +194,12 @@ CONTAINS !> \param unit_nr ... !> \param reordering ... !> \param mp2_env ... +!> \param row_offset ... +!> \param col_offset ... ! ************************************************************************************************** SUBROUTINE fm_general_add_bse(fm_out, fm_in, beta, nrow_secidx_in, ncol_secidx_in, & - nrow_secidx_out, ncol_secidx_out, unit_nr, reordering, mp2_env) + nrow_secidx_out, ncol_secidx_out, unit_nr, reordering, mp2_env, & + row_offset, col_offset) TYPE(cp_fm_type), INTENT(INOUT) :: fm_out TYPE(cp_fm_type), INTENT(IN) :: fm_in @@ -205,13 +209,14 @@ CONTAINS INTEGER :: unit_nr INTEGER, DIMENSION(4) :: reordering TYPE(mp2_type), INTENT(IN) :: mp2_env + INTEGER, INTENT(IN), OPTIONAL :: row_offset, col_offset CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_general_add_bse' INTEGER :: col_idx_loc, dummy, handle, handle2, i_entry_rec, idx_col_out, idx_row_out, ii, & - iproc, jj, ncol_block_in, ncol_block_out, ncol_local_in, ncol_local_out, nprocs, & - nrow_block_in, nrow_block_out, nrow_local_in, nrow_local_out, proc_send, row_idx_loc, & - send_pcol, send_prow + iproc, jj, my_col_offset, my_row_offset, ncol_block_in, ncol_block_out, ncol_local_in, & + ncol_local_out, nprocs, nrow_block_in, nrow_block_out, nrow_local_in, nrow_local_out, & + proc_send, row_idx_loc, send_pcol, send_prow INTEGER, ALLOCATABLE, DIMENSION(:) :: entry_counter, num_entries_rec, & num_entries_send INTEGER, DIMENSION(4) :: indices_in @@ -222,6 +227,14 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env_out TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req_array +! Offsets place the reshuffled block into a sub-block of fm_out (open-shell joint matrix); +! both default 0, recovering the closed-shell single-block placement bit-identically. + + my_row_offset = 0 + my_col_offset = 0 + IF (PRESENT(row_offset)) my_row_offset = row_offset + IF (PRESENT(col_offset)) my_col_offset = col_offset + CALL timeset(routineN, handle) CALL timeset(routineN//"_1_setup", handle2) @@ -280,8 +293,8 @@ CONTAINS indices_in(3) = (col_indices_in(col_idx_loc) - 1)/ncol_secidx_in + 1 indices_in(4) = MOD(col_indices_in(col_idx_loc) - 1, ncol_secidx_in) + 1 - idx_row_out = indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out - idx_col_out = indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out + idx_row_out = my_row_offset + indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out + idx_col_out = my_col_offset + indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out send_prow = fm_out%matrix_struct%g2p_row(idx_row_out) send_pcol = fm_out%matrix_struct%g2p_col(idx_col_out) @@ -360,8 +373,8 @@ CONTAINS indices_in(3) = (col_indices_in(col_idx_loc) - 1)/ncol_secidx_in + 1 indices_in(4) = MOD(col_indices_in(col_idx_loc) - 1, ncol_secidx_in) + 1 - idx_row_out = indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out - idx_col_out = indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out + idx_row_out = my_row_offset + indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out + idx_col_out = my_col_offset + indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out send_prow = fm_out%matrix_struct%g2p_row(idx_row_out) send_pcol = fm_out%matrix_struct%g2p_col(idx_col_out) @@ -843,20 +856,24 @@ CONTAINS END SUBROUTINE comp_eigvec_coeff_BSE ! ************************************************************************************************** -!> \brief ... -!> \param idx_prim ... -!> \param idx_sec ... -!> \param eigvec_entries ... +!> \brief Sorts excitation entries by ascending primary index, reordering the secondary index, +!> the eigenvector coefficients and - open shell - the spin index alongside +!> \param idx_prim Primary index of each entry; sorted in place and used as the sort key +!> \param idx_sec Secondary index of each entry, reordered to follow idx_prim +!> \param eigvec_entries Eigenvector coefficients of each entry, reordered to follow idx_prim +!> \param idx_spin Optional spin index of each entry (open shell), reordered to follow idx_prim ! ************************************************************************************************** - SUBROUTINE sort_excitations(idx_prim, idx_sec, eigvec_entries) + SUBROUTINE sort_excitations(idx_prim, idx_sec, eigvec_entries, idx_spin) INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_prim, idx_sec REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: eigvec_entries + INTEGER, ALLOCATABLE, DIMENSION(:), OPTIONAL :: idx_spin CHARACTER(LEN=*), PARAMETER :: routineN = 'sort_excitations' INTEGER :: handle, ii, kk, num_entries, num_mults - INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_prim_work, idx_sec_work, tmp_index + INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_prim_work, idx_sec_work, & + idx_spin_work, tmp_index LOGICAL :: unique_entries REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: eigvec_entries_work @@ -870,10 +887,12 @@ CONTAINS ALLOCATE (idx_sec_work(num_entries)) ALLOCATE (eigvec_entries_work(num_entries)) + IF (PRESENT(idx_spin)) ALLOCATE (idx_spin_work(num_entries)) DO ii = 1, num_entries idx_sec_work(ii) = idx_sec(tmp_index(ii)) eigvec_entries_work(ii) = eigvec_entries(tmp_index(ii)) + IF (PRESENT(idx_spin)) idx_spin_work(ii) = idx_spin(tmp_index(ii)) END DO DEALLOCATE (tmp_index) @@ -882,6 +901,10 @@ CONTAINS CALL MOVE_ALLOC(idx_sec_work, idx_sec) CALL MOVE_ALLOC(eigvec_entries_work, eigvec_entries) + IF (PRESENT(idx_spin)) THEN + DEALLOCATE (idx_spin) + CALL MOVE_ALLOC(idx_spin_work, idx_spin) + END IF !Now check for multiple entries in first idx to check necessity of sorting in second idx CALL sort_unique(idx_prim, unique_entries) @@ -900,6 +923,10 @@ CONTAINS ALLOCATE (eigvec_entries_work(num_mults)) idx_sec_work(:) = idx_sec(ii:ii + num_mults - 1) eigvec_entries_work(:) = eigvec_entries(ii:ii + num_mults - 1) + IF (PRESENT(idx_spin)) THEN + ALLOCATE (idx_spin_work(num_mults)) + idx_spin_work(:) = idx_spin(ii:ii + num_mults - 1) + END IF ALLOCATE (tmp_index(num_mults)) CALL sort(idx_sec_work, num_mults, tmp_index) @@ -907,11 +934,13 @@ CONTAINS DO kk = ii, ii + num_mults - 1 idx_sec(kk) = idx_sec_work(kk - ii + 1) eigvec_entries(kk) = eigvec_entries_work(tmp_index(kk - ii + 1)) + IF (PRESENT(idx_spin)) idx_spin(kk) = idx_spin_work(tmp_index(kk - ii + 1)) END DO !Deallocate work arrays DEALLOCATE (tmp_index) DEALLOCATE (idx_sec_work) DEALLOCATE (eigvec_entries_work) + IF (PRESENT(idx_spin)) DEALLOCATE (idx_spin_work) END IF idx_prim_work(ii) = idx_prim(ii) END DO @@ -924,17 +953,16 @@ CONTAINS ! ************************************************************************************************** !> \brief Roughly estimates the needed runtime and memory during the BSE run -!> \param homo_red ... -!> \param virtual_red ... +!> \param n_ov_joint ... !> \param unit_nr ... !> \param bse_abba ... !> \param para_env ... !> \param diag_runtime_est ... ! ************************************************************************************************** - SUBROUTINE estimate_BSE_resources(homo_red, virtual_red, unit_nr, bse_abba, & + SUBROUTINE estimate_BSE_resources(n_ov_joint, unit_nr, bse_abba, & para_env, diag_runtime_est) - INTEGER :: homo_red, virtual_red, unit_nr + INTEGER, INTENT(IN) :: n_ov_joint, unit_nr LOGICAL :: bse_abba TYPE(mp_para_env_type), POINTER :: para_env REAL(KIND=dp) :: diag_runtime_est @@ -955,7 +983,7 @@ CONTAINS num_BSE_matrices = 10 END IF - full_dim = (INT(homo_red, KIND=int_8)**2*INT(virtual_red, KIND=int_8)**2)*INT(num_BSE_matrices, KIND=int_8) + full_dim = INT(n_ov_joint, KIND=int_8)**2*INT(num_BSE_matrices, KIND=int_8) mem_est = REAL(8*full_dim, KIND=dp)/REAL(1024**3, KIND=dp) mem_est_per_rank = REAL(mem_est/para_env%num_pe, KIND=dp) @@ -970,7 +998,7 @@ CONTAINS END IF ! Rough estimation of diagonalization runtimes. Baseline was a full BSE Naphthalene ! run with 11000x11000 entries in A/B/C, which took 10s on 32 ranks - diag_runtime_est = REAL(INT(homo_red, KIND=int_8)*INT(virtual_red, KIND=int_8)/11000_int_8, KIND=dp)**3* & + diag_runtime_est = REAL(INT(n_ov_joint, KIND=int_8)/11000_int_8, KIND=dp)**3* & 10*32/REAL(para_env%num_pe, KIND=dp) CALL timestop(handle) @@ -988,21 +1016,27 @@ CONTAINS !> \param virtual ... !> \param num_entries ... !> \param mp2_env ... +!> \param offsets ... +!> \param virtual_per_spin ... +!> \param idx_spin ... ! ************************************************************************************************** SUBROUTINE filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, & - i_exc, virtual, num_entries, mp2_env) + i_exc, virtual, num_entries, mp2_env, & + offsets, virtual_per_spin, idx_spin) TYPE(cp_fm_type), INTENT(IN) :: fm_eigvec INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_homo, idx_virt REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: eigvec_entries INTEGER :: i_exc, virtual, num_entries TYPE(mp2_type), INTENT(INOUT) :: mp2_env + INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: offsets, virtual_per_spin + INTEGER, ALLOCATABLE, DIMENSION(:), OPTIONAL :: idx_spin CHARACTER(LEN=*), PARAMETER :: routineN = 'filter_eigvec_contrib' - INTEGER :: eigvec_idx, handle, ii, iproc, jj, kk, & - ncol_local, nrow_local, & - num_entries_local + INTEGER :: eigvec_idx, handle, ii, iproc, isp, jj, & + kk, ksp, ncol_local, nrow_local, & + num_entries_local, r_local, v_local INTEGER, ALLOCATABLE, DIMENSION(:) :: num_entries_to_comm INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices REAL(KIND=dp) :: eigvec_entry @@ -1046,7 +1080,7 @@ CONTAINS DO iproc = 0, para_env%num_pe - 1 ALLOCATE (buffer_entries(iproc)%msg(num_entries_to_comm(iproc))) - ALLOCATE (buffer_entries(iproc)%indx(num_entries_to_comm(iproc), 2)) + ALLOCATE (buffer_entries(iproc)%indx(num_entries_to_comm(iproc), 3)) buffer_entries(iproc)%msg = 0.0_dp buffer_entries(iproc)%indx = 0 END DO @@ -1061,8 +1095,24 @@ CONTAINS eigvec_idx = row_indices(ii) eigvec_entry = fm_eigvec%local_data(ii, jj) IF (ABS(eigvec_entry) > mp2_env%bse%eps_x) THEN - buffer_entries(para_env%mepos)%indx(kk, 1) = (eigvec_idx - 1)/virtual + 1 - buffer_entries(para_env%mepos)%indx(kk, 2) = MOD(eigvec_idx - 1, virtual) + 1 + ! Decode spin block from the joint row index (blocks are contiguous; sigma is the + ! largest offset strictly below eigvec_idx). offsets absent -> closed shell, sigma=1. + isp = 1 + r_local = eigvec_idx + v_local = virtual + IF (PRESENT(offsets)) THEN + DO ksp = SIZE(offsets), 1, -1 + IF (eigvec_idx > offsets(ksp)) THEN + isp = ksp + EXIT + END IF + END DO + r_local = eigvec_idx - offsets(isp) + v_local = virtual_per_spin(isp) + END IF + buffer_entries(para_env%mepos)%indx(kk, 1) = (r_local - 1)/v_local + 1 + buffer_entries(para_env%mepos)%indx(kk, 2) = MOD(r_local - 1, v_local) + 1 + buffer_entries(para_env%mepos)%indx(kk, 3) = isp buffer_entries(para_env%mepos)%msg(kk) = eigvec_entry kk = kk + 1 END IF @@ -1079,6 +1129,7 @@ CONTAINS ALLOCATE (idx_homo(num_entries)) ALLOCATE (idx_virt(num_entries)) ALLOCATE (eigvec_entries(num_entries)) + IF (PRESENT(idx_spin)) ALLOCATE (idx_spin(num_entries)) kk = 1 DO iproc = 0, para_env%num_pe - 1 @@ -1086,6 +1137,7 @@ CONTAINS DO ii = 1, num_entries_to_comm(iproc) idx_homo(kk) = buffer_entries(iproc)%indx(ii, 1) idx_virt(kk) = buffer_entries(iproc)%indx(ii, 2) + IF (PRESENT(idx_spin)) idx_spin(kk) = buffer_entries(iproc)%indx(ii, 3) eigvec_entries(kk) = buffer_entries(iproc)%msg(ii) kk = kk + 1 END DO @@ -1103,8 +1155,12 @@ CONTAINS NULLIFY (col_indices) !Now sort the results according to the involved singleparticle orbitals - ! (homo first, then virtual) - CALL sort_excitations(idx_homo, idx_virt, eigvec_entries) + ! (homo first, then virtual). idx_spin is payload, permuted alongside the entries. + IF (PRESENT(idx_spin)) THEN + CALL sort_excitations(idx_homo, idx_virt, eigvec_entries, idx_spin) + ELSE + CALL sort_excitations(idx_homo, idx_virt, eigvec_entries) + END IF CALL timestop(handle) @@ -1120,35 +1176,47 @@ CONTAINS !> \param virt_red Total number of unoccupied orbitals to include after ctuoff !> \param homo_incl First occupied index to include after cutoff !> \param virt_incl Last unoccupied index to include after cutoff -!> \param mp2_env ... +!> \param cutoff_occ ... +!> \param cutoff_empty ... ! ************************************************************************************************** SUBROUTINE determine_cutoff_indices(Eigenval, & homo, virtual, & homo_red, virt_red, & homo_incl, virt_incl, & - mp2_env) + cutoff_occ, cutoff_empty) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval INTEGER, INTENT(IN) :: homo, virtual INTEGER, INTENT(OUT) :: homo_red, virt_red, homo_incl, virt_incl - TYPE(mp2_type), INTENT(INOUT) :: mp2_env + REAL(KIND=dp), INTENT(IN) :: cutoff_occ, cutoff_empty CHARACTER(LEN=*), PARAMETER :: routineN = 'determine_cutoff_indices' - INTEGER :: handle, i_homo, j_virt + INTEGER :: handle, i_chk, i_homo, j_virt CALL timeset(routineN, handle) ! Determine index in homo and virtual for truncation - ! Uses indices of outermost orbitals within energy range (-mp2_env%bse%bse_cutoff_occ,mp2_env%bse%bse_cutoff_empty) - IF (mp2_env%bse%bse_cutoff_occ > 0 .OR. mp2_env%bse%bse_cutoff_empty > 0) THEN - IF (-mp2_env%bse%bse_cutoff_occ < Eigenval(1) - Eigenval(homo) & - .OR. mp2_env%bse%bse_cutoff_occ < 0) THEN + ! Uses indices of outermost orbitals within energy range (-cutoff_occ,cutoff_empty) + IF (cutoff_occ > 0 .OR. cutoff_empty > 0) THEN + ! The scans below EXIT at the first orbital beyond the cutoff, which only yields the correct + ! window on an ascending axis. A non-monotonic one (G0W0) stops at the first inversion and + ! silently drops in-window orbitals. + DO i_chk = 2, homo + virtual + IF (Eigenval(i_chk) < Eigenval(i_chk - 1)) THEN + CALL cp_abort(__LOCATION__, & + "determine_cutoff_indices: eigenvalues are not ascending. Take the "// & + "energy cutoff on the DFT axis; the G0W0 axis is not ordered.") + END IF + END DO + + IF (-cutoff_occ < Eigenval(1) - Eigenval(homo) & + .OR. cutoff_occ < 0) THEN homo_red = homo homo_incl = 1 ELSE homo_incl = 1 DO i_homo = 1, homo - IF (Eigenval(i_homo) - Eigenval(homo) > -mp2_env%bse%bse_cutoff_occ) THEN + IF (Eigenval(i_homo) - Eigenval(homo) > -cutoff_occ) THEN homo_incl = i_homo EXIT END IF @@ -1156,14 +1224,14 @@ CONTAINS homo_red = homo - homo_incl + 1 END IF - IF (mp2_env%bse%bse_cutoff_empty > Eigenval(homo + virtual) - Eigenval(homo + 1) & - .OR. mp2_env%bse%bse_cutoff_empty < 0) THEN + IF (cutoff_empty > Eigenval(homo + virtual) - Eigenval(homo + 1) & + .OR. cutoff_empty < 0) THEN virt_red = virtual virt_incl = virtual ELSE virt_incl = homo + 1 DO j_virt = 1, virtual - IF (Eigenval(homo + j_virt) - Eigenval(homo + 1) > mp2_env%bse%bse_cutoff_empty) THEN + IF (Eigenval(homo + j_virt) - Eigenval(homo + 1) > cutoff_empty) THEN virt_incl = j_virt - 1 EXIT END IF @@ -1181,6 +1249,91 @@ CONTAINS END SUBROUTINE determine_cutoff_indices +! ************************************************************************************************** +!> \brief Spin-block layout for the open-shell (joint) BSE matrix: per-spin OV-pair counts and the +!> block offsets into the joint matrix of dimension n_ov_joint = sum_sigma homo*virtual. +!> \param homo_red per-spin (reduced) number of occupied levels +!> \param virt_red per-spin (reduced) number of virtual levels +!> \param n_ov per-spin OV-pair count (OUT) +!> \param offsets per-spin block offset into the joint matrix (OUT) +!> \param n_ov_joint total joint dimension (OUT) +! ************************************************************************************************** + SUBROUTINE get_bse_spin_block_layout(homo_red, virt_red, n_ov, offsets, n_ov_joint) + INTEGER, DIMENSION(:), INTENT(IN) :: homo_red, virt_red + INTEGER, DIMENSION(:), INTENT(OUT) :: n_ov, offsets + INTEGER, INTENT(OUT) :: n_ov_joint + + INTEGER :: isp + + n_ov_joint = 0 + DO isp = 1, SIZE(homo_red) + offsets(isp) = n_ov_joint + n_ov(isp) = homo_red(isp)*virt_red(isp) + n_ov_joint = n_ov_joint + n_ov(isp) + END DO + + END SUBROUTINE get_bse_spin_block_layout + +! ************************************************************************************************** +!> \brief Determine a single combined active-MO window covering all spin channels for open-shell +!> BSE truncation (per-spin determine_cutoff_indices, then union of bounds). Cuts on the DFT +!> axis, as the closed-shell path in truncate_BSE_matrices and linRTBSE's +!> determine_active_mo_window do, so the pipelines truncate to the same active space. +!> CPWARN if the per-spin cutoff candidates differ. +!> \param Eigenval_scf per-spin SCF eigenvalues, shape (level, spin) +!> \param homo per-spin number of occupied levels +!> \param virtual per-spin number of virtual levels +!> \param cutoff_occ occupied-orbital energy cutoff +!> \param cutoff_empty empty-orbital energy cutoff +!> \param first_active_mo combined first occupied MO index (OUT) +!> \param last_active_mo combined last MO index (OUT) +! ************************************************************************************************** + SUBROUTINE determine_bse_combined_window(Eigenval_scf, homo, virtual, & + cutoff_occ, cutoff_empty, & + first_active_mo, last_active_mo) + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: Eigenval_scf + INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual + REAL(KIND=dp), INTENT(IN) :: cutoff_occ, cutoff_empty + INTEGER, INTENT(OUT) :: first_active_mo, last_active_mo + + CHARACTER(LEN=*), PARAMETER :: routineN = 'determine_bse_combined_window' + + INTEGER :: first_occ_prev, handle, homo_incl, & + homo_red, isp, last_virt_prev, & + virt_incl, virt_red + LOGICAL :: spins_differ + + CALL timeset(routineN, handle) + + first_active_mo = HUGE(0) + last_active_mo = 0 + first_occ_prev = -1 + last_virt_prev = -1 + spins_differ = .FALSE. + + DO isp = 1, SIZE(homo) + CALL determine_cutoff_indices(Eigenval_scf(:, isp), homo(isp), virtual(isp), & + homo_red, virt_red, homo_incl, virt_incl, & + cutoff_occ, cutoff_empty) + IF (isp > 1) THEN + IF (homo_incl /= first_occ_prev .OR. homo(isp) + virt_incl /= last_virt_prev) THEN + spins_differ = .TRUE. + END IF + END IF + first_occ_prev = homo_incl + last_virt_prev = homo(isp) + virt_incl + first_active_mo = MIN(first_active_mo, homo_incl) + last_active_mo = MAX(last_active_mo, homo(isp) + virt_incl) + END DO + + IF (spins_differ) THEN + CPWARN("BSE: spin-resolved active MO cutoff candidates differ; using combined window.") + END IF + + CALL timestop(handle) + + END SUBROUTINE determine_bse_combined_window + ! ************************************************************************************************** !> \brief Determines indices within the given energy cutoffs and truncates Eigenvalues and matrices !> \param fm_mat_S_ia_bse ... @@ -1200,6 +1353,8 @@ CONTAINS !> \param homo_red ... !> \param virt_red ... !> \param mp2_env ... +!> \param homo_incl_in ... +!> \param virt_incl_in ... ! ************************************************************************************************** SUBROUTINE truncate_BSE_matrices(fm_mat_S_ia_bse, fm_mat_S_ij_bse, fm_mat_S_ab_bse, & fm_mat_S_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & @@ -1207,7 +1362,8 @@ CONTAINS homo, virtual, dimen_RI, unit_nr, & bse_lev_virt, & homo_red, virt_red, & - mp2_env) + mp2_env, & + homo_incl_in, virt_incl_in) TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_ij_bse, & fm_mat_S_ab_bse @@ -1219,6 +1375,7 @@ CONTAINS bse_lev_virt INTEGER, INTENT(OUT) :: homo_red, virt_red TYPE(mp2_type), INTENT(INOUT) :: mp2_env + INTEGER, INTENT(IN), OPTIONAL :: homo_incl_in, virt_incl_in CHARACTER(LEN=*), PARAMETER :: routineN = 'truncate_BSE_matrices' @@ -1229,45 +1386,58 @@ CONTAINS CALL timeset(routineN, handle) - ! Determine index in homo and virtual for truncation - ! Uses indices of outermost orbitals within energy range (-mp2_env%bse%bse_cutoff_occ,mp2_env%bse%bse_cutoff_empty) + ! Determine index in homo and virtual for truncation. + ! When homo_incl_in/virt_incl_in are provided (combined-window path), skip per-spin + ! determine_cutoff_indices and the print; caller already printed via determine_bse_combined_window. + IF (PRESENT(homo_incl_in)) THEN + homo_incl = homo_incl_in + virt_incl = virt_incl_in + homo_red = homo - homo_incl + 1 + virt_red = virt_incl + ELSE + CALL determine_cutoff_indices(Eigenval_scf, & + homo, virtual, & + homo_red, virt_red, & + homo_incl, virt_incl, & + mp2_env%bse%bse_cutoff_occ, mp2_env%bse%bse_cutoff_empty) - CALL determine_cutoff_indices(Eigenval_scf, & - homo, virtual, & - homo_red, virt_red, & - homo_incl, virt_incl, & - mp2_env) - - IF (unit_nr > 0) THEN - IF (mp2_env%bse%bse_cutoff_occ > 0) THEN - WRITE (unit_nr, '(T2,A4,T7,A29,T71,F10.3)') 'BSE|', 'Cutoff occupied orbitals [eV]', & - mp2_env%bse%bse_cutoff_occ*evolt - ELSE - WRITE (unit_nr, '(T2,A4,T7,A37)') 'BSE|', 'No cutoff given for occupied orbitals' + IF (unit_nr > 0) THEN + IF (mp2_env%bse%bse_cutoff_occ > 0) THEN + WRITE (unit_nr, '(T2,A4,T7,A29,T71,F10.3)') 'BSE|', 'Cutoff occupied orbitals [eV]', & + mp2_env%bse%bse_cutoff_occ*evolt + ELSE + WRITE (unit_nr, '(T2,A4,T7,A37)') 'BSE|', 'No cutoff given for occupied orbitals' + END IF + IF (mp2_env%bse%bse_cutoff_empty > 0) THEN + WRITE (unit_nr, '(T2,A4,T7,A26,T71,F10.3)') 'BSE|', 'Cutoff empty orbitals [eV]', & + mp2_env%bse%bse_cutoff_empty*evolt + ELSE + WRITE (unit_nr, '(T2,A4,T7,A34)') 'BSE|', 'No cutoff given for empty orbitals' + END IF + WRITE (unit_nr, '(T2,A4,T7,A20,T71,I10)') 'BSE|', 'First occupied index', homo_incl + WRITE (unit_nr, '(T2,A4,T7,A32,T71,I10)') 'BSE|', 'Last empty index (not MO index!)', virt_incl + WRITE (unit_nr, '(T2,A4,T7,A35,T71,F10.3)') 'BSE|', 'Energy of first occupied index [eV]', & + Eigenval(homo_incl)*evolt + WRITE (unit_nr, '(T2,A4,T7,A31,T71,F10.3)') 'BSE|', 'Energy of last empty index [eV]', & + Eigenval(homo + virt_incl)*evolt + WRITE (unit_nr, '(T2,A4,T7,A54,T71,F10.3)') 'BSE|', & + 'Energy difference of first occupied index to HOMO [eV]', & + -(Eigenval(homo_incl) - Eigenval(homo))*evolt + WRITE (unit_nr, '(T2,A4,T7,A50,T71,F10.3)') 'BSE|', & + 'Energy difference of last empty index to LUMO [eV]', & + (Eigenval(homo + virt_incl) - Eigenval(homo + 1))*evolt + WRITE (unit_nr, '(T2,A4,T7,A35,T71,I10)') 'BSE|', 'Number of GW-corrected occupied MOs', & + mp2_env%ri_g0w0%corr_mos_occ + WRITE (unit_nr, '(T2,A4,T7,A32,T71,I10)') 'BSE|', 'Number of GW-corrected empty MOs', & + bse_lev_virt + WRITE (unit_nr, '(T2,A4)') 'BSE|' END IF - IF (mp2_env%bse%bse_cutoff_empty > 0) THEN - WRITE (unit_nr, '(T2,A4,T7,A26,T71,F10.3)') 'BSE|', 'Cutoff empty orbitals [eV]', & - mp2_env%bse%bse_cutoff_empty*evolt - ELSE - WRITE (unit_nr, '(T2,A4,T7,A34)') 'BSE|', 'No cutoff given for empty orbitals' - END IF - WRITE (unit_nr, '(T2,A4,T7,A20,T71,I10)') 'BSE|', 'First occupied index', homo_incl - WRITE (unit_nr, '(T2,A4,T7,A32,T71,I10)') 'BSE|', 'Last empty index (not MO index!)', virt_incl - WRITE (unit_nr, '(T2,A4,T7,A35,T71,F10.3)') 'BSE|', 'Energy of first occupied index [eV]', Eigenval(homo_incl)*evolt - WRITE (unit_nr, '(T2,A4,T7,A31,T71,F10.3)') 'BSE|', 'Energy of last empty index [eV]', Eigenval(homo + virt_incl)*evolt - WRITE (unit_nr, '(T2,A4,T7,A54,T71,F10.3)') 'BSE|', 'Energy difference of first occupied index to HOMO [eV]', & - -(Eigenval(homo_incl) - Eigenval(homo))*evolt - WRITE (unit_nr, '(T2,A4,T7,A50,T71,F10.3)') 'BSE|', 'Energy difference of last empty index to LUMO [eV]', & - (Eigenval(homo + virt_incl) - Eigenval(homo + 1))*evolt - WRITE (unit_nr, '(T2,A4,T7,A35,T71,I10)') 'BSE|', 'Number of GW-corrected occupied MOs', mp2_env%ri_g0w0%corr_mos_occ - WRITE (unit_nr, '(T2,A4,T7,A32,T71,I10)') 'BSE|', 'Number of GW-corrected empty MOs', mp2_env%ri_g0w0%corr_mos_virt - WRITE (unit_nr, '(T2,A4)') 'BSE|' END IF IF (unit_nr > 0) THEN IF (homo - homo_incl + 1 > mp2_env%ri_g0w0%corr_mos_occ) THEN CPABORT("Number of GW-corrected occupied MOs too small for chosen BSE cutoff") END IF - IF (virt_incl > mp2_env%ri_g0w0%corr_mos_virt) THEN + IF (virt_incl > bse_lev_virt) THEN CPABORT("Number of GW-corrected virtual MOs too small for chosen BSE cutoff") END IF END IF @@ -1708,10 +1878,11 @@ CONTAINS !> \param homo_red ... !> \param virtual_red ... !> \param context_BSE ... +!> \param ispin spin channel whose mo_set supplies homo/nao (default 1); open-shell beta needs 2 ! ************************************************************************************************** SUBROUTINE get_multipoles_mo(fm_multipole_ai_trunc, fm_multipole_ij_trunc, fm_multipole_ab_trunc, & qs_env, mo_coeff, rpoint, n_moments, & - homo_red, virtual_red, context_BSE) + homo_red, virtual_red, context_BSE, ispin) TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), & INTENT(INOUT) :: fm_multipole_ai_trunc, & @@ -1722,11 +1893,12 @@ CONTAINS REAL(dp), ALLOCATABLE, DIMENSION(:), INTENT(INOUT) :: rpoint INTEGER, INTENT(IN) :: n_moments, homo_red, virtual_red TYPE(cp_blacs_env_type), POINTER :: context_BSE + INTEGER, INTENT(IN), OPTIONAL :: ispin CHARACTER(LEN=*), PARAMETER :: routineN = 'get_multipoles_mo' - INTEGER :: handle, idir, n_multipole, n_occ, & - n_virt, nao, nmo_mp2 + INTEGER :: handle, idir, my_ispin, n_multipole, & + n_occ, n_virt, nao, nmo_mp2 REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point TYPE(cp_fm_struct_type), POINTER :: fm_struct_mp_ab_trunc, fm_struct_mp_ai_trunc, & fm_struct_mp_ij_trunc, fm_struct_multipoles_ao, fm_struct_nao_nmo, fm_struct_nmo_nmo @@ -1740,6 +1912,9 @@ CONTAINS CALL timeset(routineN, handle) + my_ispin = 1 + IF (PRESENT(ispin)) my_ispin = ispin + !First, we calculate the AO dipoles NULLIFY (sab_orb, matrix_s) CALL get_qs_env(qs_env, & @@ -1748,7 +1923,7 @@ CONTAINS sab_orb=sab_orb) ! Use the same blacs environment as for the MO coefficients to ensure correct multiplication dbcsr x fm later on - fm_struct_multipoles_ao => mos(1)%mo_coeff%matrix_struct + fm_struct_multipoles_ao => mos(my_ispin)%mo_coeff%matrix_struct ! BSE has different contexts and blacsenvs para_env_BSE => context_BSE%para_env ! Get size of multipole tensor @@ -1774,7 +1949,7 @@ CONTAINS ! n_occ is the number of occupied MOs, nao the number of all AOs ! Writing homo to n_occ instead if nmo, ! takes care of ADDED_MOS, which would overwrite nmo of qs_env-mos, if invoked - CALL get_mo_set(mo_set=mos(1), homo=n_occ, nao=nao) + CALL get_mo_set(mo_set=mos(my_ispin), homo=n_occ, nao=nao) ! Takes into account removed nullspace values from SVD nmo_mp2 = mo_coeff(1)%matrix_struct%ncol_global n_virt = nmo_mp2 - n_occ @@ -1923,4 +2098,32 @@ CONTAINS END SUBROUTINE trace_exciton_descr +! ************************************************************************************************** +!> \brief Column-concatenate per-spin ia-slabs into the joint dimen_RI x n_ov_joint slab. +!> Sigma-block of spin isp occupies columns offsets(isp)+1 .. offsets(isp)+n_ov(isp). +!> fm_S_joint must be pre-created and zeroed by the caller. +!> \param fm_S_ia per-spin ia-slabs, shape (dimen_RI, n_ov(isp)) per spin +!> \param offsets per-spin column offsets into fm_S_joint (0-based) +!> \param n_ov per-spin OV-pair counts +!> \param dimen_RI RI auxiliary basis dimension (row count) +!> \param fm_S_joint pre-created output slab (dimen_RI x n_ov_joint) +! ************************************************************************************************** + SUBROUTINE assemble_joint_ov_slab(fm_S_ia, offsets, n_ov, dimen_RI, fm_S_joint) + TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_S_ia + INTEGER, DIMENSION(:), INTENT(IN) :: offsets, n_ov + INTEGER, INTENT(IN) :: dimen_RI + TYPE(cp_fm_type), INTENT(INOUT) :: fm_S_joint + + CHARACTER(LEN=*), PARAMETER :: routineN = 'assemble_joint_ov_slab' + + INTEGER :: handle, isp + + CALL timeset(routineN, handle) + DO isp = 1, SIZE(fm_S_ia) + CALL cp_fm_to_fm_submat(fm_S_ia(isp), fm_S_joint, dimen_RI, n_ov(isp), 1, 1, 1, offsets(isp) + 1) + END DO + CALL timestop(handle) + + END SUBROUTINE assemble_joint_ov_slab + END MODULE bse_util diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index 567a1eda4f..e98ef32ade 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -56,16 +56,16 @@ MODULE cp_control_utils do_se_is_slater, do_se_lr_ewald, do_se_lr_ewald_gks, do_se_lr_ewald_r3, do_se_lr_none, & gapw_1c_large, gapw_1c_medium, gapw_1c_orb, gapw_1c_small, gapw_1c_very_large, & gaussian_env, gfn1xtb, gfn_tblite, kg_tnadd_embed, kg_tnadd_embed_ri, no_admm_type, & - numerical, ramp_env, real_time_propagation, rtp_method_bse, sccs_andreussi, & - sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, sccs_derivative_fft, & - sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, sic_list_all, sic_list_unpaired, & - sic_mauri_spz, sic_mauri_us, sic_none, slater, tblite_cli_born_kernel_auto, & - tblite_cli_solution_state_gsolv, tblite_cli_solvation_alpb, tblite_cli_solvation_cpcm, & - tblite_cli_solvation_gb, tblite_cli_solvation_gbe, tblite_cli_solvation_gbsa, & - tblite_guess_ceh, tblite_mixer_memory_inherit, tblite_scc_mixer_auto, & - tblite_scc_mixer_cp2k, tblite_scc_mixer_none, tblite_scc_mixer_tblite, tblite_solver_gvd, & - tblite_solver_gvr, tddfpt_dipole_length, tddfpt_kernel_stda, use_mom_ref_user, & - xtb_vdw_type_d3, xtb_vdw_type_d4, xtb_vdw_type_none + numerical, ramp_env, real_time_propagation, rtp_method_bse, rtp_method_bse_linearized, & + sccs_andreussi, sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, & + sccs_derivative_fft, sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, & + sic_list_all, sic_list_unpaired, sic_mauri_spz, sic_mauri_us, sic_none, slater, & + tblite_cli_born_kernel_auto, tblite_cli_solution_state_gsolv, tblite_cli_solvation_alpb, & + tblite_cli_solvation_cpcm, tblite_cli_solvation_gb, tblite_cli_solvation_gbe, & + tblite_cli_solvation_gbsa, tblite_guess_ceh, tblite_mixer_memory_inherit, & + tblite_scc_mixer_auto, tblite_scc_mixer_cp2k, tblite_scc_mixer_none, & + tblite_scc_mixer_tblite, tblite_solver_gvd, tblite_solver_gvr, tddfpt_dipole_length, & + tddfpt_kernel_stda, use_mom_ref_user, xtb_vdw_type_d3, xtb_vdw_type_d4, xtb_vdw_type_none USE input_cp2k_check, ONLY: xc_functionals_expand USE input_cp2k_dft, ONLY: create_dft_section USE input_enumeration_types, ONLY: enum_i2c,& @@ -566,7 +566,8 @@ CONTAINS IF (do_rtp) THEN ! tmp_section => section_vals_get_subs_vals(dft_section, "REAL_TIME_PROPAGATION%PRINT%POLARIZABILITY") ! CALL section_vals_get(tmp_section, explicit=is_present) - local_moment_possible = (dft_control%rtp_control%rtp_method == rtp_method_bse) .OR. & + local_moment_possible = (dft_control%rtp_control%rtp_method == rtp_method_bse .OR. & + dft_control%rtp_control%rtp_method == rtp_method_bse_linearized) .OR. & ((.NOT. dft_control%rtp_control%periodic) .AND. dft_control%rtp_control%linear_scaling) IF (local_moment_possible .AND. (.NOT. ASSOCIATED(dft_control%rtp_control%print_pol_elements))) THEN tmp_section => section_vals_get_subs_vals(dft_section, "REAL_TIME_PROPAGATION") @@ -3382,7 +3383,8 @@ CONTAINS INTEGER :: i, j, n_elems INTEGER, DIMENSION(:), POINTER :: tmp - LOGICAL :: is_present, local_moment_possible + LOGICAL :: is_present, linearize_bse_propagation, & + local_moment_possible TYPE(section_vals_type), POINTER :: proj_mo_section, subsection ALLOCATE (dft_control%rtp_control) @@ -3398,6 +3400,20 @@ CONTAINS i_val=dft_control%rtp_control%rtp_method) CALL section_vals_val_get(rtp_section, "RTBSE%RTBSE_HAMILTONIAN", & i_val=dft_control%rtp_control%rtbse_ham) + CALL section_vals_val_get(rtp_section, "RTBSE%LINEARIZED_BSE_PROPAGATION", & + l_val=linearize_bse_propagation) + ! Change rtp_method to linearized bse. The section parameter also feeds bs_env%rtp_method, + ! which gates the W(w=0) build in the GW step - TDDFT there would dispatch the linearized + ! propagator with no screened interaction to propagate with, so reject the combination. + IF (linearize_bse_propagation) THEN + IF (dft_control%rtp_control%rtp_method /= rtp_method_bse) THEN + CALL cp_abort(__LOCATION__, & + "LINEARIZED_BSE_PROPAGATION requires the RTBSE section opened as "// & + "'&RTBSE' or '&RTBSE RTBSE', not '&RTBSE TDDFT'.") + END IF + dft_control%rtp_control%rtp_method = rtp_method_bse_linearized + END IF + CALL section_vals_val_get(rtp_section, "PROPAGATOR", & i_val=dft_control%rtp_control%propagator) CALL section_vals_val_get(rtp_section, "EPS_ITER", & @@ -3448,7 +3464,8 @@ CONTAINS dft_control%rtp_control%is_proj_mo = .FALSE. END IF ! Moment trace - local_moment_possible = (dft_control%rtp_control%rtp_method == rtp_method_bse) .OR. & + local_moment_possible = (dft_control%rtp_control%rtp_method == rtp_method_bse .OR. & + dft_control%rtp_control%rtp_method == rtp_method_bse_linearized) .OR. & ((.NOT. dft_control%rtp_control%periodic) .AND. dft_control%rtp_control%linear_scaling) ! TODO : Implement for other moment operators subsection => section_vals_get_subs_vals(rtp_section, "PRINT%MOMENTS") diff --git a/src/emd/rt_bse.F b/src/emd/rt_bse.F index c3df81dd4b..74727a6666 100644 --- a/src/emd/rt_bse.F +++ b/src/emd/rt_bse.F @@ -14,8 +14,7 @@ MODULE rt_bse USE bibliography, ONLY: Marek2025, & cite_reference - USE qs_environment_types, ONLY: get_qs_env, & - qs_environment_type + USE qs_environment_types, ONLY: get_qs_env USE force_env_types, ONLY: force_env_type USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type USE cp_fm_types, ONLY: cp_fm_type, & @@ -87,10 +86,11 @@ MODULE rt_bse create_rtbse_env, & release_rtbse_env, & multiply_fm_cfm + USE rt_bse_ri_rs, ONLY: compute_sigma_ri_rs_complex USE rt_bse_io, ONLY: output_moments, & - read_field, & output_field, & output_mos_contravariant, & + read_field, & read_restart, & output_restart, & print_timestep_info, & @@ -117,7 +117,18 @@ MODULE rt_bse PUBLIC :: run_propagation_bse, & get_hartree, & - get_sigma + get_sigma, & + initialize_rtbse_env, & + initialize_singleparticle_hamiltonian, & + initialize_hartree_potential, & + initialize_cohsex_selfenergy, & + get_idempotence_deviation, & + antiherm_metric, & + init_hartree, & + rho_metric, & + propagate_density, & + cp_cfm_gexp, & + get_electron_number INTERFACE get_sigma MODULE PROCEDURE get_sigma_complex, & @@ -134,11 +145,9 @@ CONTAINS ! ************************************************************************************************** !> \brief Runs the electron-only real time BSE propagation -!> \param qs_env Quickstep environment data, containing the config from input files !> \param force_env Force environment data, entry point of the calculation ! ************************************************************************************************** - SUBROUTINE run_propagation_bse(qs_env, force_env) - TYPE(qs_environment_type), POINTER :: qs_env + SUBROUTINE run_propagation_bse(force_env) TYPE(force_env_type), POINTER :: force_env CHARACTER(len=*), PARAMETER :: routineN = 'run_propagation_bse' TYPE(rtbse_env_type), POINTER :: rtbse_env @@ -159,7 +168,7 @@ CONTAINS CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., consistent_energies=.FALSE.) ! Allocate all persistant storage and read input that does not need further processing - CALL create_rtbse_env(rtbse_env, qs_env, force_env) + CALL create_rtbse_env(rtbse_env, force_env) CALL print_rtbse_header_info(rtbse_env) @@ -167,15 +176,23 @@ CONTAINS CALL cp_add_iter_level(logger%iter_info, "MD") ! Initialize non-trivial values ! - calculates the moment operators + CALL initialize_moments(rtbse_env) + ! - populates overlap and inverse overlap matrices + CALL initialize_rtbse_env(rtbse_env) + ! - populates the initial density matrix ! - reads the restart density if requested - ! - reads the field and moment trace from previous runs - ! - populates overlap and inverse overlap matrices + CALL initialize_density_matrix(rtbse_env) + ! - reads the moment and field traces from previous runs (no-op if the files are absent) + CALL read_moments(rtbse_env%moments_section, rtbse_env%sim_start_orig, & + rtbse_env%sim_start, rtbse_env%moments_trace, rtbse_env%time_trace) + CALL read_field(rtbse_env) ! - calculates/populates the G0W0/KS Hamiltonian, respectively + CALL initialize_singleparticle_hamiltonian(rtbse_env) ! - calculates the Hartree reference potential + CALL initialize_hartree_potential(rtbse_env) ! - calculates the COHSEX reference self-energy - ! - prints some info about loaded files into the output - CALL initialize_rtbse_env(rtbse_env) + CALL initialize_cohsex_selfenergy(rtbse_env) ! Setup the time based on the starting step ! Assumes identical dt between two runs @@ -213,7 +230,7 @@ CONTAINS workspace=rtbse_env%rho_workspace, metric=a_metric_2) END DO END IF - CALL print_timestep_info(rtbse_env, i, metric, enum_re, k) + CALL print_timestep_info(rtbse_env, i, [enum_re], metric, k) IF (.NOT. converged) CPABORT("ETRS did not converge") CALL cp_iterate(logger%iter_info, iter_nr=i, last=(i == rtbse_env%sim_nsteps)) DO j = 1, rtbse_env%n_spin @@ -249,24 +266,48 @@ CONTAINS ! ************************************************************************************************** !> \brief Calculates the initial values, based on restart/scf density, and other non-trivial values !> \param rtbse_env RT-BSE environment -!> \param qs_env Quickstep environment (needed for reference to previous calculations) !> \author Stepan Marek (09.24) ! ************************************************************************************************** SUBROUTINE initialize_rtbse_env(rtbse_env) TYPE(rtbse_env_type), POINTER :: rtbse_env CHARACTER(len=*), PARAMETER :: routineN = "initialize_rtbse_env" TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: moments_dbcsr_p TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s - REAL(kind=dp), DIMENSION(:), POINTER :: occupations - REAL(kind=dp), DIMENSION(3) :: rpoint - INTEGER :: i, k, handle + INTEGER :: handle CALL timeset(routineN, handle) ! Get pointers to parameters from qs_env CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env, matrix_s=matrix_s) + ! ****** START OVERLAP + INVERSE OVERLAP CALCULATION + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, rtbse_env%S_fm) + CALL cp_fm_to_cfm(msourcer=rtbse_env%S_fm, mtarget=rtbse_env%S_cfm) + CALL cp_fm_invert(rtbse_env%S_fm, rtbse_env%S_inv_fm) + ! ****** END OVERLAP + INVERSE OVERLAP CALCULATION + + CALL timestop(handle) + END SUBROUTINE initialize_rtbse_env + +! ************************************************************************************************** +!> \brief Calculates the moment operators +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_moments(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + CHARACTER(len=*), PARAMETER :: routineN = "initialize_moments" + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: moments_dbcsr_p + INTEGER :: i, k, handle + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s + REAL(kind=dp), DIMENSION(3) :: rpoint + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env, matrix_s=matrix_s) + ! ****** START MOMENTS OPERATOR CALCULATION ! Construct moments from dbcsr NULLIFY (moments_dbcsr_p) @@ -286,16 +327,20 @@ CONTAINS reference=rtbse_env%moment_ref_type, ref_point=rtbse_env%user_moment_ref_point) CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) ! Copy to full matrix - DO k = 1, 3 - ! Again, matrices are created from overlap template - CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments(k)) + DO i = 1, rtbse_env%n_spin + DO k = 1, 3 + ! AO dipole is spin-independent; replicate into each spin slot + CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments(k, i)) + END DO END DO ! Now, repeat without reference point to get the moments for field CALL get_reference_point(rpoint, qs_env=rtbse_env%qs_env, & reference=use_mom_ref_zero) CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) - DO k = 1, 3 - CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments_field(k)) + DO i = 1, rtbse_env%n_spin + DO k = 1, 3 + CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments_field(k, i)) + END DO END DO ! Now can deallocate dbcsr matrices @@ -306,6 +351,26 @@ CONTAINS DEALLOCATE (moments_dbcsr_p) ! ****** END MOMENTS OPERATOR CALCULATION + CALL timestop(handle) + END SUBROUTINE initialize_moments + +! ************************************************************************************************** +!> \brief Calculates the initial density matrix, based on the SCF density or restart density if requested +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_density_matrix(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + CHARACTER(len=*), PARAMETER :: routineN = "initialize_density_matrix" + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(kind=dp), DIMENSION(:), POINTER :: occupations + INTEGER :: i, handle + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + ! ****** START INITIAL DENSITY MATRIX CALCULATION ! Get the rho from fm_MOS ! Uses real orbitals only - no kpoints @@ -331,22 +396,25 @@ CONTAINS CALL read_restart(rtbse_env) END IF ! ****** END INITIAL DENSITY MATRIX CALCULATION - ! ****** START MOMENTS TRACE LOAD - ! The moments are only loaded if the consistent save files exist - CALL read_moments(rtbse_env%moments_section, rtbse_env%sim_start_orig, & - rtbse_env%sim_start, rtbse_env%moments_trace, rtbse_env%time_trace) - ! ****** END MOMENTS TRACE LOAD - ! ****** START FIELD TRACE LOAD - ! The moments are only loaded if the consistent save files exist - CALL read_field(rtbse_env) - ! ****** END FIELD TRACE LOAD + CALL timestop(handle) + END SUBROUTINE initialize_density_matrix - ! ****** START OVERLAP + INVERSE OVERLAP CALCULATION - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, rtbse_env%S_fm) - CALL cp_fm_to_cfm(msourcer=rtbse_env%S_fm, mtarget=rtbse_env%S_cfm) - CALL cp_fm_invert(rtbse_env%S_fm, rtbse_env%S_inv_fm) - ! ****** END OVERLAP + INVERSE OVERLAP CALCULATION +! ************************************************************************************************** +!> \brief Calculates the single particle Hamiltonian +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_singleparticle_hamiltonian(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + CHARACTER(len=*), PARAMETER :: routineN = "initialize_singleparticle_hamiltonian" + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: i, handle + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) ! ****** START SINGLE PARTICLE HAMILTONIAN CALCULATION DO i = 1, rtbse_env%n_spin @@ -376,19 +444,28 @@ CONTAINS END DO ! ****** END SINGLE PARTICLE HAMILTONIAN CALCULATION + CALL timestop(handle) + END SUBROUTINE initialize_singleparticle_hamiltonian + +! ************************************************************************************************** +!> \brief Calculates the Hartree potential +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_hartree_potential(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + CHARACTER(len=*), PARAMETER :: routineN = "initialize_hartree_potential" + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: i, handle + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + ! ****** START HARTREE POTENTIAL REFERENCE CALCULATION ! Calculate Coulomb RI elements, necessary for Hartree calculation CALL init_hartree(rtbse_env, rtbse_env%v_dbcsr) - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! In a non-HF calculation, copy the actual correlation part of the interaction - CALL copy_fm_to_dbcsr(bs_env%fm_W_MIC_freq_zero, rtbse_env%w_dbcsr) - ELSE - ! In HF, correlation is set to zero - CALL dbcsr_set(rtbse_env%w_dbcsr, 0.0_dp) - END IF - ! Add the Hartree to the screened_dbt tensor - now W = V + W^c - CALL dbcsr_add(rtbse_env%w_dbcsr, rtbse_env%v_dbcsr, 1.0_dp, 1.0_dp) - CALL dbt_copy_matrix_to_tensor(rtbse_env%w_dbcsr, rtbse_env%screened_dbt) ! Calculate the original Hartree potential ! Uses rho_orig - same as rho for initial run but different for continued run DO i = 1, rtbse_env%n_spin @@ -402,37 +479,60 @@ CONTAINS END DO ! ****** END HARTREE POTENTIAL REFERENCE CALCULATION + CALL timestop(handle) + END SUBROUTINE initialize_hartree_potential + +! ************************************************************************************************** +!> \brief Calculates the COHSEX reference self-energy +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_cohsex_selfenergy(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + CHARACTER(len=*), PARAMETER :: routineN = "initialize_cohsex_selfenergy" + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: i, handle + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + ! ****** START COHSEX REFERENCE CALCULATION - ! Calculate the COHSEX starting energies IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! Subtract the v_xc from COH part of the self-energy, as V_xc is also not updated during the timestepping - DO i = 1, rtbse_env%n_spin + ! In a non-HF calculation, copy the actual correlation part of the interaction + CALL copy_fm_to_dbcsr(bs_env%fm_W_MIC_freq_zero, rtbse_env%w_dbcsr) + ELSE + ! In HF, correlation is set to zero + CALL dbcsr_set(rtbse_env%w_dbcsr, 0.0_dp) + END IF + ! Add the Hartree to the screened_dbt tensor - now W = V + W^c + CALL dbcsr_add(rtbse_env%w_dbcsr, rtbse_env%v_dbcsr, 1.0_dp, 1.0_dp) + CALL dbt_copy_matrix_to_tensor(rtbse_env%w_dbcsr, rtbse_env%screened_dbt) + ! Calculate the COHSEX starting energies + DO i = 1, rtbse_env%n_spin + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ! Subtract the v_xc from COH part of the self-energy, as V_xc is also not updated during the timestepping ! TODO : Allow no COH calculation for static screening CALL get_sigma(rtbse_env, rtbse_env%sigma_COH(i), -0.5_dp, rtbse_env%S_inv_fm) ! Copy and subtract from the complex reference hamiltonian CALL cp_fm_to_cfm(msourcer=rtbse_env%sigma_COH(i), mtarget=rtbse_env%ham_workspace(1)) CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & CMPLX(-1.0, 0.0, kind=dp), rtbse_env%ham_workspace(1)) - ! Calculate exchange part - TODO : should this be applied for different spins? - TEST with O2 HF propagation? - ! So far only closed shell tested - ! Uses rho_orig - same as rho for initial run but different for continued run - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX(i), -1.0_dp, rtbse_env%rho_orig(i)) - ! Subtract from the complex reference Hamiltonian - CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & - CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) - END DO - ELSE - ! KS Hamiltonian - use time-dependent Fock exchange - DO i = 1, rtbse_env%n_spin - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX(i), -1.0_dp, rtbse_env%rho_orig(i)) - CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & - CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) - END DO - END IF + END IF + ! Calculate exchange part - TODO : should this be applied for different spins? - TEST with O2 HF propagation? + ! So far only closed shell tested + ! Uses rho_orig - same as rho for initial run but different for continued run + ! For KS reference this is the time-dependent Fock exchange (w_dbcsr = v only). + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX(i), -1.0_dp, rtbse_env%rho_orig(i)) + ! Subtract from the complex reference Hamiltonian + CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & + CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) + END DO ! ****** END COHSEX REFERENCE CALCULATION CALL timestop(handle) - END SUBROUTINE initialize_rtbse_env + END SUBROUTINE initialize_cohsex_selfenergy ! ************************************************************************************************** !> \brief Custom reimplementation of the delta pulse routines @@ -460,7 +560,7 @@ CONTAINS CALL cp_fm_set_all(rtbse_env%real_workspace(1), 0.0_dp) DO k = 1, 3 CALL cp_fm_scale_and_add(1.0_dp, rtbse_env%real_workspace(1), & - kvec(k), rtbse_env%moments_field(k)) + kvec(k), rtbse_env%moments_field(k, 1)) END DO ! enforce hermiticity of the effective Hamiltonian CALL cp_fm_transpose(rtbse_env%real_workspace(1), rtbse_env%real_workspace(2)) @@ -632,12 +732,12 @@ CONTAINS DO j = 1, nspin DO k = 1, 3 ! Minus sign due to charge of electrons - CALL cp_fm_to_cfm(msourcer=rtbse_env%moments_field(k), mtarget=rtbse_env%ham_workspace(1)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%moments_field(k, 1), mtarget=rtbse_env%ham_workspace(1)) CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_effective(j), & CMPLX(rtbse_env%field(k), 0.0, kind=dp), rtbse_env%ham_workspace(1)) END DO IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! Add the COH part - so far static but can be dynamic in principle throught the W updates + ! Add the COH part - so far static but can be dynamic in principle through the W updates CALL get_sigma(rtbse_env, rtbse_env%sigma_COH(j), -0.5_dp, rtbse_env%S_inv_fm) CALL cp_fm_to_cfm(msourcer=rtbse_env%sigma_COH(j), mtarget=rtbse_env%ham_workspace(1)) CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_effective(j), & @@ -854,7 +954,7 @@ CONTAINS CMPLX(1.0, 0.0, kind=dp), exponential(j), rtbse_env%rho_workspace(1), & CMPLX(0.0, 0.0, kind=dp), rho_new(j)) END DO - ELSE IF (rtbse_env%mat_exp_method == do_bch) THEN + ELSE IF (rtbse_env%mat_exp_method == do_bch .OR. rtbse_env%linearized) THEN ! Same number of iterations as ETRS CALL bch_propagate(exponential, rho_old, rho_new, rtbse_env%rho_workspace, threshold_opt=rtbse_env%exp_accuracy, & max_iter_opt=rtbse_env%etrs_max_iter) @@ -938,32 +1038,48 @@ CONTAINS !> \note Can be used for both the Coulomb hole part and screened exchange part !> \param rtbse_env Quickstep environment data, entry point of the calculation !> \param sigma_cfm Pointer to the self-energy full matrix, which is overwritten by this routine +!> \param prefactor_opt Optional scaling factor applied to the contraction, defaults to 1.0 !> \param greens_cfm Pointer to the Green's function matrix, which is used as input data +!> \param grid_diag_re_accum Optional accumulator for the real part of the RI-RS grid diagonal +!> \param grid_diag_im_accum Optional accumulator for the imaginary part of the RI-RS grid diagonal !> \author Stepan Marek !> \date 09.2024 ! ************************************************************************************************** - SUBROUTINE get_sigma_complex(rtbse_env, sigma_cfm, prefactor_opt, greens_cfm) + SUBROUTINE get_sigma_complex(rtbse_env, sigma_cfm, prefactor_opt, greens_cfm, & + grid_diag_re_accum, grid_diag_im_accum) TYPE(rtbse_env_type), POINTER :: rtbse_env TYPE(cp_cfm_type) :: sigma_cfm ! resulting self energy REAL(kind=dp), INTENT(IN), OPTIONAL :: prefactor_opt TYPE(cp_cfm_type), INTENT(IN) :: greens_cfm ! matrix to contract with RI_W + REAL(kind=dp), INTENT(INOUT), OPTIONAL :: grid_diag_re_accum(:), grid_diag_im_accum(:) REAL(kind=dp) :: prefactor prefactor = 1.0_dp IF (PRESENT(prefactor_opt)) prefactor = prefactor_opt + ! RI-RS screened-exchange backend (linRTBSE only; rirs_kernel is forced .FALSE. for full RTBSE, + ! so this is inert there). The RI-RS routine does its own Re/Im split, replacing the AO-RI body. + ! The optional grid_diag_* accumulators harvest diag(φρφ^T) for the Hartree reuse (RI-RS only; + ! absent on AO-RI calls, which build no grid). + IF (rtbse_env%rirs_kernel) THEN + CALL compute_sigma_ri_rs_complex(rtbse_env%bs_env, sigma_cfm, prefactor, greens_cfm, & + grid_diag_re_accum=grid_diag_re_accum, & + grid_diag_im_accum=grid_diag_im_accum) + RETURN + END IF + ! Carry out the sigma part twice ! Real part CALL cp_cfm_to_fm(msource=greens_cfm, mtargetr=rtbse_env%real_workspace(1)) CALL get_sigma(rtbse_env, rtbse_env%real_workspace(2), prefactor, rtbse_env%real_workspace(1)) - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(2), mtarget=rtbse_env%ham_workspace(1)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(2), mtarget=rtbse_env%sigma_complex_workspace(1)) ! Imaginary part CALL cp_cfm_to_fm(msource=greens_cfm, mtargeti=rtbse_env%real_workspace(1)) CALL get_sigma(rtbse_env, rtbse_env%real_workspace(2), prefactor, rtbse_env%real_workspace(1)) CALL cp_fm_to_cfm(msourcei=rtbse_env%real_workspace(2), mtarget=sigma_cfm) ! Add the real part CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), sigma_cfm, & - CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_workspace(1)) + CMPLX(1.0, 0.0, kind=dp), rtbse_env%sigma_complex_workspace(1)) END SUBROUTINE get_sigma_complex ! ************************************************************************************************** @@ -981,15 +1097,25 @@ CONTAINS REAL(kind=dp), INTENT(IN), OPTIONAL :: prefactor_opt TYPE(cp_fm_type), INTENT(IN) :: greens_fm ! matrix to contract with RI_W REAL(kind=dp) :: prefactor + TYPE(dbcsr_type) :: greens_dbcsr_scratch + TYPE(post_scf_bandstructure_type), POINTER :: bs_env prefactor = 1.0_dp IF (PRESENT(prefactor_opt)) prefactor = prefactor_opt - ! Carry out the sigma part twice - ! Convert to dbcsr - CALL copy_fm_to_dbcsr(greens_fm, rtbse_env%rho_dbcsr) - CALL get_sigma_dbcsr(rtbse_env, sigma_fm, prefactor, rtbse_env%rho_dbcsr) + ! Local AO-AO dbcsr scratch for the FM->DBCSR conversion. Previously this + ! routine used rtbse_env%rho_dbcsr as the workspace, which coupled AO-RI SX + ! to the AO-RI Hartree allocation path - the historical (RIRS-H + AO-RI-SX) + ! cross-combo (no longer expressible under the single KERNEL_RI switch) + ! then segfaulted because rho_dbcsr is skipped when rirs_kernel=T. + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + CALL dbcsr_create(greens_dbcsr_scratch, name="get_sigma greens scratch", & + template=bs_env%mat_ao_ao%matrix) + CALL copy_fm_to_dbcsr(greens_fm, greens_dbcsr_scratch) + CALL get_sigma_dbcsr(rtbse_env, sigma_fm, prefactor, greens_dbcsr_scratch) + + CALL dbcsr_release(greens_dbcsr_scratch) END SUBROUTINE get_sigma_real ! ************************************************************************************************** !> \brief Calculates the self-energy by contraction of screened potential diff --git a/src/emd/rt_bse_io.F b/src/emd/rt_bse_io.F index a41f6b968e..b939c76126 100644 --- a/src/emd/rt_bse_io.F +++ b/src/emd/rt_bse_io.F @@ -40,8 +40,11 @@ MODULE rt_bse_io do_bch, & rtp_bse_ham_g0w0, & rtp_bse_ham_ks, & - use_rt_restart - USE physcon, ONLY: femtoseconds + use_rt_restart, & + restart_guess + USE qs_environment_types, ONLY: get_qs_env + USE scf_control_types, ONLY: scf_control_type + USE physcon, ONLY: evolt, femtoseconds USE rt_propagation_output, ONLY: print_moments, & print_rt_file, & rt_file_comp_real @@ -54,6 +57,9 @@ MODULE rt_bse_io CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = "rt_bse_io" + ! RESTART.trace on-disk format version - bump whenever the header or record layout changes + INTEGER, PARAMETER, PRIVATE :: restart_trace_version = 1 + #:include "rt_bse_macros.fypp" PUBLIC :: output_moments, & @@ -63,6 +69,12 @@ MODULE rt_bse_io output_mos_covariant, & output_restart, & read_restart, & + output_restart_linearized, & + read_restart_info, & + read_restart_trace, & + read_restart_density, & + read_restart_C, & + check_restart_eps_consistency, & print_etrs_info_header, & print_etrs_info, & print_timestep_info, & @@ -152,24 +164,87 @@ CONTAINS END SUBROUTINE print_etrs_info_header ! ************************************************************************************************** -!> \brief Writes the header for the etrs iteration updates - only for log level > low +!> \brief Writes the summary line of a completed propagation timestep !> \param rtbse_env Entry point - rtbse environment +!> \param step Index of the completed timestep +!> \param electron_num_re Real part of the electron number, one entry per spin channel +!> \param convergence Optional convergence metric reached by the ETRS iteration +!> \param etrs_num Optional number of ETRS iterations used in this timestep +!> \param step_walltime Optional wall time of this timestep, in seconds ! ************************************************************************************************** - SUBROUTINE print_timestep_info(rtbse_env, step, convergence, electron_num_re, etrs_num) + SUBROUTINE print_timestep_info(rtbse_env, step, electron_num_re, convergence, etrs_num, & + step_walltime) TYPE(rtbse_env_type) :: rtbse_env INTEGER :: step - REAL(kind=dp) :: convergence - REAL(kind=dp) :: electron_num_re - INTEGER :: etrs_num + REAL(kind=dp), DIMENSION(:), INTENT(IN) :: electron_num_re + REAL(kind=dp), OPTIONAL :: convergence + INTEGER, OPTIONAL :: etrs_num + REAL(kind=dp), OPTIONAL :: step_walltime TYPE(cp_logger_type), POINTER :: logger + LOGICAL :: flag_lrrtbse + INTEGER :: nch logger => cp_get_default_logger() + ! one electron-number column per spin channel (1 = closed shell, 2 = open shell alpha/beta) + nch = SIZE(electron_num_re) + + IF (.NOT. PRESENT(convergence) .OR. .NOT. PRESENT(etrs_num)) THEN + flag_lrrtbse = .TRUE. + ELSE + flag_lrrtbse = .FALSE. + END IF IF (logger%iter_info%print_level > low_print_level .AND. rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A23,A20,A20,A17)') " RTBSE| Simulation step", "Convergence", & - "Electron number", "ETRS Iterations" - WRITE (rtbse_env%unit_nr, '(A7,I16,E20.8E3,E20.8E3,I17)') ' RTBSE|', step, convergence, & - electron_num_re, etrs_num + IF (flag_lrrtbse) THEN + IF (step == 0) THEN + IF (PRESENT(step_walltime)) THEN + WRITE (rtbse_env%unit_nr, '(A45,T70,F11.3)') & + " RTBSE| Estimated runtime for propagation [s]", & + step_walltime*REAL(rtbse_env%sim_nsteps, dp) + WRITE (rtbse_env%unit_nr, '(A)') & + " RTBSE|" + IF (nch == 1) THEN + WRITE (rtbse_env%unit_nr, '(A23,T27,A13,T66,A15)') & + " RTBSE| Simulation step", "Step time [s]", "Electron number" + ELSE + ! T67/T88 (not T66/T86): each α/β is 2 bytes but 1 display col, so the byte + ! anchor is +1 per unicode char to right-align ')' under the value's last digit. + ! T anchors carry +1 byte per α/β before the ')' (α col → +1, β col → +2), + ! since each is 2 bytes but 1 display col; right-aligns ')' on the last digit. + WRITE (rtbse_env%unit_nr, '(A23,T27,A13,T47,A15,T68,A15)') & + " RTBSE| Simulation step", "Step time [s]", "El. number (α)", "El. number (β)" + END IF + ELSE + IF (nch == 1) THEN + WRITE (rtbse_env%unit_nr, '(A23,T66,A15)') " RTBSE| Simulation step", "Electron number" + ELSE + WRITE (rtbse_env%unit_nr, '(A23,T47,A15,T68,A15)') & + " RTBSE| Simulation step", "El. number (α)", "El. number (β)" + END IF + END IF + END IF + IF (PRESENT(step_walltime)) THEN + IF (nch == 1) THEN + WRITE (rtbse_env%unit_nr, '(A7,I16,T30,F10.3,T69,E12.3E3)') & + ' RTBSE|', step, step_walltime, electron_num_re(1) + ELSE + WRITE (rtbse_env%unit_nr, '(A7,I16,T30,F10.3,T49,E12.3E3,T69,E12.3E3)') & + ' RTBSE|', step, step_walltime, electron_num_re(1), electron_num_re(2) + END IF + ELSE + IF (nch == 1) THEN + WRITE (rtbse_env%unit_nr, '(A7,I16,T61,E20.8E3)') ' RTBSE|', step, electron_num_re(1) + ELSE + WRITE (rtbse_env%unit_nr, '(A7,I16,T49,E12.3E3,T69,E12.3E3)') & + ' RTBSE|', step, electron_num_re(1), electron_num_re(2) + END IF + END IF + ELSE + WRITE (rtbse_env%unit_nr, '(A23,A20,A20,A17)') " RTBSE| Simulation step", "Convergence", & + "Electron number", "ETRS Iterations" + WRITE (rtbse_env%unit_nr, '(A7,I16,E20.8E3,E20.8E3,I17)') ' RTBSE|', step, convergence, & + electron_num_re(1), etrs_num + END IF END IF END SUBROUTINE print_timestep_info @@ -194,6 +269,22 @@ CONTAINS file_labels(3) = "_SPIN_B_RE.dat" file_labels(4) = "_SPIN_B_IM.dat" logger => cp_get_default_logger() + + ! In the linearized RT-BSE active-MO path, rho is already in the MO basis + ! restricted to the active window (sized mo_active x mo_active). Dump it + ! directly without the AO-side C^T S * rho * S C transformation. + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + DO j = 1, rtbse_env%n_spin + rho_unit_re = cp_print_key_unit_nr(logger, print_key_section, extension=file_labels(2*j - 1)) + rho_unit_im = cp_print_key_unit_nr(logger, print_key_section, extension=file_labels(2*j)) + CALL cp_cfm_to_fm(rho(j), rtbse_env%real_workspace_mo(1), rtbse_env%real_workspace_mo(2)) + CALL cp_fm_write_formatted(rtbse_env%real_workspace_mo(1), rho_unit_re) + CALL cp_fm_write_formatted(rtbse_env%real_workspace_mo(2), rho_unit_im) + CALL cp_print_key_finished_output(rho_unit_re, logger, print_key_section) + CALL cp_print_key_finished_output(rho_unit_im, logger, print_key_section) + END DO + RETURN + END IF ! Start by multiplying the current density by MOS DO j = 1, rtbse_env%n_spin rho_unit_re = cp_print_key_unit_nr(logger, print_key_section, extension=file_labels(2*j - 1)) @@ -357,25 +448,33 @@ CONTAINS TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho INTEGER :: i, j, n REAL(kind=dp), DIMENSION(3) :: moments_re + TYPE(cp_fm_type), DIMENSION(:), POINTER :: ws n = rtbse_env%sim_step - rtbse_env%sim_start_orig + 1 + ! In linearized RT-BSE rho and moments are MO-active sized; otherwise AO sized. + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + ws => rtbse_env%real_workspace_mo + ELSE + ws => rtbse_env%real_workspace + END IF + DO j = 1, rtbse_env%n_spin ! Need to transpose due to the definition of trace function - CALL cp_cfm_to_fm(msource=rho(j), mtargetr=rtbse_env%real_workspace(2)) + CALL cp_cfm_to_fm(msource=rho(j), mtargetr=ws(2)) DO i = 1, 3 ! Moments should be symmetric, test without transopose? - CALL cp_fm_transpose(rtbse_env%moments(i), rtbse_env%real_workspace(1)) - CALL cp_fm_trace(rtbse_env%real_workspace(1), rtbse_env%real_workspace(2), moments_re(i)) + CALL cp_fm_transpose(rtbse_env%moments(i, j), ws(1)) + CALL cp_fm_trace(ws(1), ws(2), moments_re(i)) ! Scale by spin degeneracy and electron charge moments_re(i) = -moments_re(i)*rtbse_env%spin_degeneracy rtbse_env%moments_trace(j, i, n) = CMPLX(moments_re(i), 0.0, kind=dp) END DO ! Same for imaginary part - CALL cp_cfm_to_fm(msource=rho(j), mtargeti=rtbse_env%real_workspace(2)) + CALL cp_cfm_to_fm(msource=rho(j), mtargeti=ws(2)) DO i = 1, 3 - CALL cp_fm_transpose(rtbse_env%moments(i), rtbse_env%real_workspace(1)) - CALL cp_fm_trace(rtbse_env%real_workspace(1), rtbse_env%real_workspace(2), moments_re(i)) + CALL cp_fm_transpose(rtbse_env%moments(i, j), ws(1)) + CALL cp_fm_trace(ws(1), ws(2), moments_re(i)) ! Scale by spin degeneracy and electron charge moments_re(i) = -moments_re(i)*rtbse_env%spin_degeneracy rtbse_env%moments_trace(j, i, n) = rtbse_env%moments_trace(j, i, n) + CMPLX(0.0, moments_re(i), kind=dp) @@ -486,4 +585,392 @@ CONTAINS END IF END DO END SUBROUTINE read_restart +! ************************************************************************************************** +!> \brief Linearized RT-BSE restart writer. Writes the restart set: lab-frame MO-active density +!> matrices, the .info step index (sim_step = steps completed = the resume step), the +!> once-per-run C_active gauge reference, and the appended RESTART.trace record feeding the +!> FT prefix on continuation. All indices derive from sim_step so the .info/.trace +!> bookkeeping cannot drift apart. (Full RTBSE uses the upstream output_restart above.) +!> \param rtbse_env RT-BSE environment +!> \param rho Density matrix (lab frame) to store +! ************************************************************************************************** + SUBROUTINE output_restart_linearized(rtbse_env, rho) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho + TYPE(cp_fm_type), DIMENSION(:), POINTER :: workspace + CHARACTER(len=17), DIMENSION(4) :: file_labels + CHARACTER(len=16), DIMENSION(2) :: c_file_labels + TYPE(cp_logger_type), POINTER :: logger + INTEGER :: rho_unit_nr, i + + ! Default labels distinguishing up to two spin species and real/imaginary parts + file_labels(1) = "_SPIN_A_RE.matrix" + file_labels(2) = "_SPIN_A_IM.matrix" + file_labels(3) = "_SPIN_B_RE.matrix" + file_labels(4) = "_SPIN_B_IM.matrix" + c_file_labels(1) = "_SPIN_A_C.matrix" + c_file_labels(2) = "_SPIN_B_C.matrix" + + logger => cp_get_default_logger() + + ! In linearized RT-BSE rho is MO-active sized; otherwise AO sized. + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + workspace => rtbse_env%real_workspace_mo + ELSE + workspace => rtbse_env%real_workspace + END IF + + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_to_fm(rho(i), workspace(1), workspace(2)) + ! Real part + rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=file_labels(2*i - 1), & + file_form="UNFORMATTED", file_position="REWIND") + CALL cp_fm_write_unformatted(workspace(1), rho_unit_nr) + CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) + ! Imag part + rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=file_labels(2*i), & + file_form="UNFORMATTED", file_position="REWIND") + CALL cp_fm_write_unformatted(workspace(2), rho_unit_nr) + CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) + ! Info + rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=".info", & + file_form="UNFORMATTED", file_position="REWIND") + IF (rho_unit_nr > 0) WRITE (rho_unit_nr) rtbse_env%sim_step + CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) + END DO + + ! Once-per-run C_active dump (linearized only): gauge reference for the restart basis bridge + IF (ASSOCIATED(rtbse_env%real_workspace_mo) .AND. .NOT. rtbse_env%restart_C_written) THEN + DO i = 1, rtbse_env%n_spin + rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=c_file_labels(i), & + file_form="UNFORMATTED", file_position="REWIND") + CALL cp_fm_write_unformatted(rtbse_env%C_active(i), rho_unit_nr) + CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) + END DO + rtbse_env%restart_C_written = .TRUE. + END IF + + CALL write_restart_trace(rtbse_env) + END SUBROUTINE output_restart_linearized +! ************************************************************************************************** +!> \brief Appends the current observable-trace record to RESTART.trace. Records are keyed by the +!> observable slot n_slot = sim_step - sim_start_orig + 1 - the SAME index output_moments/ +!> output_field write (both drivers bump sim_step inside the propagation call before the +!> output calls run). On the first call of a run the file is rewritten from memory (header + +!> records 1..n_slot), truncating leftovers from an aborted run; subsequent calls append one +!> record. Ionode writes; layout matches read_restart_trace verbatim. +!> \param rtbse_env RT-BSE environment +! ************************************************************************************************** + SUBROUTINE write_restart_trace(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_logger_type), POINTER :: logger + CHARACTER(len=default_path_length) :: save_name + INTEGER :: trace_unit, n, n_eps, n_slot + + logger => cp_get_default_logger() + save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".trace", my_local=.FALSE.) + + IF (rtbse_env%unit_nr > 0) THEN + n_slot = rtbse_env%sim_step - rtbse_env%sim_start_orig + 1 + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + ! scalar row count is safe: determine_active_mo_window takes the union window across + ! spins, so eps_active is rectangular (mo_active, n_spin) by construction + n_eps = SIZE(rtbse_env%eps_active, 1) + ELSE + n_eps = 0 + END IF + IF (.NOT. rtbse_env%restart_trace_written) THEN + CALL open_file(save_name, file_status="UNKNOWN", file_form="UNFORMATTED", file_action="WRITE", & + file_position="REWIND", unit_number=trace_unit) + WRITE (trace_unit) restart_trace_version + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + WRITE (trace_unit) rtbse_env%n_spin, rtbse_env%mo_active, rtbse_env%n_ao + ELSE + WRITE (trace_unit) rtbse_env%n_spin, rtbse_env%n_ao, rtbse_env%n_ao + END IF + WRITE (trace_unit) rtbse_env%sim_dt + WRITE (trace_unit) REAL(rtbse_env%dft_control%rtp_control%delta_pulse_direction, dp), & + rtbse_env%dft_control%rtp_control%delta_pulse_scale + WRITE (trace_unit) n_eps + IF (n_eps > 0) WRITE (trace_unit) rtbse_env%eps_active + DO n = 1, n_slot + WRITE (trace_unit) n, rtbse_env%time_trace(n), rtbse_env%field_trace(:, n), & + rtbse_env%moments_trace(:, :, n) + END DO + ELSE + CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="WRITE", & + file_position="APPEND", unit_number=trace_unit) + WRITE (trace_unit) n_slot, rtbse_env%time_trace(n_slot), rtbse_env%field_trace(:, n_slot), & + rtbse_env%moments_trace(:, :, n_slot) + END IF + CALL close_file(trace_unit) + END IF + rtbse_env%restart_trace_written = .TRUE. + END SUBROUTINE write_restart_trace +! ************************************************************************************************** +!> \brief Early phase of the restart read: the starting step index from the .info file, the original +!> run's dt peeked from the RESTART.trace header (so ENFORCE_MAX_DT can inherit it), and an +!> SCF_GUESS hygiene check. Runs BEFORE initialize_maximum_timestep; the trace prefix records +!> are loaded separately by read_restart_trace once the trace arrays are sized. +!> \param rtbse_env RT-BSE environment +! ************************************************************************************************** + SUBROUTINE read_restart_info(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_logger_type), POINTER :: logger + CHARACTER(len=default_path_length) :: save_name + INTEGER :: info_unit, trace_unit, version + TYPE(scf_control_type), POINTER :: scf_control + + logger => cp_get_default_logger() + + save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".info", my_local=.FALSE.) + IF (file_exists(save_name)) THEN + CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & + unit_number=info_unit) + READ (info_unit) rtbse_env%sim_start + CALL close_file(info_unit) + IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A31,I25,A24)') " RTBSE| Starting from timestep ", & + rtbse_env%sim_start, ", delta kick NOT applied" + ELSE + CPWARN("Restart required but no info file found - starting from sim_step given in input") + END IF + + ! Peek the original run's dt from the trace header (version, dims record, dt) so ENFORCE_MAX_DT + ! can inherit it rather than recompute a window-dependent dt. The dims record is skipped here; + ! read_restart_trace re-reads the full header and validates it once the trace arrays are sized. + save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".trace", my_local=.FALSE.) + IF (file_exists(save_name)) THEN + CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & + unit_number=trace_unit) + READ (trace_unit) version + IF (version == restart_trace_version) THEN + READ (trace_unit) + READ (trace_unit) rtbse_env%sim_dt_restart + END IF + CALL close_file(trace_unit) + END IF + + ! Hygiene nudge only - correctness is protected by the restart basis bridge (linearized path) + NULLIFY (scf_control) + CALL get_qs_env(rtbse_env%qs_env, scf_control=scf_control) + IF (scf_control%density_guess /= restart_guess) THEN + CPWARN("RT_RESTART without SCF_GUESS RESTART - SCF may reconverge to a gauge-rotated MO basis.") + END IF + END SUBROUTINE read_restart_info +! ************************************************************************************************** +!> \brief Reads the RESTART.trace prefix (records 1..sim_start) into the in-memory moment/field/ +!> time traces so the continuation FT covers the full history. Header guards: version, +!> n_spin, dims, dt (abort); kick params (warn); eps_active > 0.1 meV (warn). All ranks read +!> (the traces are replicated). Record layout matches write_restart_trace verbatim. +!> \param rtbse_env RT-BSE environment +! ************************************************************************************************** + SUBROUTINE read_restart_trace(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_logger_type), POINTER :: logger + CHARACTER(len=default_path_length) :: save_name, err_msg + INTEGER :: trace_unit, version, n_spin_file, & + n_basis_file, n_ao_file, n_eps, n, & + n_read_max, ios + REAL(kind=dp) :: dt_file, kick_scale_file, t_rec + REAL(kind=dp), DIMENSION(3) :: kick_dir_file + REAL(kind=dp), DIMENSION(:, :), ALLOCATABLE :: eps_file + COMPLEX(kind=dp), DIMENSION(3) :: field_rec + COMPLEX(kind=dp), DIMENSION(:, :), ALLOCATABLE :: mom_rec + + logger => cp_get_default_logger() + save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".trace", my_local=.FALSE.) + ! No trace + real prior history: the FT would run on a zero prefix - either a guaranteed + ! multi_fft abort AFTER the full propagation (default FT%START_TIME=0, delta_t=0) or a + ! silently wrong tail-only spectrum (START_TIME>0). Fail fast instead. + IF (.NOT. file_exists(save_name)) THEN + IF (rtbse_env%sim_start > 0) THEN + CALL cp_abort(__LOCATION__, & + "RT_RESTART without RESTART.trace - the continuation FT would miss the pre-restart "// & + "history. Restore the original run's RESTART.trace next to the density restart files.") + END IF + RETURN + END IF + + CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & + unit_number=trace_unit) + READ (trace_unit) version + IF (version /= restart_trace_version) THEN + WRITE (err_msg, '(A,I0,A,I0)') "RESTART.trace: format version ", version, & + " does not match this binary's version ", restart_trace_version + CALL cp_abort(__LOCATION__, TRIM(err_msg)) + END IF + READ (trace_unit) n_spin_file, n_basis_file, n_ao_file + IF (n_spin_file /= rtbse_env%n_spin) CPABORT("RESTART.trace: n_spin mismatch") + IF (n_ao_file /= rtbse_env%n_ao) CPABORT("RESTART.trace: n_ao mismatch") + ! v1 is strict same-window: the linearized active-MO count must match (D6) + IF (ASSOCIATED(rtbse_env%real_workspace_mo) .AND. n_basis_file /= rtbse_env%mo_active) THEN + CALL cp_abort(__LOCATION__, & + "RESTART.trace: active-MO count differs from the original run - same-window continuation only") + END IF + READ (trace_unit) dt_file + ! ENFORCE_MAX_DT inherits dt_file (read_restart_info -> initialize_maximum_timestep), so this + ! fires only on the manual path (ENFORCE off + user dt /= original); name the exact fix. + IF (ABS(dt_file - rtbse_env%sim_dt) > 1.0e-12_dp*MAX(1.0_dp, ABS(rtbse_env%sim_dt))) THEN + WRITE (err_msg, '(A,ES16.9,A)') & + "RESTART.trace: TIMESTEP differs from the original run - continuation undefined. "// & + "Set MD%TIMESTEP [fs] ", dt_file*femtoseconds, & + " or enable RTBSE%ENFORCE_MAX_DT to inherit it automatically." + CALL cp_abort(__LOCATION__, TRIM(err_msg)) + END IF + READ (trace_unit) kick_dir_file, kick_scale_file + IF (MAXVAL(ABS(kick_dir_file - REAL(rtbse_env%dft_control%rtp_control%delta_pulse_direction, dp))) > 1.0e-12_dp .OR. & + ABS(kick_scale_file - rtbse_env%dft_control%rtp_control%delta_pulse_scale) > 1.0e-12_dp) THEN + CALL cp_warn(__LOCATION__, & + "RESTART.trace: delta-kick parameters differ from the original run - FT normalization inconsistent.") + END IF + READ (trace_unit) n_eps + IF (n_eps > 0) THEN + ALLOCATE (eps_file(n_eps, rtbse_env%n_spin)) + READ (trace_unit) eps_file + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + IF (n_eps /= SIZE(rtbse_env%eps_active, 1)) THEN + CALL cp_abort(__LOCATION__, "RESTART.trace: active-window size mismatch") + END IF + ! eps_active is not populated yet (built later in the Hamiltonian init); stash for the + ! post-Hamiltonian consistency check in check_restart_eps_consistency. + ALLOCATE (rtbse_env%eps_active_restart(n_eps, rtbse_env%n_spin)) + rtbse_env%eps_active_restart(:, :) = eps_file + END IF + DEALLOCATE (eps_file) + END IF + + ALLOCATE (mom_rec(rtbse_env%n_spin, 3)) + n_read_max = 0 + DO + READ (trace_unit, IOSTAT=ios) n, t_rec, field_rec, mom_rec + IF (ios /= 0) EXIT + ! Fill through slot sim_start+1: both drivers bump sim_step inside the propagation call + ! (etrs_scf_loop / solve_rk4_timestep), so the live loop's first step writes slot + ! sim_start+2 and slot sim_start+1 must be reloaded here. + IF (n > rtbse_env%sim_start + 1) EXIT + IF (n > SIZE(rtbse_env%time_trace)) THEN + CPABORT("RESTART.trace: record index exceeds trace size - increase MOTION%MD%STEPS") + END IF + rtbse_env%time_trace(n) = t_rec + rtbse_env%field_trace(:, n) = field_rec + rtbse_env%moments_trace(:, :, n) = mom_rec + n_read_max = MAX(n_read_max, n) + END DO + DEALLOCATE (mom_rec) + CALL close_file(trace_unit) + IF (n_read_max < rtbse_env%sim_start) THEN + CPWARN("RESTART.trace: fewer records than restart step - trace prefix incomplete.") + END IF + END SUBROUTINE read_restart_trace +! ************************************************************************************************** +!> \brief Compares the original run's active eigenvalues (stashed by read_restart_trace) against +!> the recomputed eps_active, once the Hamiltonian is built. Prints the max deviation and +!> warns above 0.1 meV (GW analytic continuation gives run-to-run QP noise above FP, so the +!> threshold is deliberately loose). Frees the stash. No-op if nothing was stashed. +!> \param rtbse_env RT-BSE environment +! ************************************************************************************************** + SUBROUTINE check_restart_eps_consistency(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + REAL(kind=dp) :: eps_dev + + IF (.NOT. ASSOCIATED(rtbse_env%eps_active_restart)) RETURN + + eps_dev = MAXVAL(ABS(rtbse_env%eps_active_restart - rtbse_env%eps_active)) + IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') & + " RTBSE| Restart eps_active max deviation vs original run ", eps_dev, " Ha" + ! 0.1 meV = 1.0e-4 eV, converted to Ha via evolt (Ha -> eV factor) + IF (eps_dev > 1.0e-4_dp/evolt) THEN + CALL cp_warn(__LOCATION__, & + "RESTART.trace: active eigenvalues deviate beyond 0.1 meV - "// & + "Hamiltonian changed; continuation is physically inconsistent.") + END IF + + DEALLOCATE (rtbse_env%eps_active_restart) + NULLIFY (rtbse_env%eps_active_restart) + END SUBROUTINE check_restart_eps_consistency +! ************************************************************************************************** +!> \brief Late phase of the restart read: overwrites rho from the lab-frame restart matrices and +!> sets restart_extracted. MO-active for the linearized path, AO otherwise +!> (cp_fm_read_unformatted aborts on a size mismatch, guarding a changed active window). +!> \param rtbse_env RT-BSE environment +! ************************************************************************************************** + SUBROUTINE read_restart_density(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_logger_type), POINTER :: logger + CHARACTER(len=default_path_length) :: save_name, save_name_2 + INTEGER :: rho_unit_nr, j + CHARACTER(len=17), DIMENSION(4) :: file_labels + TYPE(cp_fm_type), DIMENSION(:), POINTER :: ws + + ! This allows the delta kick and output of moment at time 0 in all cases + ! except the case when both imaginary and real parts of the density are read + rtbse_env%restart_extracted = .FALSE. + logger => cp_get_default_logger() + + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN + ws => rtbse_env%real_workspace_mo + ELSE + ws => rtbse_env%real_workspace + END IF + + ! Default labels distinguishing up to two spin species and real/imaginary parts + file_labels(1) = "_SPIN_A_RE.matrix" + file_labels(2) = "_SPIN_A_IM.matrix" + file_labels(3) = "_SPIN_B_RE.matrix" + file_labels(4) = "_SPIN_B_IM.matrix" + DO j = 1, rtbse_env%n_spin + save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, & + extension=file_labels(2*j - 1), my_local=.FALSE.) + save_name_2 = cp_print_key_generate_filename(logger, rtbse_env%restart_section, & + extension=file_labels(2*j), my_local=.FALSE.) + IF (file_exists(save_name) .AND. file_exists(save_name_2)) THEN + CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & + unit_number=rho_unit_nr) + CALL cp_fm_read_unformatted(ws(1), rho_unit_nr) + CALL close_file(rho_unit_nr) + CALL open_file(save_name_2, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & + unit_number=rho_unit_nr) + CALL cp_fm_read_unformatted(ws(2), rho_unit_nr) + CALL close_file(rho_unit_nr) + CALL cp_fm_to_cfm(ws(1), ws(2), & + rtbse_env%rho(j)) + rtbse_env%restart_extracted = .TRUE. + ELSE + CPWARN("Restart without some restart matrices - starting from SCF density.") + END IF + END DO + END SUBROUTINE read_restart_density +! ************************************************************************************************** +!> \brief Reads the previous run's C_active slabs (gauge reference for the restart basis bridge). +!> \param rtbse_env RT-BSE environment +!> \param C_old Caller-created fm array (n_spin) on fm_struct_ao_mo_active, filled on success +!> \param found .TRUE. iff all per-spin C files were present and read +! ************************************************************************************************** + SUBROUTINE read_restart_C(rtbse_env, C_old, found) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_fm_type), DIMENSION(:), POINTER :: C_old + LOGICAL, INTENT(OUT) :: found + TYPE(cp_logger_type), POINTER :: logger + CHARACTER(len=default_path_length) :: save_name + CHARACTER(len=16), DIMENSION(2) :: c_file_labels + INTEGER :: c_unit, j + + c_file_labels(1) = "_SPIN_A_C.matrix" + c_file_labels(2) = "_SPIN_B_C.matrix" + logger => cp_get_default_logger() + found = .FALSE. + DO j = 1, rtbse_env%n_spin + save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, & + extension=c_file_labels(j), my_local=.FALSE.) + IF (.NOT. file_exists(save_name)) THEN + CPWARN("Restart without C_active file - assuming identical MO gauge (no basis bridge).") + RETURN + END IF + CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & + unit_number=c_unit) + CALL cp_fm_read_unformatted(C_old(j), c_unit) + CALL close_file(c_unit) + END DO + found = .TRUE. + END SUBROUTINE read_restart_C END MODULE rt_bse_io diff --git a/src/emd/rt_bse_linearized.F b/src/emd/rt_bse_linearized.F new file mode 100644 index 0000000000..b4fc0d46b6 --- /dev/null +++ b/src/emd/rt_bse_linearized.F @@ -0,0 +1,2841 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Routines for the propagation of the linearized RT-BSE equations of motion. +!> Propagates the first-order density matrix response Δρ within the active MO window, +!> in the Tamm-Dancoff approximation or with the full (A, B) coupling, instead of the +!> lesser Green's function propagated by rt_bse. Also provides the Liouvillian eigenvalue +!> diagnostic, which builds the Liouvillian by probing the kernel with canonical basis +!> vectors and diagonalizes it. +!> \note The control is handed directly from cp2k_runs +!> The initialization and delta-kick routines are adapted from the full RT-BSE +!> propagator in rt_bse.F. +!> \author Maximilian Graml (03.26) +!> \author Stepan Marek (09.24) - original RT-BSE routines adapted here +! ************************************************************************************************** + +MODULE rt_bse_linearized + USE cp_cfm_basic_linalg, ONLY: cp_cfm_gemm,& + cp_cfm_norm,& + cp_cfm_scale,& + cp_cfm_scale_and_add,& + cp_cfm_transpose + USE cp_cfm_diag, ONLY: cp_cfm_heevd + USE cp_cfm_types, ONLY: & + cp_cfm_get_info, cp_cfm_get_submatrix, cp_cfm_set_all, cp_cfm_set_element, & + cp_cfm_set_submatrix, cp_cfm_to_cfm, cp_cfm_to_fm, cp_cfm_type, cp_fm_to_cfm + USE cp_dbcsr_api, ONLY: dbcsr_add,& + dbcsr_copy,& + dbcsr_get_info,& + dbcsr_p_type,& + dbcsr_release,& + dbcsr_set + USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& + copy_fm_to_dbcsr + USE cp_fm_basic_linalg, ONLY: cp_fm_scale,& + cp_fm_scale_and_add,& + cp_fm_transpose + USE cp_fm_types, ONLY: cp_fm_create,& + cp_fm_get_diag,& + cp_fm_get_info,& + cp_fm_release,& + cp_fm_set_all,& + cp_fm_to_fm_submat_general,& + cp_fm_type + USE cp_log_handling, ONLY: cp_get_default_logger,& + cp_logger_type + USE cp_output_handling, ONLY: cp_add_iter_level,& + cp_iterate,& + cp_print_key_finished_output,& + cp_print_key_unit_nr,& + cp_rm_iter_level + USE dbt_api, ONLY: dbt_copy_matrix_to_tensor + USE force_env_methods, ONLY: force_env_calc_energy_force + USE force_env_types, ONLY: force_env_type + USE input_constants, ONLY: rtp_bse_ham_g0w0,& + use_mom_ref_zero,& + use_rt_restart + USE kinds, ONLY: dp + USE machine, ONLY: m_walltime + USE mathconstants, ONLY: twopi + USE moments_utils, ONLY: get_reference_point + USE parallel_gemm_api, ONLY: parallel_gemm + USE physcon, ONLY: evolt,& + seconds + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE qs_environment_types, ONLY: get_qs_env + USE qs_moments, ONLY: build_local_moment_matrix + USE rpa_gw_kpoints_util, ONLY: cp_cfm_power + USE rt_bse, ONLY: get_hartree,& + get_sigma,& + init_hartree,& + initialize_rtbse_env,& + propagate_density,& + rho_metric + USE rt_bse_io, ONLY: & + check_restart_eps_consistency, output_field, output_moments, output_mos_contravariant, & + output_restart_linearized, print_timestep_info, read_restart_C, read_restart_density, & + read_restart_info, read_restart_trace + USE rt_bse_ri_rs, ONLY: compute_hartree_ri_rs,& + compute_hartree_ri_rs_complex,& + compute_hartree_ri_rs_from_diag,& + rt_bse_ri_rs_ensure_V_grid,& + rt_bse_ri_rs_ensure_W0_grid + USE rt_bse_types, ONLY: create_rtbse_env,& + release_rtbse_env,& + rtbse_env_type + USE rt_propagation_output, ONLY: print_ft +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rt_bse_linearized' + + ! build_shared_sex_and_hartree input-convention selector. The mask choice also fixes the input + ! Hermiticity, which gates the Hartree imaginary channel (Im computed iff non-Hermitian = OV only). + INTEGER, PARAMETER, PRIVATE :: kernel_input_ov = 1, kernel_input_ovvo = 2, kernel_input_full = 3 + + PUBLIC :: run_propagation_linearized_bse + +CONTAINS + +! ************************************************************************************************** +!> \brief Runs the electron-only real time propagation of the linearized BSE +!> \param force_env Force environment data, entry point of the calculation +! ************************************************************************************************** + SUBROUTINE run_propagation_linearized_bse(force_env) + TYPE(force_env_type), POINTER :: force_env + + CHARACTER(len=*), PARAMETER :: routineN = 'run_propagation_linearized_bse' + + INTEGER :: handle, i, j + REAL(kind=dp) :: t_phys, t_start, timestep_walltime, & + timestep_walltime_start + REAL(kind=dp), DIMENSION(2) :: enum_im, enum_re + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_lab + TYPE(cp_logger_type), POINTER :: logger + TYPE(rtbse_env_type), POINTER :: rtbse_env + + ! Per-spin (alpha/beta) electron numbers; only 1:n_spin entries are used. + + CALL timeset(routineN, handle) + + CALL cp_warn(__LOCATION__, & + "Linearized RT-BSE is under active development. Make sure you understand "// & + "the method and validate results before using it for production calculations.") + + ! To Do: Bibliography information + + logger => cp_get_default_logger() + + ! Run the initial SCF calculation / read SCF restart information + CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., consistent_energies=.FALSE.) + + ! Allocate all persistant storage and read input that does not need further processing + CALL create_rtbse_env(rtbse_env, force_env, linearized=.TRUE.) + + ! Restart phase 1a: read sim_start + the original run's dt (from the trace header) BEFORE + ! ENFORCE_MAX_DT, so the continuation inherits that dt instead of a window-dependent one. + IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart) THEN + CALL read_restart_info(rtbse_env) + END IF + + CALL initialize_maximum_timestep(rtbse_env) + + ! Restart phase 1b: load the trace prefix now that ENFORCE_MAX_DT has sized the trace arrays. + IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart) THEN + IF (rtbse_env%sim_start >= rtbse_env%sim_nsteps) THEN + CPABORT("RT_RESTART: restart step >= STEPS - increase MOTION%MD%STEPS") + END IF + CALL read_restart_trace(rtbse_env) + END IF + + CALL print_linrtbse_header_info(rtbse_env) + + ! Build the truncated MO coefficient slabs C_active(:, first_active_mo..last_active_mo) + ! used by all AO<->MO transforms in the linearized path. + CALL populate_C_active(rtbse_env) + + ! Initiate iteration level "MD" in order to copy the structure of other RTP codes + CALL cp_add_iter_level(logger%iter_info, "MD") + ! Initialize non-trivial values + ! - calculates the moment operators + CALL initialize_moments(rtbse_env) + ! - populates overlap and inverse overlap matrices + CALL initialize_rtbse_env(rtbse_env) + + ! - populates the fresh SCF density matrix rho^0 (and the rho_orig reference for delta rho) + CALL initialize_density_matrix(rtbse_env) + + ! Restart phase 2: overwrite rho from the lab-frame restart files, bridge into this run's MO + ! gauge, then enter this run's rotating frame (rotate_rho_phase is a no-op when omega_shift=0) + IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart) THEN + CALL read_restart_density(rtbse_env) + IF (rtbse_env%restart_extracted) THEN + CALL apply_restart_basis_bridge(rtbse_env) + t_start = REAL(rtbse_env%sim_start, dp)*rtbse_env%sim_dt + DO i = 1, rtbse_env%n_spin + CALL rotate_rho_phase(rtbse_env, rtbse_env%rho(i), i, -rtbse_env%omega_shift*t_start) + END DO + END IF + END IF + ! - calculates/populates the G0W0/KS Hamiltonian, respectively + CALL initialize_singleparticle_hamiltonian(rtbse_env) + ! Restart Hamiltonian-consistency heads-up: eps_active exists only now, so compare here + CALL check_restart_eps_consistency(rtbse_env) + ! Transform initial density matrix to AO basis for use in Hartree and self-energy calculations + DO i = 1, rtbse_env%n_spin + CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%rho_orig(i), rtbse_env%rho_ao_scratch(i), i) + END DO + ! - calculates the Hartree reference potential + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_set_all(rtbse_env%ham_reference(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + CALL initialize_hartree_potential(rtbse_env) + ! - calculates the SEX reference self-energy + CALL initialize_sex_selfenergy(rtbse_env) + + ! Liouvillian eigenvalue diagnostic (one-shot at init, TDA or ABBA via dispatcher). + ! Detached from the propagator; safe to call after the reference-init routines. + IF (rtbse_env%diagnose_liouvillian_eig) THEN + CALL diagnose_liouvillian_eigenvalues(rtbse_env) + END IF + + ! Setup the time based on the starting step + ! Assumes identical dt between two runs + rtbse_env%sim_time = REAL(rtbse_env%sim_start, dp)*rtbse_env%sim_dt + NULLIFY (rho_lab) + ! Output 0 time moments and field + IF (.NOT. rtbse_env%restart_extracted) THEN + CALL output_field(rtbse_env) + CALL build_rho_lab(rtbse_env, rtbse_env%rho, rtbse_env%sim_time, rho_lab) + CALL output_moments(rtbse_env, rho_lab) + END IF + + ! Do not apply the delta kick if we are doing a restart calculation + IF (rtbse_env%dft_control%rtp_control%apply_delta_pulse .AND. (.NOT. rtbse_env%restart_extracted)) THEN + CALL apply_delta_pulse_MO(rtbse_env) + END IF + + ! ********************** Start the time loop ********************** + ! NOTE : Time-loop starts at index sim_start = 0, unless restarted or configured otherwise + DO i = rtbse_env%sim_start, rtbse_env%sim_nsteps - 1 + timestep_walltime_start = m_walltime() + + ! Update the simulation time + rtbse_env%sim_time = REAL(i, dp)*rtbse_env%sim_dt + rtbse_env%sim_step = i + + CALL solve_rk4_timestep(rtbse_env, rtbse_env%rho, rtbse_env%rho_new) + CALL get_electron_number_MO(rtbse_env, rtbse_env%rho_new, & + enum_re(1:rtbse_env%n_spin), enum_im(1:rtbse_env%n_spin)) + timestep_walltime = m_walltime() - timestep_walltime_start + CALL print_timestep_info(rtbse_env, i, enum_re(1:rtbse_env%n_spin), step_walltime=timestep_walltime) + CALL cp_iterate(logger%iter_info, iter_nr=i, last=(i == rtbse_env%sim_nsteps - 1)) + + ! Update rho + DO j = 1, rtbse_env%n_spin + CALL cp_cfm_to_cfm(rtbse_env%rho_new(j), rtbse_env%rho(j)) + END DO + ! Print the updated field + CALL output_field(rtbse_env) + ! rho is the rotating-frame density at physical time t_phys = (i+1)*dt. + ! Build a lab-frame copy once and feed it to all observable/restart sinks. + t_phys = REAL(i + 1, dp)*rtbse_env%sim_dt + CALL build_rho_lab(rtbse_env, rtbse_env%rho, t_phys, rho_lab) + ! If needed, print out the density matrix in MO basis + CALL output_mos_contravariant(rtbse_env, rho_lab, rtbse_env%rho_section) + ! Also handles outputting to memory + CALL output_moments(rtbse_env, rho_lab) + ! Output restart files, so that the restart resumes at the step recorded in .info + CALL output_restart_linearized(rtbse_env, rho_lab) + END DO + ! ********************** End the time loop ********************** + + CALL cp_rm_iter_level(logger%iter_info, "MD") + + ! Carry out the FT + CALL print_ft(rtbse_env%rtp_section, & + rtbse_env%moments_trace, & + rtbse_env%time_trace, & + rtbse_env%field_trace, & + rtbse_env%dft_control%rtp_control, & + info_opt=rtbse_env%unit_nr) + + ! Deallocate everything + CALL release_rtbse_env(rtbse_env) + + CALL timestop(handle) + END SUBROUTINE run_propagation_linearized_bse + +! ************************************************************************************************** +!> \brief Computes the analytic RK4 stability bound t* = 2√2 / Ω_max (a.u.) from the largest active +!> GW/KS gap, and (TDA + first-peak) the rotating-frame shift Ω_0 = ε^ai_min. +!> Writes the timestep diagnostics to stdout; optionally rewrites TIMESTEP/STEPS under +!> ENFORCE_MAX_DT; on restart it inherits the original dt from the trace and only rescales STEPS. +!> \param rtbse_env Entry point - rtbse environment +! ************************************************************************************************** + SUBROUTINE initialize_maximum_timestep(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'initialize_maximum_timestep' + + CHARACTER(len=256) :: hint_msg + INTEGER :: handle, i_first, i_last, ispin, & + n_steps_new, n_steps_old + REAL(kind=dp) :: eps_max_ai, eps_min_ai, eps_occ_max, eps_occ_min, eps_virt_max, & + eps_virt_min, ev_tmp, grace_factor, omega_max, sim_dt_as, total_time + + CALL timeset(routineN, handle) + + i_first = rtbse_env%first_active_mo + i_last = rtbse_env%last_active_mo + + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + omega_max = MAXVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:i_last, :, :)) - & + MINVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:i_last, :, :)) + ELSE + omega_max = MAXVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:i_last, :)) - & + MINVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:i_last, :)) + END IF + + ! First-peak shift (TDA only): set Ω_0 = eps_min_ai so the lowest + ! active OV mode oscillates at zero frequency in the rotating frame + ! (RK4-exact for peak 1). omega_max is the full active OV width + ! Delta = eps_max_ai - eps_min_ai, where eps_ai = eps_a - eps_i runs + ! over the active OV pairs only (i in active occupied, a in active + ! virtual). + rtbse_env%omega_shift = 0.0_dp + IF (rtbse_env%tda_active .AND. rtbse_env%tda_shift_to_first_peak) THEN + eps_occ_min = HUGE(0.0_dp) + eps_occ_max = -HUGE(0.0_dp) + eps_virt_min = HUGE(0.0_dp) + eps_virt_max = -HUGE(0.0_dp) + DO ispin = 1, rtbse_env%n_spin + ! Active occupied window: first_active_mo .. n_occ(ispin) + IF (rtbse_env%n_occ(ispin) >= i_first) THEN + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:rtbse_env%n_occ(ispin), :, ispin)) + eps_occ_min = MIN(eps_occ_min, ev_tmp) + ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:rtbse_env%n_occ(ispin), :, ispin)) + eps_occ_max = MAX(eps_occ_max, ev_tmp) + ELSE + ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:rtbse_env%n_occ(ispin), ispin)) + eps_occ_min = MIN(eps_occ_min, ev_tmp) + ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:rtbse_env%n_occ(ispin), ispin)) + eps_occ_max = MAX(eps_occ_max, ev_tmp) + END IF + END IF + ! Active virtual window: n_occ(ispin)+1 .. last_active_mo + IF (rtbse_env%n_occ(ispin) < i_last) THEN + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin) + 1:i_last, :, ispin)) + eps_virt_min = MIN(eps_virt_min, ev_tmp) + ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin) + 1:i_last, :, ispin)) + eps_virt_max = MAX(eps_virt_max, ev_tmp) + ELSE + ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin) + 1:i_last, ispin)) + eps_virt_min = MIN(eps_virt_min, ev_tmp) + ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin) + 1:i_last, ispin)) + eps_virt_max = MAX(eps_virt_max, ev_tmp) + END IF + END IF + END DO + + IF (eps_occ_max > -HUGE(0.0_dp) .AND. eps_virt_min < HUGE(0.0_dp)) THEN + eps_min_ai = eps_virt_min - eps_occ_max + eps_max_ai = eps_virt_max - eps_occ_min + rtbse_env%omega_shift = eps_min_ai + omega_max = eps_max_ai - eps_min_ai + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A)') & + " RTBSE| ---------- First-peak shift diagnostics (TDA, active OV pairs) ----------" + WRITE (rtbse_env%unit_nr, '(A,F14.6,A,F14.6)') & + " RTBSE| eps_occ [eV] min / max =", eps_occ_min*evolt, & + " /", eps_occ_max*evolt + WRITE (rtbse_env%unit_nr, '(A,F14.6,A,F14.6)') & + " RTBSE| eps_virt [eV] min / max =", eps_virt_min*evolt, & + " /", eps_virt_max*evolt + WRITE (rtbse_env%unit_nr, '(A,F14.6,A,F14.6)') & + " RTBSE| eps_ai [eV] min / max =", eps_min_ai*evolt, & + " /", eps_max_ai*evolt + WRITE (rtbse_env%unit_nr, '(A,F14.6)') & + " RTBSE| omega_shift [eV] =", rtbse_env%omega_shift*evolt + WRITE (rtbse_env%unit_nr, '(A,F14.6)') & + " RTBSE| omega_max [eV] (full) =", omega_max*evolt + WRITE (rtbse_env%unit_nr, '(A)') & + " RTBSE| ------------------------------------------------------------------------" + END IF + ELSE + ! Active window has no genuine OV pair - fall back to no shift + rtbse_env%omega_shift = 0.0_dp + rtbse_env%tda_shift_to_first_peak = .FALSE. + END IF + END IF + + rtbse_env%omega_max = omega_max + + IF (omega_max > 0.0_dp) THEN + ! t* = 2√2 / Ω_max (a.u.; imaginary-axis RK4 bound |R(iy)| ≤ 1 at y = 2√2) + rtbse_env%maximum_timestep = 2.0_dp*SQRT(2.0_dp)/omega_max + ELSE + CALL cp_abort(__LOCATION__, & + "Error in estimating maximum timestep: largest KS/GW gap is "// & + "non-positive. Check the active MO window (cutoffs) and the "// & + "eigenvalues.") + END IF + + IF (rtbse_env%sim_dt <= 0.0_dp) THEN + CALL cp_abort(__LOCATION__, & + "TIMESTEP must be positive for linearized RT-BSE. Use RTBSE%ENFORCE_MAX_DT "// & + "with a positive TIMESTEP to automatically rewrite TIMESTEP and STEPS.") + END IF + + n_steps_old = MAX(0, rtbse_env%sim_nsteps) + + IF (rtbse_env%enforce_max_dt) THEN + total_time = REAL(n_steps_old, dp)*rtbse_env%sim_dt + ! Full code needs a grace factor of 4 + IF (rtbse_env%tda_active) THEN + grace_factor = 1.0_dp + ELSE + grace_factor = 4.0_dp + END IF + IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart .AND. & + rtbse_env%sim_dt_restart > 0.0_dp) THEN + ! Continuation: dt is frozen in the trace, so inherit it and only rescale the step count + ! to the requested window. Recomputing dt from the (longer) window would desync the trace + ! time-grid and trip the continuation guard in read_restart_trace. + rtbse_env%sim_dt = rtbse_env%sim_dt_restart + n_steps_new = MAX(1, NINT(total_time/rtbse_env%sim_dt)) + rtbse_env%sim_nsteps = n_steps_new + sim_dt_as = rtbse_env%sim_dt*seconds*1e18_dp + WRITE (hint_msg, '(A,F16.4,A,I0,A)') & + 'ENFORCE_MAX_DT on restart: inheriting original TIMESTEP ', sim_dt_as, & + ' as and setting STEPS to ', n_steps_new, '.' + CALL cp_hint(__LOCATION__, TRIM(hint_msg)) + ! The inherited dt was stable in the original run; warn only if this run's stability + ! window shrank below it (e.g. the recomputed GW eigenvalues shifted the gap). + IF (rtbse_env%sim_dt > rtbse_env%maximum_timestep/grace_factor) THEN + CALL cp_warn(__LOCATION__, & + "ENFORCE_MAX_DT restart: inherited dt exceeds this run's stability "// & + "limit - the recomputed Hamiltonian may make the propagation unstable.") + END IF + ELSE + n_steps_new = MAX(1, CEILING(total_time/(rtbse_env%maximum_timestep/grace_factor))) + rtbse_env%sim_dt = total_time/REAL(n_steps_new, dp) + rtbse_env%sim_nsteps = n_steps_new + sim_dt_as = rtbse_env%sim_dt*seconds*1e18_dp + WRITE (hint_msg, '(A,F16.4,A,I0,A)') & + 'ENFORCE_MAX_DT enabled. Resetting TIMESTEP to ', sim_dt_as, & + ' as and STEPS to ', n_steps_new, '.' + CALL cp_hint(__LOCATION__, TRIM(hint_msg)) + END IF + END IF + + IF (rtbse_env%sim_nsteps /= n_steps_old) THEN + CALL reallocate_ft_traces(rtbse_env) + END IF + + CALL timestop(handle) + END SUBROUTINE initialize_maximum_timestep + +! ************************************************************************************************** +!> \brief Reallocate FT trace buffers after ENFORCE_MAX_DT rewrites the step count. +!> \param rtbse_env Entry point - rtbse environment +! ************************************************************************************************** + SUBROUTINE reallocate_ft_traces(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'reallocate_ft_traces' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + IF (ASSOCIATED(rtbse_env%moments_trace)) DEALLOCATE (rtbse_env%moments_trace) + IF (ASSOCIATED(rtbse_env%field_trace)) DEALLOCATE (rtbse_env%field_trace) + IF (ASSOCIATED(rtbse_env%time_trace)) DEALLOCATE (rtbse_env%time_trace) + + ALLOCATE (rtbse_env%moments_trace(rtbse_env%n_spin, 3, rtbse_env%sim_nsteps + 1), & + source=CMPLX(0.0_dp, 0.0_dp, kind=dp)) + ALLOCATE (rtbse_env%field_trace(3, rtbse_env%sim_nsteps + 1), & + source=CMPLX(0.0_dp, 0.0_dp, kind=dp)) + ALLOCATE (rtbse_env%time_trace(rtbse_env%sim_nsteps + 1), source=0.0_dp) + + CALL timestop(handle) + END SUBROUTINE reallocate_ft_traces + +! ************************************************************************************************** +!> \brief Prints the linRTBSE run header to stdout: active-MO window (first/last/count) and the +!> occupied/virtual energy cutoffs. +!> \param rtbse_env Entry point - rtbse environment +! ************************************************************************************************** + SUBROUTINE print_linrtbse_header_info(rtbse_env) + TYPE(rtbse_env_type) :: rtbse_env + + INTEGER :: ispin, n_steps + REAL(kind=dp) :: e_first, e_last, fft_resolution, & + nyquist_frequency, total_time + TYPE(cp_logger_type), POINTER :: logger + + logger => cp_get_default_logger() + n_steps = MAX(0, rtbse_env%sim_nsteps) + total_time = REAL(n_steps, dp)*rtbse_env%sim_dt + fft_resolution = 0.0_dp + nyquist_frequency = 0.0_dp + IF (total_time > 0.0_dp) fft_resolution = twopi/total_time + IF (rtbse_env%sim_dt > 0.0_dp) nyquist_frequency = twopi/(2.0_dp*rtbse_env%sim_dt) + + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, *) '' + WRITE (rtbse_env%unit_nr, '(A)') ' /-----------------------------------------------'// & + '------------------------------\' + WRITE (rtbse_env%unit_nr, '(A)') ' | '// & + ' |' + WRITE (rtbse_env%unit_nr, '(A)') ' | Linearized Real Time Bethe-Salpeter Propagation'// & + ' |' + WRITE (rtbse_env%unit_nr, '(A)') ' | '// & + ' |' + WRITE (rtbse_env%unit_nr, '(A)') ' \-----------------------------------------------'// & + '------------------------------/' + WRITE (rtbse_env%unit_nr, *) '' + + WRITE (rtbse_env%unit_nr, '(A18,L62)') ' Apply delta pulse', & + rtbse_env%dft_control%rtp_control%apply_delta_pulse + WRITE (rtbse_env%unit_nr, '(A)') '' + WRITE (rtbse_env%unit_nr, '(A18,L62)') ' Use Tamm-Dancoff approximation', & + rtbse_env%tda_active + IF (rtbse_env%tda_active) THEN + WRITE (rtbse_env%unit_nr, '(A,T71,L10)') ' TDA first-peak shift active', & + rtbse_env%tda_shift_to_first_peak + IF (rtbse_env%tda_shift_to_first_peak) THEN + WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' TDA first-peak shift Omega_0 [eV]:', & + rtbse_env%omega_shift*evolt + END IF + END IF + + WRITE (rtbse_env%unit_nr, '(A)') '' + + WRITE (rtbse_env%unit_nr, '(A,T65,F16.4)') ' Estimated maximum timestep within stability region [as]:', & + rtbse_env%maximum_timestep*seconds*1e18_dp + WRITE (rtbse_env%unit_nr, '(A,T65,F16.4)') ' Applied timestep [as]:', & + rtbse_env%sim_dt*seconds*1e18_dp + WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' Number of propagation steps:', n_steps + WRITE (rtbse_env%unit_nr, '(A,T65,F16.4)') ' Total propagation time [as]:', & + total_time*seconds*1e18_dp + WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' Estimated FFT frequency resolution without interpolation [eV]:', & + fft_resolution*evolt + WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' Nyquist frequency [eV]:', & + nyquist_frequency*evolt + WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' Estimated maximum oscillation frequency (gap-based) [eV]:', & + rtbse_env%omega_max*evolt + + ! Active MO window (energy-cutoff truncation) for linearized RT-BSE + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + WRITE (rtbse_env%unit_nr, '(A,T75,A6)') ' Active-window single-particle spectrum source:', ' G0W0' + ELSE + WRITE (rtbse_env%unit_nr, '(A,T75,A6)') ' Active-window single-particle spectrum source:', ' KS' + END IF + IF (rtbse_env%rtbse_energy_cutoff_occ > 0.0_dp) THEN + WRITE (rtbse_env%unit_nr, '(A,T71,F10.3)') ' Active-window occupied energy cutoff [eV]:', & + rtbse_env%rtbse_energy_cutoff_occ*evolt + ELSE + WRITE (rtbse_env%unit_nr, '(A,T71,A10)') ' Active-window occupied energy cutoff [eV]:', ' disabled' + END IF + IF (rtbse_env%rtbse_energy_cutoff_empty > 0.0_dp) THEN + WRITE (rtbse_env%unit_nr, '(A,T71,F10.3)') ' Active-window virtual energy cutoff [eV]:', & + rtbse_env%rtbse_energy_cutoff_empty*evolt + ELSE + WRITE (rtbse_env%unit_nr, '(A,T71,A10)') ' Active-window virtual energy cutoff [eV]:', ' disabled' + END IF + WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' First active occupied MO index:', rtbse_env%first_active_mo + WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' Last active virtual MO index:', rtbse_env%last_active_mo + WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' Number of active MOs:', rtbse_env%mo_active + IF (rtbse_env%active_mo_truncation) THEN + ! The window is cut on the DFT axis but propagated on the QP axis, so the QP edges may + ! exceed the nominal cutoff. Print both so the window can be checked against the input. + DO ispin = 1, rtbse_env%n_spin + e_first = (rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%first_active_mo, ispin) - & + rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin), ispin))*evolt + e_last = (rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%last_active_mo, ispin) - & + rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin) + 1, ispin))*evolt + WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & + ' first active MO, E - E_HOMO (KS) [eV]:', e_first + WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & + ' last active MO, E - E_LUMO (KS) [eV]:', e_last + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + e_first = (rtbse_env%bs_env%eigenval_G0W0(rtbse_env%first_active_mo, 1, ispin) - & + rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin), 1, ispin))*evolt + e_last = (rtbse_env%bs_env%eigenval_G0W0(rtbse_env%last_active_mo, 1, ispin) - & + rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin) + 1, 1, ispin))*evolt + WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & + ' first active MO, E - E_HOMO (QP) [eV]:', e_first + WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & + ' last active MO, E - E_LUMO (QP) [eV]:', e_last + END IF + END DO + END IF + END IF + + END SUBROUTINE print_linrtbse_header_info + +! ************************************************************************************************** +!> \brief Populates rtbse_env%C_active(i_spin) (n_ao x mo_active) by extracting columns +!> first_active_mo..last_active_mo from bs_env%fm_mo_coeff_Gamma(i_spin). +!> \param rtbse_env RT-BSE environment +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** + SUBROUTINE populate_C_active(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'populate_C_active' + + INTEGER :: handle, i + + CALL timeset(routineN, handle) + + DO i = 1, rtbse_env%n_spin + CALL cp_fm_set_all(rtbse_env%C_active(i), 0.0_dp) + CALL cp_fm_to_fm_submat_general( & + rtbse_env%bs_env%fm_mo_coeff_Gamma(i), rtbse_env%C_active(i), & + rtbse_env%n_ao, rtbse_env%mo_active, & + 1, rtbse_env%first_active_mo, & + 1, 1, & + rtbse_env%bs_env%fm_mo_coeff_Gamma(i)%matrix_struct%context) + END DO + + CALL timestop(handle) + END SUBROUTINE populate_C_active + +! ************************************************************************************************** +!> \brief Builds the dipole moment operators r_mn in the active-MO basis (per axis, per spin) from +!> the AO moment matrices: moments(k,σ) at the reference point, moments_field(k,σ) at origin. +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_moments(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'initialize_moments' + + INTEGER :: handle, i_spin, k + REAL(kind=dp), DIMENSION(3) :: rpoint + TYPE(cp_fm_type) :: tmp_ao + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, moments_dbcsr_p + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env, matrix_s=matrix_s) + + ! AO-sized scratch buffer for moment matrices before transform to MO basis + CALL cp_fm_create(tmp_ao, bs_env%fm_s_Gamma%matrix_struct) + + ! ****** START MOMENTS OPERATOR CALCULATION + ! Construct moments from dbcsr + NULLIFY (moments_dbcsr_p) + ALLOCATE (moments_dbcsr_p(3)) + DO k = 1, 3 + ! Make sure the pointer is empty + NULLIFY (moments_dbcsr_p(k)%matrix) + ! Allocate a new matrix that the pointer points to + ALLOCATE (moments_dbcsr_p(k)%matrix) + ! Create the matrix storage - matrix copies the structure of overlap matrix + CALL dbcsr_copy(moments_dbcsr_p(k)%matrix, matrix_s(1)%matrix) + END DO + ! Run the moment calculation + ! check for presence to prevent memory errors + rpoint(:) = 0.0_dp + CALL get_reference_point(rpoint, qs_env=rtbse_env%qs_env, & + reference=rtbse_env%moment_ref_type, ref_point=rtbse_env%user_moment_ref_point) + CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) + ! Copy to AO scratch then transform to MO-active + DO k = 1, 3 + CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, tmp_ao) + DO i_spin = 1, rtbse_env%n_spin + CALL transform_ao_to_mo_covariant_fm(rtbse_env, tmp_ao, rtbse_env%moments(k, i_spin), i_spin) + END DO + END DO + ! TODO: remove moments_field (only needed for the TDDFT comparison) + ! Now, repeat without reference point to get the moments for field + CALL get_reference_point(rpoint, qs_env=rtbse_env%qs_env, & + reference=use_mom_ref_zero) + CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) + DO k = 1, 3 + CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, tmp_ao) + DO i_spin = 1, rtbse_env%n_spin + CALL transform_ao_to_mo_covariant_fm(rtbse_env, tmp_ao, rtbse_env%moments_field(k, i_spin), i_spin) + END DO + END DO + + ! Now can deallocate dbcsr matrices + DO k = 1, 3 + CALL dbcsr_release(moments_dbcsr_p(k)%matrix) + DEALLOCATE (moments_dbcsr_p(k)%matrix) + END DO + DEALLOCATE (moments_dbcsr_p) + CALL cp_fm_release(tmp_ao) + ! ****** END MOMENTS OPERATOR CALCULATION + + CALL timestop(handle) + END SUBROUTINE initialize_moments + +! ************************************************************************************************** +!> \brief Initial MO density ρ^0_mn = f_m δ_mn (f_m = 1 on active occupied, 0 on virtual), copied to +!> rho_orig as the reference for the δ-kick. Imaginary part zero. +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - adapted to the linearized active-MO path +! ************************************************************************************************** + SUBROUTINE initialize_density_matrix(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'initialize_density_matrix' + + INTEGER :: handle, i, i_row_global, ii, & + j_col_global, jj, ncol_global, & + ncol_local, nrow_global, nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + + CALL timeset(routineN, handle) + + ! Get distribution of MO-active workspace + CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & + nrow_global=nrow_global, ncol_global=ncol_global, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + + ! Iterate over both spins + DO i = 1, rtbse_env%n_spin + !Ensure that workspace is set to 0 + CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) + DO ii = 1, nrow_local + i_row_global = row_indices(ii) + DO jj = 1, ncol_local + j_col_global = col_indices(jj) + IF (i_row_global == j_col_global .AND. & + (i_row_global + rtbse_env%first_active_mo - 1) <= rtbse_env%n_occ(i)) THEN + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = 1.0_dp + END IF + END DO + END DO + ! Sets imaginary part to zero + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%rho(i)) + ! Save the reference value for the case of delta kick + CALL cp_cfm_to_cfm(rtbse_env%rho(i), rtbse_env%rho_orig(i)) + END DO + ! rho_orig stays the SCF reference for delta rho; a restart overwrites only rho, downstream in + ! the driver (read_restart_density + apply_restart_basis_bridge + rotate_rho_phase). + + CALL timestop(handle) + END SUBROUTINE initialize_density_matrix + +! ************************************************************************************************** +!> \brief Single-particle reference Hamiltonian in the active-MO basis: H^0_mn = ε^GW_m δ_mn (or KS +!> ε^scf), diagonal. TDA first-peak adds +Ω_0/2 on occupied, -Ω_0/2 on virtual diagonals. +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation +! ************************************************************************************************** + SUBROUTINE initialize_singleparticle_hamiltonian(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'initialize_singleparticle_hamiltonian' + + INTEGER :: abs_mo_idx, handle, i, i_row_global, ii, & + j_col_global, jj, ncol_global, & + ncol_local, nrow_global, nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + + ! Get distribution of MO-active workspace + CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & + nrow_global=nrow_global, ncol_global=ncol_global, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + + !Ensure that workspace is set to 0 + CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) + rtbse_env%eps_active(:, :) = 0.0_dp + ! ****** START SINGLE PARTICLE HAMILTONIAN CALCULATION + DO i = 1, rtbse_env%n_spin + DO ii = 1, nrow_local + i_row_global = row_indices(ii) + DO jj = 1, ncol_local + j_col_global = col_indices(jj) + IF (i_row_global == j_col_global) THEN + abs_mo_idx = i_row_global + rtbse_env%first_active_mo - 1 + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ! G0W0 Hamiltonian + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = bs_env%eigenval_G0W0(abs_mo_idx, 1, i) + ELSE + ! KS Hamiltonian + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = bs_env%eigenval_scf_Gamma(abs_mo_idx, i) + END IF + ! First-peak shift (TDA only): rotate the single-particle Hamiltonian + ! into a frame where the lowest active OV mode oscillates at zero, with + ! Ω_0 = eps_min_ai. Adds +Ω_0/2 on active occupied diagonals and + ! -Ω_0/2 on active virtual diagonals so that [h', rho]_OV picks up an + ! overall (- eps_ai + Ω_0) and OO/VV blocks remain commutator-free. + IF (rtbse_env%tda_active .AND. rtbse_env%tda_shift_to_first_peak) THEN + IF (abs_mo_idx <= rtbse_env%n_occ(i)) THEN + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) + 0.5_dp*rtbse_env%omega_shift + ELSE + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) - 0.5_dp*rtbse_env%omega_shift + END IF + END IF + ! Mirror the finalized diagonal into the replicated active-energy array + rtbse_env%eps_active(i_row_global, i) = rtbse_env%real_workspace_mo(1)%local_data(ii, jj) + END IF + END DO + END DO + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%ham_reference_singleparticle(i)) + END DO + ! Each diagonal element was set on its single owner rank; sum to replicate eps_active. + CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%sum(rtbse_env%eps_active) + ! ****** END SINGLE PARTICLE HAMILTONIAN CALCULATION + + CALL timestop(handle) + END SUBROUTINE initialize_singleparticle_hamiltonian + +! ************************************************************************************************** +!> \brief Reference Hartree subtraction: builds V^H[ρ^0] (AO-RI or RI-RS) and subtracts it into +!> ham_reference, realizing H_eff = ... + V_H[ρ] - V_H[ρ^0]. Only for non-TDA n_spin=1 (in +!> TDA the OV/VO projection of the OO-diagonal ρ^0 vanishes, so the reference is zero). +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - add transform to MO +! ************************************************************************************************** + SUBROUTINE initialize_hartree_potential(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'initialize_hartree_potential' + + INTEGER :: handle, i, n_grid + LOGICAL :: use_hartree_reference, use_rirs_kernel + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + use_hartree_reference = (.NOT. rtbse_env%tda_active) .AND. (rtbse_env%n_spin == 1) .AND. & + (.NOT. rtbse_env%debug_disable_hartree) + use_rirs_kernel = rtbse_env%rirs_kernel + + ! Make sure the RI-RS V_grid kernel is available if we need it for Hartree. + IF (use_rirs_kernel) CALL rt_bse_ri_rs_ensure_V_grid(bs_env, rtbse_env%qs_env) + + ! Spin-summed grid-density accumulators for the RI-RS Hartree reuse (diag(φρφ^T) harvested in SEX; + ! mat_phi_mu_l is grid x AO, so its row count is n_grid). Allocated ONLY for RI-RS + Hartree, so the + ! get_sigma harvest calls (passed unconditionally below) see an absent optional and self-disable on + ! AO-RI / Hartree-off (F2008 unallocated-allocatable -> absent optional). Sole allocator, runs once. + IF (use_rirs_kernel .AND. (.NOT. rtbse_env%debug_disable_hartree)) THEN + CALL dbcsr_get_info(bs_env%ri_rs%mat_phi_mu_l, nfullrows_total=n_grid) + ALLOCATE (rtbse_env%hartree_diag_re(n_grid), rtbse_env%hartree_diag_im(n_grid)) + END IF + + ! The RI-RS Hartree normally reuses the grid density harvested by the SEX kernel. With SEX + ! disabled but Hartree on, that diagonal is never produced, so the Hartree must rebuild the full + ! real-space density grid itself every RK4 stage - much slower. Warn once (this is a debug-only + ! configuration); the rebuild fallback lives in the use_sex branches of the Hartree kernels. + IF (use_rirs_kernel .AND. (.NOT. rtbse_env%debug_disable_hartree) .AND. rtbse_env%debug_disable_sex) THEN + CALL cp_warn(__LOCATION__, & + "RI-RS Hartree rebuilds the full density grid every RK4 stage because SEX is "// & + "disabled (DEBUG_DISABLE_SEX) and no SEX-harvested diagonal is available to reuse. "// & + "This slows down the Hartree computation considerably.") + END IF + + ! ****** START HARTREE POTENTIAL REFERENCE CALCULATION + ! v_dbcsr is needed by either AO-RI Hartree (here) or by AO-RI SEX (W = V + W^c assembly). + IF (.NOT. use_rirs_kernel) THEN + CALL init_hartree(rtbse_env, rtbse_env%v_dbcsr) + END IF + ! Always zero ham_reference here (this routine is the first to touch it). + ! The Hartree reference subtraction is then conditionally added below. + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_set_all(rtbse_env%ham_reference(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + ! Calculate the original Hartree potential + ! Uses rho_orig - same as rho for initial run but different for continued run + ! In TDA the propagator evaluates separate OV/VO-projected kernel passes. + ! rho_orig is OO-diagonal in the MO basis, so its OV/VO projections vanish + ! and the corresponding Hartree reference is identically zero. + IF (use_hartree_reference) THEN + DO i = 1, rtbse_env%n_spin + IF (use_rirs_kernel) THEN + ! V^H_λσ = sum_l φ_λ(r_l) v_l φ_σ(r_l), v_l = sum_l' V_ll' n_l' (RI-RS) + ! AO-RI get_hartree uses only Re(rho); mirror that on the RI-RS path. + CALL cp_cfm_to_fm(msource=rtbse_env%rho_ao_scratch(i), & + mtargetr=rtbse_env%real_workspace(1)) + CALL compute_hartree_ri_rs(bs_env, rtbse_env%real_workspace(1), & + rtbse_env%hartree_curr_ao(i)) + ELSE + ! V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) ρ^0_µν] (AO-RI; reference density) + CALL get_hartree(rtbse_env, rtbse_env%rho_ao_scratch(i), rtbse_env%hartree_curr_ao(i)) + END IF + ! Scaling by spin degeneracy + CALL cp_fm_scale(rtbse_env%spin_degeneracy, rtbse_env%hartree_curr_ao(i)) + ! Transform to MO basis (AO scratch -> MO-active result) + CALL transform_ao_to_mo_covariant_fm(rtbse_env, rtbse_env%hartree_curr_ao(i), rtbse_env%hartree_curr(i), i) + ! Apply occupation factor f_n-f_m + CALL transform_mo_occupation_factor_diff_fm(rtbse_env, rtbse_env%hartree_curr(i), i) + ! Subtract the reference from the reference Hamiltonian + ! following H_eff = ... + V_Hartree(rho) - V_Hartree(rho_0), + CALL cp_fm_to_cfm(msourcer=rtbse_env%hartree_curr(i), mtarget=rtbse_env%ham_workspace(1)) + CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & + CMPLX(-1.0, 0.0, kind=dp), rtbse_env%ham_workspace(1)) + END DO + END IF + ! ****** END HARTREE POTENTIAL REFERENCE CALCULATION + + CALL timestop(handle) + END SUBROUTINE initialize_hartree_potential + +! ************************************************************************************************** +!> \brief Reference SEX self-energy subtraction into ham_reference (non-TDA, n_spin=1). Assembles +!> W = V + W^c, then Σ^SX = -W ρ^0, (f_n - f_m)-weighted, subtracted. +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml (03.26) - add transform to MO +! ************************************************************************************************** + SUBROUTINE initialize_sex_selfenergy(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'initialize_sex_selfenergy' + + INTEGER :: handle, i + LOGICAL :: use_rirs_kernel, use_sex_reference + + CALL timeset(routineN, handle) + use_sex_reference = (.NOT. rtbse_env%tda_active) .AND. (rtbse_env%n_spin == 1) .AND. & + (.NOT. rtbse_env%debug_disable_sex) + use_rirs_kernel = rtbse_env%rirs_kernel + + ! Make sure the RI-RS W0_grid kernel is available if we need it for SEX. + IF (use_rirs_kernel) CALL rt_bse_ri_rs_ensure_W0_grid(rtbse_env%bs_env, rtbse_env%qs_env) + + ! ****** START SEX REFERENCE CALCULATION + ! w_dbcsr and screened_dbt are needed for get_sigma routines (AO-RI path only). + ! For RI-RS the W = V + W^c kernel is on the real-space grid in mat_W0_grid_rtbse. + IF (.NOT. use_rirs_kernel) THEN + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ! W(w=0) is built by the GW step only under its RTBSE rtp_method gate; reaching this + ! consumer without it means gate and consumer disagree. The HF branch below needs no W. + IF (.NOT. ASSOCIATED(rtbse_env%bs_env%fm_W_MIC_freq_zero%matrix_struct)) THEN + CALL cp_abort(__LOCATION__, & + "RT-BSE AO-RI kernel needs the screened interaction W(w=0), which the "// & + "GW step did not build. Select the RT-BSE propagator with '&RTBSE' or "// & + "'&RTBSE RTBSE', not '&RTBSE TDDFT'.") + END IF + ! In a non-HF calculation, copy the actual correlation part of the interaction + CALL copy_fm_to_dbcsr(rtbse_env%bs_env%fm_W_MIC_freq_zero, rtbse_env%w_dbcsr) + ELSE + ! In HF, correlation is set to zero + CALL dbcsr_set(rtbse_env%w_dbcsr, 0.0_dp) + END IF + ! Add the Hartree to the screened_dbt tensor - now W = V + W^c + CALL dbcsr_add(rtbse_env%w_dbcsr, rtbse_env%v_dbcsr, 1.0_dp, 1.0_dp) + CALL dbt_copy_matrix_to_tensor(rtbse_env%w_dbcsr, rtbse_env%screened_dbt) + END IF + ! Calculate the SEX starting energies + DO i = 1, rtbse_env%n_spin + ! Calculate the exchange (SEX) part for this spin channel + ! Uses rho_orig - same as rho for initial run but different for continued run + ! For KS reference this is the time-dependent Fock exchange (w_dbcsr = v only). + ! In TDA the propagator evaluates separate OV/VO-projected kernel passes. + ! rho_orig is OO-diagonal in the MO basis, so its OV/VO projections + ! vanish and the SEX reference must remain zero in TDA. + IF (use_sex_reference) THEN + ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) ρ^0_µν][sum_P (νσ|P) W_PQ] (reference) + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(i), -1.0_dp, rtbse_env%rho_ao_scratch(i)) + ! Transform to MO basis (AO scratch -> MO-active result) + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(i), rtbse_env%sigma_SEX(i), i) + ! Apply occupation factor f_n-f_m + CALL transform_mo_occupation_factor_diff_cfm(rtbse_env, rtbse_env%sigma_SEX(i), i) + ! Subtract from the complex reference Hamiltonian + CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & + CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) + END IF + END DO + ! ****** END SEX REFERENCE CALCULATION + + CALL timestop(handle) + END SUBROUTINE initialize_sex_selfenergy + +! ************************************************************************************************** +!> \brief Propagates the density one timestep by RK4 for ∂_t ρ = f(t,ρ) = +!> -i( Δε Δρ + (f_n - f_m) V_Hartree(Δρ) + ΔΣ(Δρ) ); see body for the 4-stage scheme. +!> Spin loop is inner to each stage (cross-spin Hartree coupling). +!> \param rtbse_env Entry point - rtbse environment +!> \param rho_start Initial density matrix +!> \param rho_end Final density matrix +! ************************************************************************************************** + SUBROUTINE solve_rk4_timestep(rtbse_env, rho_start, rho_end) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_start, rho_end + + CHARACTER(len=*), PARAMETER :: routineN = 'solve_rk4_timestep' + + INTEGER :: handle, i + + CALL timeset(routineN, handle) + ! RK4 follows the typical scheme + ! d/dt ρ = f(t, ρ) + ! f(t,ρ) = -i( Δε Δρ + (f_n-f_m) V_Hartree(Δρ) + ΔΣ(Δρ) ) + ! i.e. RK4 reads + ! k_1 = f(t, ρ_start) + ! k_2 = f(t + dt/2, ρ_start + dt/2 * k_1) + ! k_3 = f(t + dt/2, ρ_start + dt/2 * k_2) + ! k_4 = f(t + dt, ρ_start + dt * k_3) + ! ρ_end = ρ_start + dt/6 * (k_1 + 2*k_2 + 2*k_3 + k_4) + ! Note that the effective Hamiltonian needs to be updated for each evaluation of f, + ! as it depends on the density matrix at the respective time + + ! Spin loop is INNER to each RK4 stage (inside do_rk4_stage): cross-spin-coupled kernels (Hartree in + ! open shell) need every spin's stage density before any spin advances. rk4_coefficients(i) holds + ! spin i's CURRENT-stage k (indexed by spin, not stage - see its allocation in create_rtbse_env), + ! reused across stages; rho_workspace(i) holds spin i's stage density. Bit-identical for n_spin=1. + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_to_cfm(rho_start(i), rho_end(i)) + END DO + ! Each stage: do_rk4_stage evaluates k = f(stage density) for all spins, accumulates + ! rho_end += result_weight*dt*k (Butcher b = 1/6, 1/3, 1/3, 1/6) and forms the next stage density + ! rho_workspace = rho_start + advance_weight*dt*k (node c = 1/2, 1/2, 1; omitted on k_4, which only + ! accumulates). The dt factor is applied inside do_rk4_stage, so the calls show the bare weights. + ! k_1 = f(t, rho_start) + CALL do_rk4_stage(rtbse_env, rho_start, rho_start, rho_end, & + result_weight=1.0_dp/6.0_dp, advance_weight=0.5_dp) + ! k_2 = f(t + dt/2, rho_start + dt/2 * k_1) + CALL do_rk4_stage(rtbse_env, rtbse_env%rho_workspace, rho_start, rho_end, & + result_weight=1.0_dp/3.0_dp, advance_weight=0.5_dp) + ! k_3 = f(t + dt/2, rho_start + dt/2 * k_2) + CALL do_rk4_stage(rtbse_env, rtbse_env%rho_workspace, rho_start, rho_end, & + result_weight=1.0_dp/3.0_dp, advance_weight=1.0_dp) + ! k_4 = f(t + dt, rho_start + dt * k_3) + CALL do_rk4_stage(rtbse_env, rtbse_env%rho_workspace, rho_start, rho_end, & + result_weight=1.0_dp/6.0_dp) + + ! Update bookkeeping to the next timestep similar to logic of etrs_scf_loop + rtbse_env%sim_step = rtbse_env%sim_step + 1 + rtbse_env%sim_time = rtbse_env%sim_time + rtbse_env%sim_dt + + CALL timestop(handle) + END SUBROUTINE solve_rk4_timestep + +! ************************************************************************************************** +!> \brief Takes one RK4 stage. Evaluates k = f(t, rho_eval) for every spin into +!> rtbse_env%rk4_coefficients, accumulates it into the running result (rho_end += result_weight*dt*k) +!> and - unless this is the last stage - forms the next stage density +!> (rho_workspace = rho_base + advance_weight*dt*k). Builds the stage's shared kernels first: the +!> cross-spin Hartree is built once per stage and consumed by every spin in update_effective_ham_MO. +!> All shell/kernel combinations go through build_shared_sex_and_hartree (mask_mode selects the +!> input convention); update_effective_ham_MO is then a pure consumer. +!> No timeset/timestop: the callees are individually timed and this runs 4x per RK4 timestep. +!> \param rtbse_env RT-BSE environment +!> \param rho_eval Per-spin MO density f is evaluated at (rho_start for k_1, rho_workspace otherwise) +!> \param rho_base Per-spin MO density the next stage advances from (the step's rho_start) +!> \param rho_end Per-spin RK4 result accumulator (= rho_start + dt/6*(k1+2k2+2k3+k4) after all 4 stages) +!> \param result_weight RK4 Butcher weight b (dt factor applied inside) for accumulating k into rho_end +!> \param advance_weight RK4 node c (dt factor applied inside) for the next stage density; ABSENT on the last stage +!> \author Maximilian Graml +! ************************************************************************************************** + SUBROUTINE do_rk4_stage(rtbse_env, rho_eval, rho_base, rho_end, result_weight, advance_weight) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_eval, rho_base, rho_end + REAL(kind=dp), INTENT(IN) :: result_weight + REAL(kind=dp), INTENT(IN), OPTIONAL :: advance_weight + + INTEGER :: i, mask_mode + + ! Input convention for this stage's shared kernel build: + IF (rtbse_env%tda_active) THEN + mask_mode = kernel_input_ov ! TDA (any shell): OV only, non-Hermitian + ELSE IF (rtbse_env%n_spin > 1) THEN + mask_mode = kernel_input_ovvo ! open-shell ABBA: OV+VO, Hermitian + ELSE + mask_mode = kernel_input_full ! closed-shell ABBA: full ρ, Hermitian + END IF + ! Build this stage's shared SEX + bare Hartree; consumers are per-spin in update_effective_ham_MO. + CALL build_shared_sex_and_hartree(rtbse_env, rho_eval, mask_mode) + DO i = 1, rtbse_env%n_spin + CALL update_effective_ham_MO(rtbse_env, rho_eval(i), rtbse_env%rk4_coefficients(i), i) + IF (rtbse_env%tda_active .OR. rtbse_env%n_spin > 1) THEN + CALL project_drho_to_ov(rtbse_env, rtbse_env%rk4_coefficients(i), i) + END IF + END DO + ! Fold each spin's k into the RK4 result and (unless last stage) form the next stage density. + ! The dt factor lives here so the call sites carry the bare RK4 weights. + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rho_end(i), & + CMPLX(result_weight*rtbse_env%sim_dt, 0.0_dp, kind=dp), rtbse_env%rk4_coefficients(i)) + IF (PRESENT(advance_weight)) THEN + CALL cp_cfm_to_cfm(rho_base(i), rtbse_env%rho_workspace(i)) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_workspace(i), & + CMPLX(advance_weight*rtbse_env%sim_dt, 0.0_dp, kind=dp), rtbse_env%rk4_coefficients(i)) + END IF + END DO + END SUBROUTINE do_rk4_stage + +! ************************************************************************************************** +!> \brief Builds the spin-summed complex Hartree potential in AO, once per RK4 stage (AO-RI or RI-RS). +!> rho_total = spin_degeneracy * sum_sigma (OV-masked rho^sigma -> AO); hartree_total_ao = +!> V_H[rho_total]. update_effective_ham_MO back-transforms it with each spin's C, so this +!> single call feeds every spin block - the cross-spin Hartree coupling of open shell. +!> Side effect: leaves rho_ao_scratch(sigma) = OV-masked AO density (recomputed per spin in +!> update_effective_ham_MO; built here only to form the sum). +!> \param rtbse_env RT-BSE environment +!> \param rho_stage Per-spin MO density at the current RK4 stage +!> \param keep_ovvo .FALSE. = OV source mask (TDA); .TRUE. = OV+VO (open-shell ABBA). +!> \author Maximilian Graml +! ************************************************************************************************** + SUBROUTINE build_shared_hartree_ao(rtbse_env, rho_stage, keep_ovvo) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_stage + LOGICAL, INTENT(IN) :: keep_ovvo + + CHARACTER(len=*), PARAMETER :: routineN = 'build_shared_hartree_ao' + + INTEGER :: handle, isp + + CALL timeset(routineN, handle) + ! Per spin: mask the stage density and project to AO. + DO isp = 1, rtbse_env%n_spin + CALL cp_cfm_to_cfm(rho_stage(isp), rtbse_env%rho_delta_mo(isp)) + CALL mask_mo_block_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), isp, & + keep_OV=.TRUE., keep_ovvo=keep_ovvo) + CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), & + rtbse_env%rho_ao_scratch(isp), isp) + END DO + ! Sum: rho_total = spin_degeneracy * sum_isp rho_ao_scratch(isp). + CALL cp_cfm_set_all(rtbse_env%rho_total_ao_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + DO isp = 1, rtbse_env%n_spin + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_total_ao_scratch, & + CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), & + rtbse_env%rho_ao_scratch(isp)) + END DO + ! One complex Hartree contraction on the summed density. RI backend = kernel choice: both + ! get_hartree_complex and compute_hartree_ri_rs_complex take AO x AO in/out and are spin-blind, + ! so the spin-summed cross-spin density feeds whichever kernel is active. + IF (rtbse_env%rirs_kernel) THEN + ! V^H_λσ = sum_l φ_λ(r_l) v_l φ_σ(r_l), v_l = sum_l' V_ll' n_l'[ρ^total] (RI-RS) + CALL compute_hartree_ri_rs_complex(rtbse_env%bs_env, rtbse_env%rho_total_ao_scratch, & + rtbse_env%hartree_total_ao) + ELSE + ! V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) ρ^total_µν] (AO-RI) + CALL get_hartree_complex(rtbse_env, rtbse_env%rho_total_ao_scratch, & + rtbse_env%hartree_total_ao, 1) + END IF + CALL timestop(handle) + END SUBROUTINE build_shared_hartree_ao + +! ************************************************************************************************** +!> \brief Unified cross-spin kernel builder, once per RK4 stage for every shell. Computes the +!> per-spin SEX self-energy (stashed in sigma_SEX_ao(σ)) and the single shared bare Hartree +!> (hartree_total_ao), so update_effective_ham_MO only consumes them. +!> mask_mode selects the source-density convention (OV / OV+VO / full-ρ); it also determines +!> the input Hermiticity, which gates the Hartree imaginary channel: Im computed only when +!> mask_mode = kernel_input_ov (non-Hermitian TDA input); for Hermitian input Im ≡ 0 analytically +!> and is skipped. Hartree emitted BARE (no spin_degeneracy); consumer scales g on the MO output. +!> \param rtbse_env RT-BSE environment +!> \param rho_stage Per-spin MO density at the current RK4 stage +!> \param mask_mode Input-convention selector: kernel_input_ov / kernel_input_ovvo / kernel_input_full +!> \author Maximilian Graml +! ************************************************************************************************** + SUBROUTINE build_shared_sex_and_hartree(rtbse_env, rho_stage, mask_mode) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_stage + INTEGER, INTENT(IN) :: mask_mode + + CHARACTER(len=*), PARAMETER :: routineN = 'build_shared_sex_and_hartree' + + INTEGER :: handle, isp + LOGICAL :: harvest_im, use_hartree, & + use_rirs_kernel, use_sex + + CALL timeset(routineN, handle) + use_hartree = .NOT. rtbse_env%debug_disable_hartree + use_sex = .NOT. rtbse_env%debug_disable_sex + use_rirs_kernel = rtbse_env%rirs_kernel + ! Im channel iff the masked input is non-Hermitian (OV-only, TDA). For Hermitian input (OV+VO + ! or full ρ) Im(ρ) is antisymmetric and Coulomb factors are symmetric, so V_H[Im] ≡ 0. + harvest_im = (mask_mode == kernel_input_ov) + + ! Pre-zero the RI-RS spin-summed grid-diagonal accumulators (the SEX harvest target). + IF (use_rirs_kernel .AND. use_sex .AND. use_hartree) THEN + rtbse_env%hartree_diag_re(:) = 0.0_dp + IF (harvest_im) rtbse_env%hartree_diag_im(:) = 0.0_dp + END IF + ! Per spin: stage ρ into AO (masked per mask_mode); SEX (stash sigma_SEX_ao(σ)); RI-RS harvests + ! the diagonal. + DO isp = 1, rtbse_env%n_spin + CALL cp_cfm_to_cfm(rho_stage(isp), rtbse_env%rho_delta_mo(isp)) + SELECT CASE (mask_mode) + CASE (kernel_input_ov) + CALL mask_mo_block_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), isp, & + keep_OV=.TRUE., keep_ovvo=.FALSE.) + CASE (kernel_input_ovvo) + CALL mask_mo_block_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), isp, & + keep_OV=.TRUE., keep_ovvo=.TRUE.) + CASE (kernel_input_full) + ! no mask: full ρ (closed-shell ABBA; reference subtracted later via ham_reference) + CASE DEFAULT + CPABORT("Unknown mask_mode in build_shared_sex_and_hartree") + END SELECT + CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), & + rtbse_env%rho_ao_scratch(isp), isp) + IF (use_sex) THEN + ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ]. Im accumulator passed only + ! when harvesting; absent (unallocated optional) on AO-RI / Hartree-off / Hermitian. + IF (harvest_im) THEN + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(isp), -1.0_dp, rtbse_env%rho_ao_scratch(isp), & + grid_diag_re_accum=rtbse_env%hartree_diag_re, & + grid_diag_im_accum=rtbse_env%hartree_diag_im) + ELSE + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(isp), -1.0_dp, rtbse_env%rho_ao_scratch(isp), & + grid_diag_re_accum=rtbse_env%hartree_diag_re) + END IF + END IF + END DO + ! Shared cross-spin Hartree, emitted BARE (no spin_degeneracy — consumer scales g on output). + ! RI-RS reuses the spin-summed grid diagonal; AO-RI contracts rho_total = sum_σ ρ_σ. + ! Hermitian input: real Hartree path (Im ≡ 0); non-Hermitian: complex. + IF (use_hartree) THEN + IF (use_rirs_kernel .AND. use_sex) THEN + IF (harvest_im) THEN + CALL compute_hartree_ri_rs_from_diag(rtbse_env%bs_env, rtbse_env%hartree_diag_re, & + rtbse_env%hartree_total_ao, n_im=rtbse_env%hartree_diag_im) + ELSE + CALL compute_hartree_ri_rs_from_diag(rtbse_env%bs_env, rtbse_env%hartree_diag_re, & + rtbse_env%hartree_total_ao) + END IF + ELSE + CALL cp_cfm_set_all(rtbse_env%rho_total_ao_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + DO isp = 1, rtbse_env%n_spin + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_total_ao_scratch, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_ao_scratch(isp)) + END DO + IF (use_rirs_kernel) THEN + IF (harvest_im) THEN + CALL compute_hartree_ri_rs_complex(rtbse_env%bs_env, rtbse_env%rho_total_ao_scratch, & + rtbse_env%hartree_total_ao) + ELSE + ! Hermitian input: real RI-RS on Re(ρ_total) -> cfm with Im ≡ 0. + CALL cp_cfm_to_fm(msource=rtbse_env%rho_total_ao_scratch, & + mtargetr=rtbse_env%real_workspace(1)) + CALL compute_hartree_ri_rs(rtbse_env%bs_env, rtbse_env%real_workspace(1), & + rtbse_env%hartree_curr_ao(1)) + CALL cp_cfm_set_all(rtbse_env%hartree_total_ao, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%hartree_curr_ao(1), & + mtarget=rtbse_env%hartree_total_ao) + END IF + ELSE + IF (harvest_im) THEN + CALL get_hartree_complex(rtbse_env, rtbse_env%rho_total_ao_scratch, & + rtbse_env%hartree_total_ao, 1) + ELSE + ! Hermitian input: real AO-RI on Re(ρ_total) -> cfm with Im ≡ 0. + CALL get_hartree(rtbse_env, rtbse_env%rho_total_ao_scratch, & + rtbse_env%hartree_curr_ao(1)) + CALL cp_cfm_set_all(rtbse_env%hartree_total_ao, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%hartree_curr_ao(1), & + mtarget=rtbse_env%hartree_total_ao) + END IF + END IF + END IF + END IF + CALL timestop(handle) + END SUBROUTINE build_shared_sex_and_hartree + + ! ************************************************************************************************** +!> \brief Assembles the linearized RT-BSE right-hand side in the MO basis and returns it scaled by -i: +!> ham_effective <- -i( [H^0, ρ] + (f_n - f_m)(ΔΣ^SX[Δρ] + ΔV^H[Δρ]) ), i.e. the +!> f(t,ρ) of ∂_t Δρ_mn = -i( (ε_m - ε_n)Δρ_mn + (f_n - f_m)(V^H_mn + Σ^SX_mn) ). +!> ham_reference already carries KS+G0W0 minus the reference SEX/Hartree, so the kernels +!> enter as differences vs the reference. Forks: tda_active (drop B-coupling: one OV kernel +!> pass + VO conjugate) vs full ABBA (OV+VO); n_spin and the KERNEL_RI (rirs_kernel) flag +!> select the AO-RI or RI-RS backend per term. +!> \param rtbse_env Entry point of the calculation - contains current state of variables +!> \param rho Real and imaginary parts ( + spin) of the density at current time +!> \param ham_effective Effective Hamiltonian in the MO basis that is updated in this routine +!> \param ispin Spin channel σ being assembled +! ************************************************************************************************** + SUBROUTINE update_effective_ham_MO(rtbse_env, rho, ham_effective, ispin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type) :: rho, ham_effective + INTEGER :: ispin + + CHARACTER(len=*), PARAMETER :: routineN = 'update_effective_ham_MO' + + INTEGER :: handle, i_global, i_loc, j_global, & + j_loc, ncl, nrl + INTEGER, DIMENSION(:), POINTER :: c_idx, r_idx + LOGICAL :: use_hartree, use_sex + + CALL timeset(routineN, handle) + use_hartree = .NOT. rtbse_env%debug_disable_hartree + use_sex = .NOT. rtbse_env%debug_disable_sex + + ! Reset the effective Hamiltonian to KS Hamiltonian + G0W0 - reference SEX - reference Hartree + ! Sets the imaginary part to zero + CALL cp_cfm_to_cfm(rtbse_env%ham_reference(ispin), ham_effective) + ! [H^0, ρ]_mn = (ε_m - ε_n) ρ_mn exactly (H^0 diagonal in active-MO basis). Element-wise + ! local pass replacing the two gemms; ham_effective and rho share fm_struct_mo_active so + ! their local layouts coincide. Covers all (m,n) (OO/VV retained for closed-shell ABBA). + CALL cp_cfm_get_info(matrix=ham_effective, nrow_local=nrl, ncol_local=ncl, & + row_indices=r_idx, col_indices=c_idx) + DO j_loc = 1, ncl + j_global = c_idx(j_loc) + DO i_loc = 1, nrl + i_global = r_idx(i_loc) + ham_effective%local_data(i_loc, j_loc) = ham_effective%local_data(i_loc, j_loc) & + + CMPLX(rtbse_env%eps_active(i_global, ispin) - rtbse_env%eps_active(j_global, ispin), & + 0.0_dp, kind=dp)*rho%local_data(i_loc, j_loc) + END DO + END DO + ! Determine the field at current time + IF (rtbse_env%dft_control%apply_efield_field) THEN + CALL cp_abort(__LOCATION__, & + "Continuous/pulsed E(t) field coupling is not implemented for linearized "// & + "RT-BSE. Only the delta-kick (impulsive) absorption spectrum is supported; "// & + "use APPLY_DELTA_PULSE.") + ELSE + ! No field + rtbse_env%field(:) = 0.0_dp + END IF + IF (.NOT. rtbse_env%tda_active) THEN + ! ===== ABBA: consume the prebuilt per-spin SEX (sigma_SEX_ao(σ)) and shared bare Hartree + ! (hartree_total_ao). (f_n-f_m) zeros OO/VV and sets OV/VO signs. Closed shell uses full-ρ + ! input (no mask, reference subtracted via ham_reference); open shell uses OV+VO mask. ===== + IF (use_sex) THEN + ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ] + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), & + rtbse_env%sigma_SEX(ispin), ispin) + CALL transform_mo_occupation_factor_diff_cfm(rtbse_env, rtbse_env%sigma_SEX(ispin), ispin) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%sigma_SEX(ispin)) + END IF + IF (use_hartree) THEN + ! Builder emits bare V_H (no spin_degeneracy); fold g here (post-occ-factor). + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & + rtbse_env%ham_workspace(1), ispin) + CALL transform_mo_occupation_factor_diff_cfm(rtbse_env, rtbse_env%ham_workspace(1), ispin) + CALL cp_cfm_scale(CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) + END IF + ELSE + ! ----- TDA: drop B-coupling. Consume the OV-input kernels prebuilt by + ! build_shared_sex_and_hartree. K_MO[Δρ_VO] = (K_MO[Δρ_OV])^C (real C + symmetric AO kernels), + ! so evaluate on OV, mask MO to OV, add VO as conjugate transpose. + ! Signs: (f_n - f_m) = -1 on OV, +1 on VO; applied explicitly. ----- + + ! SEX: AO->MO, mask OV, stash (assembled after Hartree). + IF (use_sex) THEN + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), & + rtbse_env%sigma_SEX(ispin), ispin) + CALL mask_mo_block_cfm(rtbse_env, rtbse_env%sigma_SEX(ispin), ispin, keep_OV=.TRUE.) + END IF + + ! Hartree: hartree_total_ao is bare (no spin_degeneracy); fold g here (post-mask). + ! VO = (OV)^C; rho_delta_mo(ispin) is idle scratch. + IF (use_hartree) THEN + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & + rtbse_env%ham_workspace(1), ispin) + CALL mask_mo_block_cfm(rtbse_env, rtbse_env%ham_workspace(1), ispin, keep_OV=.TRUE.) + CALL cp_cfm_scale(CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) + CALL cp_cfm_transpose(rtbse_env%ham_workspace(1), 'C', rtbse_env%rho_delta_mo(ispin)) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_delta_mo(ispin)) + END IF + + ! SEX assembled (stashed sigma_SEX, OV-masked). OV sign -1; VO = (OV)^C sign +1. + IF (use_sex) THEN + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%sigma_SEX(ispin)) + CALL cp_cfm_transpose(rtbse_env%sigma_SEX(ispin), 'C', rtbse_env%rho_delta_mo(ispin)) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_delta_mo(ispin)) + END IF + + ! Restore rho_ao_scratch to the AO image of the current full rho, so any + ! post-routine consumer (output_mos) sees the same invariant. + CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rho, rtbse_env%rho_ao_scratch(ispin), ispin) + END IF + ! Return the actual RHS f(t,rho) = -i * A(rho) for RK4 + CALL cp_cfm_scale(CMPLX(0.0_dp, -1.0_dp, kind=dp), ham_effective) + + CALL timestop(handle) + END SUBROUTINE update_effective_ham_MO + +! ************************************************************************************************** +!> \brief Single-spin Liouvillian matvec: apply L^sigma_sigma to one spin's Delta rho_MO and return +!> L * Delta rho_MO in MO basis, OV+VO blocks populated. Drives the n_spin=1 TDA diagnostic +!> and the (n_spin=1) ABBA diagnostic; the open-shell TDA path uses the array routine +!> apply_liouvillian_to_drho instead. Detached from the propagator (does NOT touch +!> rho / rho_orig / ham_effective / ham_reference); only env scratches drho_probe(ispin), +!> rho_ao_scratch, sigma_SEX_ao, hartree_total_ao, ham_workspace(1), sigma_SEX, +!> rho_delta_mo(ispin), real_workspace_mo(1) are used. +!> +!> Matrix elements correspond to the Casida-A matrix: +!> L_{ia,jb} = (eps_a - eps_i) delta_{ij} delta_{ab} + (ia|jb) - W_{ij,ab} +!> with no (f_n - f_m) factor (the propagator path applies -1 on OV; we want raw +K). +!> Honors rtbse_env%rirs_kernel to dispatch Hartree to the RI-RS grid kernel +!> (compute_hartree_ri_rs_complex); the SX RI-RS dispatch also reads rirs_kernel inside get_sigma. +!> AO-RI path: get_hartree_complex / get_sigma. +!> +!> \param rtbse_env RT-BSE environment (TDA, n_spin=1). +!> \param drho_in Input Delta rho_MO (mo_active x mo_active complex). +!> \param L_drho_out Output L * Delta rho_MO; OV+VO blocks populated; OO/VV zero. +!> \param ispin Spin index. +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** + SUBROUTINE apply_liouvillian_to_drho_spin(rtbse_env, drho_in, L_drho_out, ispin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), INTENT(IN) :: drho_in + TYPE(cp_cfm_type), INTENT(INOUT) :: L_drho_out + INTEGER, INTENT(IN) :: ispin + + CHARACTER(len=*), PARAMETER :: routineN = 'apply_liouvillian_to_drho_spin' + + INTEGER :: abs_mo_idx, handle, i_row_global, ii, & + j_col_global, jj, ncol_local, & + nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: use_hartree, use_sex + + CALL timeset(routineN, handle) + + ! Mirror update_effective_ham_MO kernel gating: only Hartree + SX are gated + ! (no COH kernel in linRTBSE). + use_hartree = .NOT. rtbse_env%debug_disable_hartree + use_sex = .NOT. rtbse_env%debug_disable_sex + ! RI-RS dispatch reads rtbse_env%rirs_kernel directly below. + ! V_grid / W0_grid are populated by initialize_hartree_potential / + ! initialize_sex_selfenergy, which run before this diagnostic. + + ! 1. Stage drho_in into drho_probe. TDA: mask to OV (propagator carries only OV + ! and the VO contribution is recovered later via the (.)^C shortcut). ABBA: keep + ! the full OV+VO content - drho_in carries both blocks independently. + CALL cp_cfm_to_cfm(drho_in, rtbse_env%drho_probe(ispin)) + IF (rtbse_env%tda_active) THEN + CALL mask_mo_block_cfm(rtbse_env, rtbse_env%drho_probe(ispin), ispin, keep_OV=.TRUE.) + END IF + + ! 2. Project Delta rho_OV (MO -> AO, contravariant). + CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%drho_probe(ispin), & + rtbse_env%rho_ao_scratch(ispin), ispin) + + ! 3. Initialize the output accumulator. + CALL cp_cfm_set_all(L_drho_out, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + + ! 4. eps_{ai} diagonal contribution, kept before the kernel steps (5/6). drho_in aliases + ! rtbse_env%drho_probe(ispin) at the caller; the kernels' VO Hermitian-conjugate scratch + ! is rho_delta_mo(ispin) (NOT drho_probe), so they no longer corrupt drho_in - but eps + ! first is the clean ordering. Build H_eps as a real diagonal fm in real_workspace_mo(1), + ! convert to cfm in ham_workspace(1), accumulate [drho_in, H_eps] = drho * H - H * drho. + ! On OV: ([drho, H])_{ia} = (eps_a - eps_i) * drho_{ia} = +eps_{ai} * drho_{ia}. + ! On VO: -eps_{ai} * drho_{ai} (sign flips); irrelevant - driver only reads OV. + ! Bare GW eigenvalues (lab frame) so eigenvalues compare 1:1 to bse_full.F. + CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) + DO ii = 1, nrow_local + i_row_global = row_indices(ii) + DO jj = 1, ncol_local + j_col_global = col_indices(jj) + IF (i_row_global == j_col_global) THEN + abs_mo_idx = i_row_global + rtbse_env%first_active_mo - 1 + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & + rtbse_env%bs_env%eigenval_G0W0(abs_mo_idx, 1, ispin) + END IF + END DO + END DO + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & + mtarget=rtbse_env%ham_workspace(1)) + ! drho * H_eps + CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), drho_in, rtbse_env%ham_workspace(1), & + CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out) + ! -H_eps * drho + CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1), drho_in, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out) + + ! 5. Hartree contribution: get_hartree_complex (Re/Im split) on AO Delta rho, then + ! AO->MO covariant, mask OV+VO, accumulate +spin_degeneracy on OV and on VO. + ! No (f_n - f_m) factor: we want raw +K (Casida convention), not the propagator's -K_OV. + ! VO contribution comes from the Hermitian conjugate of the OV result (P2 in + ! rt_bse_pitfalls_physics.md): for real C_active + AO-pair-symmetric kernel, + ! K_MO[Delta rho_VO] = (K_MO[Delta rho_OV])^C. + IF (use_hartree) THEN + IF (rtbse_env%rirs_kernel) THEN + ! V^H_λσ = sum_l φ_λ(r_l) v_l φ_σ(r_l), v_l = sum_l' V_ll' n_l' (RI-RS) + CALL compute_hartree_ri_rs_complex(rtbse_env%bs_env, rtbse_env%rho_ao_scratch(ispin), & + rtbse_env%hartree_total_ao) + ELSE + ! V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) Δρ_µν] (AO-RI) + CALL get_hartree_complex(rtbse_env, rtbse_env%rho_ao_scratch(ispin), & + rtbse_env%hartree_total_ao, ispin) + END IF + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & + rtbse_env%ham_workspace(1), ispin) + CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%ham_workspace(1), L_drho_out, & + CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), ispin) + END IF + + ! 6. Screened-exchange contribution: get_sigma is already complex-aware. The + ! -1.0_dp factor passed to get_sigma builds the -W contribution; we then add + ! +1.0 here (no occupation-factor flip), giving raw K^SX = -W as required by + ! K = (ia|jb) - W_{ij,ab} (Casida convention with +K). + IF (use_sex) THEN + ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ] + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), -1.0_dp, rtbse_env%rho_ao_scratch(ispin)) + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), & + rtbse_env%sigma_SEX(ispin), ispin) + CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%sigma_SEX(ispin), L_drho_out, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), ispin) + END IF + + CALL timestop(handle) + END SUBROUTINE apply_liouvillian_to_drho_spin + +! ************************************************************************************************** +!> \brief Adds the MO-domain kernel contribution K_MO * Delta rho to L_drho_out, branching on +!> rtbse_env%tda_active. TDA: masks K_MO to OV in place, adds scale*K_MO on OV, then +!> builds the VO contribution as (K_MO_OV)^C and adds it (valid only under the TDA +!> assumption Delta rho_VO = (Delta rho_OV)^C). ABBA: adds the full mo_active x mo_active +!> K_MO directly - OV+VO blocks are computed naturally from the full OV+VO input. +!> K_MO is INTENT(INOUT); in the TDA branch it is masked in place (treat as scratch +!> after this call). rho_delta_mo(ispin) is used as the VO-transpose scratch in the TDA +!> branch (NOT drho_probe, which the open-shell array driver keeps as the live probe). +!> \param rtbse_env RT-BSE environment. +!> \param K_MO Kernel contribution in MO basis (mo_active x mo_active). Scratched in TDA branch. +!> \param L_drho_out Accumulator (mo_active x mo_active). +!> \param scale Complex scale factor (spin_degeneracy for Hartree, 1.0 for SX). +!> \param ispin Spin index. +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** + SUBROUTINE add_K_MO_to_L_drho(rtbse_env, K_MO, L_drho_out, scale, ispin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), INTENT(INOUT) :: K_MO, L_drho_out + COMPLEX(kind=dp), INTENT(IN) :: scale + INTEGER, INTENT(IN) :: ispin + + CHARACTER(len=*), PARAMETER :: routineN = 'add_K_MO_to_L_drho' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + IF (rtbse_env%tda_active) THEN + CALL mask_mo_block_cfm(rtbse_env, K_MO, ispin, keep_OV=.TRUE.) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out, scale, K_MO) + CALL cp_cfm_transpose(K_MO, 'C', rtbse_env%rho_delta_mo(ispin)) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out, scale, rtbse_env%rho_delta_mo(ispin)) + ELSE + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out, scale, K_MO) + END IF + + CALL timestop(handle) + END SUBROUTINE add_K_MO_to_L_drho + +! ************************************************************************************************** +!> \brief Open-shell TDA Liouvillian matvec: apply the joint spin-block L_TDA to a per-spin probe +!> and return L * Delta rho on every spin block. A probe on spin sigma feeds the diagonal +!> block A^{sigma,sigma} (eps + Coulomb + SX) AND the off-diagonal Coulomb block +!> A^{sigma',sigma} for every other output spin sigma' (cross-spin Hartree - the term that +!> produces the singlet/triplet split). AO-RI only: the Phase-D guard forbids RIRS +!> for n_spin>1, so there is no RIRS branch here; the n_spin=1 diagnostic routes +!> through apply_liouvillian_to_drho_spin instead (which keeps the RIRS path). +!> \param rtbse_env RT-BSE environment (TDA). +!> \param drho_in Per-spin probe Delta rho_MO (mo_active x mo_active each); zero on non-probed spins. +!> \param L_drho_out Per-spin output L * Delta rho; OV+VO blocks populated, OO/VV zero. +!> \author Maximilian Graml +! ************************************************************************************************** + SUBROUTINE apply_liouvillian_to_drho(rtbse_env, drho_in, L_drho_out) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: drho_in, L_drho_out + + CHARACTER(len=*), PARAMETER :: routineN = 'apply_liouvillian_to_drho' + + INTEGER :: abs_mo_idx, handle, i_row_global, ii, & + isp, isp_out, j_col_global, jj, & + ncol_local, nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: use_hartree, use_sex + + CALL timeset(routineN, handle) + + use_hartree = .NOT. rtbse_env%debug_disable_hartree + use_sex = .NOT. rtbse_env%debug_disable_sex + + ! Zero every output spin block before accumulating. + DO isp = 1, rtbse_env%n_spin + CALL cp_cfm_set_all(L_drho_out(isp), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + + ! eps^sigma commutator -> diagonal block only (eps is spin-diagonal). MUST precede the + ! kernel steps (add_K_MO_to_L_drho scratches MO buffers). Lab-frame bare GW eigenvalues + ! so they compare 1:1 to bse_full_diag.F. + CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + DO isp = 1, rtbse_env%n_spin + CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) + DO ii = 1, nrow_local + i_row_global = row_indices(ii) + DO jj = 1, ncol_local + j_col_global = col_indices(jj) + IF (i_row_global == j_col_global) THEN + abs_mo_idx = i_row_global + rtbse_env%first_active_mo - 1 + rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & + rtbse_env%bs_env%eigenval_G0W0(abs_mo_idx, 1, isp) + END IF + END DO + END DO + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & + mtarget=rtbse_env%ham_workspace(1)) + ! [drho, H_eps] = drho * H_eps - H_eps * drho + CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), drho_in(isp), rtbse_env%ham_workspace(1), & + CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out(isp)) + CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1), drho_in(isp), & + CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out(isp)) + END DO + + ! Project per-spin OV-masked rho_ao(sigma) (consumed by SX) and build the single cross-spin + ! Hartree V_H[spin_degeneracy * sum_sigma rho_ao(sigma)] (Coulomb is spin-blind). + ! build_shared_hartree_ao does both; skip only when neither kernel is active. + IF (use_hartree .OR. use_sex) THEN + CALL build_shared_hartree_ao(rtbse_env, drho_in, keep_ovvo=.FALSE.) + END IF + + ! Hartree: the one shared V_H read back with each output spin's C fills the diagonal + ! A^{sigma,sigma} AND the off-diagonal A^{sigma',sigma}. Coeff 1.0 (spin_degeneracy lives in + ! the summed density); no (f_n - f_m) factor (Casida +K convention). + IF (use_hartree) THEN + DO isp_out = 1, rtbse_env%n_spin + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & + rtbse_env%ham_workspace(1), isp_out) + CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%ham_workspace(1), L_drho_out(isp_out), & + CMPLX(1.0_dp, 0.0_dp, kind=dp), isp_out) + END DO + END IF + + ! Screened exchange: spin-diagonal (W^sigma acts only within spin sigma). get_sigma builds + ! -W; add raw +1 (no occupation-factor flip), giving K^SX = -W. + IF (use_sex) THEN + DO isp = 1, rtbse_env%n_spin + ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ] (per spin) + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(isp), -1.0_dp, rtbse_env%rho_ao_scratch(isp)) + CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(isp), & + rtbse_env%sigma_SEX(isp), isp) + CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%sigma_SEX(isp), L_drho_out(isp), & + CMPLX(1.0_dp, 0.0_dp, kind=dp), isp) + END DO + END IF + + CALL timestop(handle) + END SUBROUTINE apply_liouvillian_to_drho + +! ************************************************************************************************** +!> \brief Public entry for the Liouvillian eigenvalue diagnostic. +!> Dispatches to the TDA branch (Casida-A via cp_cfm_heevd) or the ABBA branch +!> (Furche reduction via cp_cfm_power) based on rtbse_env%tda_active. +!> Called once at job init from run_propagation_linearized_bse, gated on +!> rtbse_env%diagnose_liouvillian_eig (n_spin = 1 enforced at env creation). +!> \param rtbse_env RT-BSE environment with diagnostic scratch already allocated. +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** + SUBROUTINE diagnose_liouvillian_eigenvalues(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'diagnose_liouvillian_eigenvalues' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + IF (rtbse_env%tda_active) THEN + CALL diagnose_TDA_liouvillian(rtbse_env) + ELSE + CALL diagnose_ABBA_liouvillian(rtbse_env) + END IF + + CALL timestop(handle) + END SUBROUTINE diagnose_liouvillian_eigenvalues + +! ************************************************************************************************** +!> \brief TDA branch of the Liouvillian eigenvalue diagnostic. Probes the Liouvillian with +!> canonical OV unit vectors and assembles the joint spin-block Casida-A matrix as L_pairs +!> (N_OV_joint x N_OV_joint, spin blocks stacked), then diagonalizes via cp_cfm_heevd. +!> A probe on spin sigma fills its column block and the response on every output spin lands +!> in that spin's row block (the off-diagonal blocks carry the cross-spin Coulomb that +!> splits singlet/triplet). The matvec is dispatched on n_spin: n_spin=1 uses the +!> single-spin apply_liouvillian_to_drho_spin (keeps the RIRS path, bit-identical to the +!> closed-shell baseline); n_spin=2 uses the AO-RI array apply_liouvillian_to_drho. +!> Eigenvalues go to stdout (RTBSE|) and to the LIOUVILLIAN_EIG .dat file. Detached from +!> RK4 state. Called from the dispatcher when tda_active=.TRUE. +!> \param rtbse_env RT-BSE environment with TDA diagnostic scratch already allocated. +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** + SUBROUTINE diagnose_TDA_liouvillian(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'diagnose_TDA_liouvillian' + + COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: ov_block + INTEGER :: b, eig_unit, handle, j, k_col, k_local, & + n, n_ov_joint, sigma_out, sigma_probe + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_act_occ, n_act_virt, n_ov, off + REAL(kind=dp) :: residual_max + TYPE(cp_logger_type), POINTER :: logger + + CALL timeset(routineN, handle) + logger => cp_get_default_logger() + + ! Per-spin OV counts + offsets into the stacked joint Liouvillian. off(1)=0, + ! off(2)=n_ov(1); n_ov_joint = sum_sigma n_ov(sigma). n_spin=1 -> single block. + ALLOCATE (n_act_occ(rtbse_env%n_spin), n_act_virt(rtbse_env%n_spin), & + n_ov(rtbse_env%n_spin), off(rtbse_env%n_spin)) + n_ov_joint = 0 + DO sigma_probe = 1, rtbse_env%n_spin + n_act_occ(sigma_probe) = rtbse_env%n_occ(sigma_probe) - rtbse_env%first_active_mo + 1 + n_act_virt(sigma_probe) = rtbse_env%last_active_mo - rtbse_env%n_occ(sigma_probe) + n_ov(sigma_probe) = n_act_occ(sigma_probe)*n_act_virt(sigma_probe) + off(sigma_probe) = n_ov_joint + n_ov_joint = n_ov_joint + n_ov(sigma_probe) + END DO + + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE| ----- TDA Liouvillian diagnostic -----' + WRITE (rtbse_env%unit_nr, '(A,I0,A,I0)') & + ' RTBSE| n_spin = ', rtbse_env%n_spin, ', joint N_OV = ', n_ov_joint + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' + END IF + + ! Single joint block to the .dat file (REWIND). ignore_should_output=.TRUE. so this fires + ! at init regardless of MD-iteration cadence. + eig_unit = cp_print_key_unit_nr(logger, rtbse_env%eig_section, & + extension=".dat", & + file_form="FORMATTED", & + file_position="REWIND", & + ignore_should_output=.TRUE.) + IF (eig_unit > 0) THEN + WRITE (eig_unit, '(A)') '# Joint spin-block TDA Liouvillian eigenvalues' + IF (rtbse_env%n_spin == 1) THEN + WRITE (eig_unit, '(A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, ', N_OV = ', n_ov(1) + ELSE + WRITE (eig_unit, '(A,I0,A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, & + ', N_OV(1) = ', n_ov(1), ', N_OV(2) = ', n_ov(2) + END IF + END IF + + ! Assemble the joint Casida-A matrix. A probe on spin sigma_probe with canonical OV unit + ! vector e_{(j,b)} fills column off(sigma_probe)+k_local; the response on each output spin + ! sigma_out lands in its row block [off(sigma_out)+1 .. +n_ov(sigma_out)]. Block-level + ! transfers keep this at O(N_OV_joint) collective ops. Column-major OV index + ! k_local = (b_local-1)*n_act_occ + j_local matches the Fortran layout of ov_block, so + ! RESHAPE without padding gives the right (n_ov, 1) column. + DO sigma_probe = 1, rtbse_env%n_spin + DO b = rtbse_env%n_occ(sigma_probe) + 1, rtbse_env%last_active_mo + DO j = rtbse_env%first_active_mo, rtbse_env%n_occ(sigma_probe) + k_local = (b - rtbse_env%n_occ(sigma_probe) - 1)*n_act_occ(sigma_probe) + & + (j - rtbse_env%first_active_mo + 1) + k_col = off(sigma_probe) + k_local + + DO sigma_out = 1, rtbse_env%n_spin + CALL cp_cfm_set_all(rtbse_env%drho_probe(sigma_out), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + CALL cp_cfm_set_element(rtbse_env%drho_probe(sigma_probe), & + j - rtbse_env%first_active_mo + 1, & + b - rtbse_env%first_active_mo + 1, & + CMPLX(1.0_dp, 0.0_dp, kind=dp)) + + ! n_spin=1 keeps the single-spin matvec (RIRS-capable, bit-identical baseline); + ! n_spin=2 is AO-RI-only (Phase-D guard) -> cross-spin array matvec. + IF (rtbse_env%n_spin == 1) THEN + CALL apply_liouvillian_to_drho_spin(rtbse_env, rtbse_env%drho_probe(1), & + rtbse_env%L_drho(1), 1) + ELSE + CALL apply_liouvillian_to_drho(rtbse_env, rtbse_env%drho_probe, rtbse_env%L_drho) + END IF + + ! Stack each output spin's OV response into the joint column. + DO sigma_out = 1, rtbse_env%n_spin + ALLOCATE (ov_block(n_act_occ(sigma_out), n_act_virt(sigma_out))) + CALL cp_cfm_get_submatrix(rtbse_env%L_drho(sigma_out), ov_block, & + start_row=1, start_col=n_act_occ(sigma_out) + 1, & + n_rows=n_act_occ(sigma_out), n_cols=n_act_virt(sigma_out)) + CALL cp_cfm_set_submatrix(rtbse_env%L_pairs, & + RESHAPE(ov_block, [n_ov(sigma_out), 1]), & + start_row=off(sigma_out) + 1, start_col=k_col, & + n_rows=n_ov(sigma_out), n_cols=1) + DEALLOCATE (ov_block) + END DO + END DO + END DO + END DO + + ! Hermitian residual on the joint matrix: real-orbital BSE => L real symmetric, so + ! ||L - L^H||_max should be at the FP floor. D = L^H - L into eigvecs_pairs (idle here; + ! heevd overwrites it), then its max-element norm via the BLACS-native pzlange path. + CALL cp_cfm_transpose(rtbse_env%L_pairs, 'C', rtbse_env%eigvecs_pairs) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%eigvecs_pairs, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%L_pairs) + residual_max = cp_cfm_norm(rtbse_env%eigvecs_pairs, 'M') + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A,ES16.6)') & + ' RTBSE| Hermitian residual ||L - L^H||_max = ', residual_max + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' + END IF + IF (residual_max > 1.0E-6_dp) THEN + CPABORT("Liouvillian Hermitian residual > 1e-6 - check kernel signs / symmetry.") + END IF + + ! Diagonalize the joint matrix. cp_cfm_heevd returns ascending real eigenvalues. + CALL cp_cfm_heevd(rtbse_env%L_pairs, rtbse_env%eigvecs_pairs, & + rtbse_env%eigenvalues_liouvillian) + + ! Stdout table (eV, F12.4 right-aligned to col 80, L-7) + .dat (a.u. + eV). + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A,T26,A,T59,A)') & + ' RTBSE|', "Excitation index n", "Excitation energy (eV)" + DO n = 1, n_ov_joint + WRITE (rtbse_env%unit_nr, '(A,T40,I4,T69,F12.4)') & + ' RTBSE|', n, rtbse_env%eigenvalues_liouvillian(n)*evolt + END DO + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' + END IF + IF (eig_unit > 0) THEN + WRITE (eig_unit, '(A)') '# n Omega [a.u.] Omega [eV]' + DO n = 1, n_ov_joint + WRITE (eig_unit, '(I5,4X,ES24.14E3,4X,ES24.14E3)') n, & + rtbse_env%eigenvalues_liouvillian(n), & + rtbse_env%eigenvalues_liouvillian(n)*evolt + END DO + END IF + + CALL cp_print_key_finished_output(eig_unit, logger, rtbse_env%eig_section) + + DEALLOCATE (n_act_occ, n_act_virt, n_ov, off) + + CALL timestop(handle) + END SUBROUTINE diagnose_TDA_liouvillian + +! ************************************************************************************************** +!> \brief ABBA branch of the Liouvillian eigenvalue diagnostic. Assembles the joint spin-block +!> A and B by probing apply_liouvillian_to_drho with canonical OV unit vectors: a probe on +!> spin sigma_probe fills joint column off(sigma_probe)+k_local; each output spin's OV +!> response -> A, VO response -> -B^* (recovered by sign-flip + conjugation). One joint +!> Furche reduction follows: (A-B)>0 gate (independent cp_cfm_heevd), (A-B)^{1/2} via +!> cp_cfm_power, C = (A-B)^{1/2}(A+B)(A-B)^{1/2}, cp_cfm_heevd, Ω_n = √(C). The +!> matvec is dispatched on n_spin: n_spin=1 -> apply_liouvillian_to_drho_spin (RIRS-capable, +!> bit-identical to the closed-shell baseline); n_spin=2 -> the AO-RI cross-spin array +!> apply_liouvillian_to_drho. For n_spin=1 the routine reduces to the single-block path. +!> Output: a single joint spectrum (stdout RTBSE| + LIOUVILLIAN_EIG .dat). All eigenvalues +!> are retained, including optically dark triplet modes (the kernel-correctness gate). +!> \param rtbse_env RT-BSE environment with ABBA diagnostic scratch allocated. +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** + SUBROUTINE diagnose_ABBA_liouvillian(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'diagnose_ABBA_liouvillian' + + COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: ov_block, vo_block + COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: B_local + INTEGER :: b, eig_unit, handle, j, k_col, k_local, & + n, n_ov_joint, sigma_out, sigma_probe + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_act_occ, n_act_virt, n_ov, off + REAL(kind=dp) :: lambda_min_AmB, residual_A, residual_B + TYPE(cp_logger_type), POINTER :: logger + + CALL timeset(routineN, handle) + logger => cp_get_default_logger() + + ! Per-spin OV counts + offsets into the stacked joint A/B (same layout as the TDA + ! diagnostic). off(1)=0, off(2)=n_ov(1); n_ov_joint = sum_sigma n_ov(sigma). For + ! n_spin=1 this is the single block, bit-identical to the closed-shell ABBA path. + ALLOCATE (n_act_occ(rtbse_env%n_spin), n_act_virt(rtbse_env%n_spin), & + n_ov(rtbse_env%n_spin), off(rtbse_env%n_spin)) + n_ov_joint = 0 + DO sigma_probe = 1, rtbse_env%n_spin + n_act_occ(sigma_probe) = rtbse_env%n_occ(sigma_probe) - rtbse_env%first_active_mo + 1 + n_act_virt(sigma_probe) = rtbse_env%last_active_mo - rtbse_env%n_occ(sigma_probe) + n_ov(sigma_probe) = n_act_occ(sigma_probe)*n_act_virt(sigma_probe) + off(sigma_probe) = n_ov_joint + n_ov_joint = n_ov_joint + n_ov(sigma_probe) + END DO + + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE| ----- ABBA Liouvillian diagnostic -----' + WRITE (rtbse_env%unit_nr, '(A,I0,A,I0)') & + ' RTBSE| n_spin = ', rtbse_env%n_spin, ', joint N_OV = ', n_ov_joint + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' + END IF + + eig_unit = cp_print_key_unit_nr(logger, rtbse_env%eig_section, & + extension=".dat", & + file_form="FORMATTED", & + file_position="REWIND", & + ignore_should_output=.TRUE.) + IF (eig_unit > 0) THEN + WRITE (eig_unit, '(A)') '# Joint spin-block ABBA Liouvillian eigenvalues' + IF (rtbse_env%n_spin == 1) THEN + WRITE (eig_unit, '(A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, ', N_OV = ', n_ov(1) + ELSE + WRITE (eig_unit, '(A,I0,A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, & + ', N_OV(1) = ', n_ov(1), ', N_OV(2) = ', n_ov(2) + END IF + END IF + + ! Assemble joint A and B. Probe on spin sigma_probe, OV pair (j,b) -> joint column + ! k_col = off(sigma_probe)+k_local (column-major k_local, as TDA). Each output spin's + ! OV response -> A rows [off(sigma_out)+1 ..]; VO response -> B rows (TRANSPOSE to OV + ! layout), recovered as -B^* below. The n_spin=2 array matvec produces the full OV+VO + ! readout (add_K_MO_to_L_drho .NOT.tda_active branch); one cross-spin Hartree fills + ! both A^{s,s'} and B^{s,s'} Coulomb; SX stays spin-diagonal. + DO sigma_probe = 1, rtbse_env%n_spin + DO b = rtbse_env%n_occ(sigma_probe) + 1, rtbse_env%last_active_mo + DO j = rtbse_env%first_active_mo, rtbse_env%n_occ(sigma_probe) + k_local = (b - rtbse_env%n_occ(sigma_probe) - 1)*n_act_occ(sigma_probe) + & + (j - rtbse_env%first_active_mo + 1) + k_col = off(sigma_probe) + k_local + + DO sigma_out = 1, rtbse_env%n_spin + CALL cp_cfm_set_all(rtbse_env%drho_probe(sigma_out), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + CALL cp_cfm_set_element(rtbse_env%drho_probe(sigma_probe), & + j - rtbse_env%first_active_mo + 1, & + b - rtbse_env%first_active_mo + 1, & + CMPLX(1.0_dp, 0.0_dp, kind=dp)) + + IF (rtbse_env%n_spin == 1) THEN + CALL apply_liouvillian_to_drho_spin(rtbse_env, rtbse_env%drho_probe(1), & + rtbse_env%L_drho(1), 1) + ELSE + CALL apply_liouvillian_to_drho(rtbse_env, rtbse_env%drho_probe, rtbse_env%L_drho) + END IF + + DO sigma_out = 1, rtbse_env%n_spin + ALLOCATE (ov_block(n_act_occ(sigma_out), n_act_virt(sigma_out))) + ALLOCATE (vo_block(n_act_virt(sigma_out), n_act_occ(sigma_out))) + CALL cp_cfm_get_submatrix(rtbse_env%L_drho(sigma_out), ov_block, & + start_row=1, start_col=n_act_occ(sigma_out) + 1, & + n_rows=n_act_occ(sigma_out), n_cols=n_act_virt(sigma_out)) + CALL cp_cfm_set_submatrix(rtbse_env%A_mat, & + RESHAPE(ov_block, [n_ov(sigma_out), 1]), & + start_row=off(sigma_out) + 1, start_col=k_col, & + n_rows=n_ov(sigma_out), n_cols=1) + ! TRANSPOSE puts vo_block in (n_act_occ, n_act_virt) layout, matching the OV pack. + CALL cp_cfm_get_submatrix(rtbse_env%L_drho(sigma_out), vo_block, & + start_row=n_act_occ(sigma_out) + 1, start_col=1, & + n_rows=n_act_virt(sigma_out), n_cols=n_act_occ(sigma_out)) + CALL cp_cfm_set_submatrix(rtbse_env%B_mat, & + RESHAPE(TRANSPOSE(vo_block), [n_ov(sigma_out), 1]), & + start_row=off(sigma_out) + 1, start_col=k_col, & + n_rows=n_ov(sigma_out), n_cols=1) + DEALLOCATE (ov_block, vo_block) + END DO + END DO + END DO + END DO + + ! Recover B from -B^* via rank-local pass on the cfm's MPI-local data (documented + ! exception to the fm/cfm-routines-only rule); B_recovered = -CONJG(stored). + B_local => rtbse_env%B_mat%local_data + B_local = -CONJG(B_local) + + ! Block-symmetry residuals on the JOINT matrices: A Hermitian, B real-symmetric. + CALL cp_cfm_transpose(rtbse_env%A_mat, 'C', rtbse_env%eigvecs_pairs) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%eigvecs_pairs, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%A_mat) + residual_A = cp_cfm_norm(rtbse_env%eigvecs_pairs, 'M') + + CALL cp_cfm_transpose(rtbse_env%B_mat, 'T', rtbse_env%eigvecs_pairs) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%eigvecs_pairs, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%B_mat) + residual_B = cp_cfm_norm(rtbse_env%eigvecs_pairs, 'M') + + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A,ES16.6)') & + ' RTBSE| Hermitian residual ||A - A^H||_max = ', residual_A + WRITE (rtbse_env%unit_nr, '(A,ES16.6)') & + ' RTBSE| Symmetry residual ||B - B^T||_max = ', residual_B + END IF + IF (residual_A > 1.0E-6_dp) THEN + CPABORT("A is not Hermitian within 1e-6 - check kernel signs / symmetry.") + END IF + IF (residual_B > 1.0E-6_dp) THEN + CPABORT("B is not symmetric within 1e-6 - check kernel signs / symmetry.") + END IF + + ! A +/- B in scratches (both Hermitian). + CALL cp_cfm_to_cfm(rtbse_env%A_mat, rtbse_env%AmB_scratch) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%AmB_scratch, & + CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%B_mat) + CALL cp_cfm_to_cfm(rtbse_env%A_mat, rtbse_env%ApB_scratch) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%ApB_scratch, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%B_mat) + + ! (A-B) positivity gate on the joint matrix: heevd on a copy; abort if lambda_min < 0. + CALL cp_cfm_to_cfm(rtbse_env%AmB_scratch, rtbse_env%L_pairs) + CALL cp_cfm_heevd(rtbse_env%L_pairs, rtbse_env%eigvecs_pairs, rtbse_env%eigenvalues_liouvillian) + lambda_min_AmB = rtbse_env%eigenvalues_liouvillian(1) + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A,ES16.6,A,F12.6,A)') & + ' RTBSE| lambda_min(A - B) = ', & + lambda_min_AmB, ' a.u. (', lambda_min_AmB*evolt, ' eV)' + END IF + ! Hard abort by design: a non-positive (A-B) breaks the Furche reduction. + IF (lambda_min_AmB < 0.0_dp) THEN + CALL cp_abort(__LOCATION__, & + "(A - B) not positive definite - this may hint at a triplet or "// & + "charge-transfer instability of the reference state.") + END IF + + ! In-place AmB_scratch -> (A-B)^{1/2} via cp_cfm_power. threshold=0 substitution + ! codepath is unreachable here (lambda_min_AmB > 0 already enforced above). + CALL cp_cfm_power(rtbse_env%AmB_scratch, threshold=0.0_dp, exponent=0.5_dp) + + ! C = (A-B)^{1/2}(A+B)(A-B)^{1/2}. B_mat free after step "A+/-B" -> reuse as T scratch. + CALL cp_cfm_gemm('N', 'N', n_ov_joint, n_ov_joint, n_ov_joint, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), & + rtbse_env%AmB_scratch, rtbse_env%ApB_scratch, & + CMPLX(0.0_dp, 0.0_dp, kind=dp), & + rtbse_env%B_mat) + CALL cp_cfm_gemm('N', 'N', n_ov_joint, n_ov_joint, n_ov_joint, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), & + rtbse_env%B_mat, rtbse_env%AmB_scratch, & + CMPLX(0.0_dp, 0.0_dp, kind=dp), & + rtbse_env%L_pairs) + + ! Diagonalize C -> Ω_n^2; take +√. Safety clamp on tiny-negative noise. + CALL cp_cfm_heevd(rtbse_env%L_pairs, rtbse_env%eigvecs_pairs, rtbse_env%eigenvalues_liouvillian) + DO n = 1, n_ov_joint + IF (rtbse_env%eigenvalues_liouvillian(n) < 0.0_dp) THEN + rtbse_env%eigenvalues_liouvillian(n) = 0.0_dp + ELSE + rtbse_env%eigenvalues_liouvillian(n) = SQRT(rtbse_env%eigenvalues_liouvillian(n)) + END IF + END DO + + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' + WRITE (rtbse_env%unit_nr, '(A,T26,A,T59,A)') & + ' RTBSE|', "Excitation index n", "Excitation energy (eV)" + DO n = 1, n_ov_joint + WRITE (rtbse_env%unit_nr, '(A,T40,I4,T69,F12.4)') & + ' RTBSE|', n, rtbse_env%eigenvalues_liouvillian(n)*evolt + END DO + WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' + END IF + IF (eig_unit > 0) THEN + WRITE (eig_unit, '(A)') '# n Omega [a.u.] Omega [eV]' + DO n = 1, n_ov_joint + WRITE (eig_unit, '(I5,4X,ES24.14E3,4X,ES24.14E3)') n, & + rtbse_env%eigenvalues_liouvillian(n), & + rtbse_env%eigenvalues_liouvillian(n)*evolt + END DO + END IF + + CALL cp_print_key_finished_output(eig_unit, logger, rtbse_env%eig_section) + + DEALLOCATE (n_act_occ, n_act_virt, n_ov, off) + + CALL timestop(handle) + END SUBROUTINE diagnose_ABBA_liouvillian + +! ************************************************************************************************** +!> \brief Covariant AO->MO transform of an operator (real): M^MO_mn = sum_µν C_µm M^AO_µν C_νn. +!> For operator-like kernels (Σ^SX, V^H); the density uses the contravariant routine. +!> \param rtbse_env Entry point of the calculation - contains current state of variables +!> \param fm_ao operator in the AO basis (n_ao x n_ao), input +!> \param fm_mo operator in the active-MO basis (mo_active x mo_active), output +!> \param i_spin spin channel σ; selects C_active(σ) +! ************************************************************************************************** + SUBROUTINE transform_ao_to_mo_covariant_fm(rtbse_env, fm_ao, fm_mo, i_spin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_fm_type) :: fm_ao, fm_mo + INTEGER, INTENT(IN) :: i_spin + + CHARACTER(len=*), PARAMETER :: routineN = 'transform_ao_to_mo_covariant_fm' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + ! step 1: T_µn = sum_ν M^AO_µν C_νn (n_ao x mo_active) + CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, fm_ao, rtbse_env%C_active(i_spin), & + 0.0_dp, rtbse_env%ao_mo_workspace(1)) + ! step 2: M^MO_mn = sum_µ C_µm T_µn (mo_active x mo_active) + CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%ao_mo_workspace(1), & + 0.0_dp, fm_mo) + + CALL timestop(handle) + END SUBROUTINE transform_ao_to_mo_covariant_fm + +! ************************************************************************************************** +!> \brief Covariant AO->MO transform (complex): M^MO_mn = sum_µν C_µm M^AO_µν C_νn, applied to the +!> real and imaginary AO parts separately (2x the real cost). +!> \param rtbse_env Entry point of the calculation - contains current state of variables +!> \param fm_ao operator in the AO basis (n_ao x n_ao) cfm, input +!> \param fm_mo operator in the active-MO basis (mo_active x mo_active) cfm, output +!> \param i_spin spin channel σ; selects C_active(σ) +! ************************************************************************************************** + SUBROUTINE transform_ao_to_mo_covariant_cfm(rtbse_env, fm_ao, fm_mo, i_spin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type) :: fm_ao, fm_mo + INTEGER, INTENT(IN) :: i_spin + + CHARACTER(len=*), PARAMETER :: routineN = 'transform_ao_to_mo_covariant_cfm' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + ! Decompose into real/imag AO-sized parts + CALL cp_cfm_to_fm(msource=fm_ao, mtargetr=rtbse_env%real_workspace(1), & + mtargeti=rtbse_env%real_workspace(2)) + ! Re(M^MO)_mn = sum_µν C_µm Re(M^AO)_µν C_νn (two gemms via ao_mo_workspace) + CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%real_workspace(1), rtbse_env%C_active(i_spin), & + 0.0_dp, rtbse_env%ao_mo_workspace(1)) + CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%ao_mo_workspace(1), & + 0.0_dp, rtbse_env%real_workspace_mo(1)) + ! Im(M^MO)_mn = sum_µν C_µm Im(M^AO)_µν C_νn + CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%real_workspace(2), rtbse_env%C_active(i_spin), & + 0.0_dp, rtbse_env%ao_mo_workspace(1)) + CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%ao_mo_workspace(1), & + 0.0_dp, rtbse_env%real_workspace_mo(2)) + ! Reassemble into MO-sized cfm + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & + msourcei=rtbse_env%real_workspace_mo(2), & + mtarget=fm_mo) + + CALL timestop(handle) + END SUBROUTINE transform_ao_to_mo_covariant_cfm + +! ************************************************************************************************** +!> \brief Contravariant MO->AO transform of the density (complex): Δρ^AO_µν = sum_mn C_µm Δρ^MO_mn C_νn. +!> Density-like (expands MO indices), unlike the covariant operator transform. +!> \param rtbse_env Entry point of the calculation - contains current state of variables +!> \param fm_mo density in the active-MO basis (mo_active x mo_active) cfm, input +!> \param fm_ao density in the AO basis (n_ao x n_ao) cfm, output +!> \param i_spin spin channel σ; selects C_active(σ) +! ************************************************************************************************** + SUBROUTINE transform_mo_to_ao_contravariant_cfm(rtbse_env, fm_mo, fm_ao, i_spin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type) :: fm_mo, fm_ao + INTEGER, INTENT(IN) :: i_spin + + CHARACTER(len=*), PARAMETER :: routineN = 'transform_mo_to_ao_contravariant_cfm' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + ! Re/Im split of Δρ^MO (mo_active x mo_active) into persistent MO-sized scratch + CALL cp_cfm_to_fm(msource=fm_mo, mtargetr=rtbse_env%real_workspace_mo(1), & + mtargeti=rtbse_env%real_workspace_mo(2)) + ! Re(Δρ^AO)_µν = sum_mn C_µm Re(Δρ^MO)_mn C_νn (C·ρ via ao_mo_workspace, then ·C^T) + CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%mo_active, & + 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%real_workspace_mo(1), & + 0.0_dp, rtbse_env%ao_mo_workspace(1)) + CALL parallel_gemm("N", "T", rtbse_env%n_ao, rtbse_env%n_ao, rtbse_env%mo_active, & + 1.0_dp, rtbse_env%ao_mo_workspace(1), rtbse_env%C_active(i_spin), & + 0.0_dp, rtbse_env%real_workspace(1)) + ! Im(Δρ^AO)_µν = sum_mn C_µm Im(Δρ^MO)_mn C_νn + CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%mo_active, & + 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%real_workspace_mo(2), & + 0.0_dp, rtbse_env%ao_mo_workspace(1)) + CALL parallel_gemm("N", "T", rtbse_env%n_ao, rtbse_env%n_ao, rtbse_env%mo_active, & + 1.0_dp, rtbse_env%ao_mo_workspace(1), rtbse_env%C_active(i_spin), & + 0.0_dp, rtbse_env%real_workspace(2)) + ! Reassemble into AO-sized cfm + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(1), & + msourcei=rtbse_env%real_workspace(2), mtarget=fm_ao) + + CALL timestop(handle) + END SUBROUTINE transform_mo_to_ao_contravariant_cfm + +! ************************************************************************************************** +!> \brief Scales each MO-active element (m,n) by the occupation prefactor (f_n - f_m), f in {0,1} +!> (complex): OV -> -1, VO -> +1, OO/VV -> 0. The only trace of "ρ^0 diagonal in MO". +!> Applied to whatever kernel the caller passes (Σ^SX, V^H in MO) - bound by the caller. +!> \param rtbse_env Entry point of the calculation - contains current state of variables +!> \param cfm MO-active kernel matrix (mo_active x mo_active) cfm, scaled in place +!> \param i_spin spin channel σ; OV/VO boundary set by n_occ(σ) +! ************************************************************************************************** + SUBROUTINE transform_mo_occupation_factor_diff_cfm(rtbse_env, cfm, i_spin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type) :: cfm + INTEGER :: i_spin + + CHARACTER(len=*), PARAMETER :: routineN = 'transform_mo_occupation_factor_diff_cfm' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL cp_cfm_to_fm(msource=cfm, mtargetr=rtbse_env%real_workspace_mo(1), & + mtargeti=rtbse_env%real_workspace_mo(2)) + ! (f_n - f_m) applied to the real part + CALL transform_mo_occupation_factor_diff_fm(rtbse_env, rtbse_env%real_workspace_mo(1), i_spin) + ! (f_n - f_m) applied to the imaginary part + CALL transform_mo_occupation_factor_diff_fm(rtbse_env, rtbse_env%real_workspace_mo(2), i_spin) + ! Copy back to cfm + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & + msourcei=rtbse_env%real_workspace_mo(2), & + mtarget=cfm) + + CALL timestop(handle) + END SUBROUTINE transform_mo_occupation_factor_diff_cfm + +! ************************************************************************************************** +!> \brief Scales each MO-active element (m,n) by the occupation prefactor (f_n - f_m), f in {0,1} +!> (real): OV -> -1, VO -> +1, OO/VV -> 0. Real-input worker for the cfm variant; the only +!> trace of "ρ^0 diagonal in MO". Bound by the caller to the kernel being scaled. +!> \param rtbse_env Entry point of the calculation - contains current state of variables +!> \param fm MO-active kernel matrix (mo_active x mo_active) fm, scaled in place +!> \param i_spin spin channel σ; OV/VO boundary set by n_occ(σ) +! ************************************************************************************************** + SUBROUTINE transform_mo_occupation_factor_diff_fm(rtbse_env, fm, i_spin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_fm_type) :: fm + INTEGER :: i_spin + + CHARACTER(len=*), PARAMETER :: routineN = 'transform_mo_occupation_factor_diff_fm' + + INTEGER :: handle, i_global, i_global_mo, i_local, & + j_global, j_global_mo, j_local, n_occ, & + ncol_local, nrow_local, shift + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + REAL(kind=dp) :: occ_factor + REAL(kind=dp), DIMENSION(:, :), POINTER :: local_data + + CALL timeset(routineN, handle) + + n_occ = rtbse_env%n_occ(i_spin) + ! Shift mapping local active-window index to absolute MO index + shift = rtbse_env%first_active_mo - 1 + + CALL cp_fm_get_info(matrix=fm, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + + local_data => fm%local_data + + DO i_local = 1, nrow_local + i_global = row_indices(i_local) + i_global_mo = i_global + shift + DO j_local = 1, ncol_local + j_global = col_indices(j_local) + j_global_mo = j_global + shift + + IF (i_global_mo <= n_occ .AND. j_global_mo > n_occ) THEN + occ_factor = -1.0_dp + ELSE IF (i_global_mo > n_occ .AND. j_global_mo <= n_occ) THEN + occ_factor = 1.0_dp + ELSE + occ_factor = 0.0_dp + END IF + + local_data(i_local, j_local) = occ_factor*local_data(i_local, j_local) + END DO + END DO + + CALL timestop(handle) + END SUBROUTINE transform_mo_occupation_factor_diff_fm + +! ************************************************************************************************** +!> \brief Mask an MO-active cfm: keep either OV or VO block, zero everything else. +!> \param rtbse_env RT-BSE environment +!> \param cfm MO-active cfm to mask in place +!> \param i_spin Spin index +!> \param keep_OV .TRUE. keeps the (occ row, virt col) block; .FALSE. keeps (virt row, occ col) +!> \param keep_ovvo if present and .TRUE., keep BOTH off-diagonal blocks (OV and VO) and zero +!> OO/VV; overrides keep_OV. Absent/false reproduces the keep_OV behaviour. +! ************************************************************************************************** + SUBROUTINE mask_mo_block_cfm(rtbse_env, cfm, i_spin, keep_OV, keep_ovvo) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type) :: cfm + INTEGER, INTENT(IN) :: i_spin + LOGICAL, INTENT(IN) :: keep_OV + LOGICAL, INTENT(IN), OPTIONAL :: keep_ovvo + + CHARACTER(len=*), PARAMETER :: routineN = 'mask_mo_block_cfm' + + COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data + INTEGER :: handle, i_global, i_global_mo, i_local, & + j_global, j_global_mo, j_local, n_occ, & + ncol_local, nrow_local, shift + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: keep, l_keep_ovvo + + CALL timeset(routineN, handle) + + l_keep_ovvo = .FALSE. + IF (PRESENT(keep_ovvo)) l_keep_ovvo = keep_ovvo + + n_occ = rtbse_env%n_occ(i_spin) + shift = rtbse_env%first_active_mo - 1 + + CALL cp_cfm_get_info(matrix=cfm, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + + local_data => cfm%local_data + + DO i_local = 1, nrow_local + i_global = row_indices(i_local) + i_global_mo = i_global + shift + DO j_local = 1, ncol_local + j_global = col_indices(j_local) + j_global_mo = j_global + shift + IF (l_keep_ovvo) THEN + ! keep both off-diagonal blocks (OV and VO); drop OO/VV + keep = ((i_global_mo <= n_occ) .NEQV. (j_global_mo <= n_occ)) + ELSE IF (keep_OV) THEN + keep = (i_global_mo <= n_occ .AND. j_global_mo > n_occ) + ELSE + keep = (i_global_mo > n_occ .AND. j_global_mo <= n_occ) + END IF + IF (.NOT. keep) local_data(i_local, j_local) = CMPLX(0.0_dp, 0.0_dp, kind=dp) + END DO + END DO + + CALL timestop(handle) + END SUBROUTINE mask_mo_block_cfm + +! ************************************************************************************************** +!> \brief Mask an MO-active fm: keep either OV or VO block, zero everything else. +!> \param rtbse_env RT-BSE environment +!> \param fm MO-active fm to mask in place +!> \param i_spin Spin index +!> \param keep_OV .TRUE. keeps the (occ row, virt col) block; .FALSE. keeps (virt row, occ col) +! ************************************************************************************************** + SUBROUTINE mask_mo_block_fm(rtbse_env, fm, i_spin, keep_OV) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_fm_type) :: fm + INTEGER, INTENT(IN) :: i_spin + LOGICAL, INTENT(IN) :: keep_OV + + CHARACTER(len=*), PARAMETER :: routineN = 'mask_mo_block_fm' + + INTEGER :: handle, i_global, i_global_mo, i_local, & + j_global, j_global_mo, j_local, n_occ, & + ncol_local, nrow_local, shift + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: keep + REAL(kind=dp), DIMENSION(:, :), POINTER :: local_data + + CALL timeset(routineN, handle) + + n_occ = rtbse_env%n_occ(i_spin) + shift = rtbse_env%first_active_mo - 1 + + CALL cp_fm_get_info(matrix=fm, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + + local_data => fm%local_data + + DO i_local = 1, nrow_local + i_global = row_indices(i_local) + i_global_mo = i_global + shift + DO j_local = 1, ncol_local + j_global = col_indices(j_local) + j_global_mo = j_global + shift + IF (keep_OV) THEN + keep = (i_global_mo <= n_occ .AND. j_global_mo > n_occ) + ELSE + keep = (i_global_mo > n_occ .AND. j_global_mo <= n_occ) + END IF + IF (.NOT. keep) local_data(i_local, j_local) = 0.0_dp + END DO + END DO + + CALL timestop(handle) + END SUBROUTINE mask_mo_block_fm + +! ************************************************************************************************** +!> \brief Multiply a MO-active cfm rho by the TDA symmetric-shift rotation: +!> rho_OV *= exp(i * phase), rho_VO *= exp(-i * phase). +!> OO/VV blocks are left untouched. For direction='to_lab' pass phase = -Ω_0*t; +!> for direction='to_rotating' pass phase = +Ω_0*t. No-op when omega_shift = 0. +!> Preserves Hermiticity since the two phases are complex conjugates of each other. +!> \param rtbse_env RT-BSE environment +!> \param rho MO-active cfm rotated in place +!> \param i_spin Spin index +!> \param phase Real phase argument (radians); typically +/- Ω_0 * t +! ************************************************************************************************** + SUBROUTINE rotate_rho_phase(rtbse_env, rho, i_spin, phase) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type) :: rho + INTEGER, INTENT(IN) :: i_spin + REAL(kind=dp), INTENT(IN) :: phase + + CHARACTER(len=*), PARAMETER :: routineN = 'rotate_rho_phase' + + COMPLEX(kind=dp) :: phase_ov, phase_vo + COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data + INTEGER :: handle, i_global, i_global_mo, i_local, & + j_global, j_global_mo, j_local, n_occ, & + ncol_local, nrow_local, shift + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + + IF (rtbse_env%omega_shift == 0.0_dp) RETURN + + CALL timeset(routineN, handle) + + n_occ = rtbse_env%n_occ(i_spin) + shift = rtbse_env%first_active_mo - 1 + phase_ov = CMPLX(COS(phase), SIN(phase), kind=dp) + phase_vo = CONJG(phase_ov) + + CALL cp_cfm_get_info(matrix=rho, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + local_data => rho%local_data + + DO i_local = 1, nrow_local + i_global = row_indices(i_local) + i_global_mo = i_global + shift + DO j_local = 1, ncol_local + j_global = col_indices(j_local) + j_global_mo = j_global + shift + IF (i_global_mo <= n_occ .AND. j_global_mo > n_occ) THEN + ! ρ_OV *= e^{+iφ} + local_data(i_local, j_local) = phase_ov*local_data(i_local, j_local) + ELSE IF (i_global_mo > n_occ .AND. j_global_mo <= n_occ) THEN + ! ρ_VO *= e^{-iφ} + local_data(i_local, j_local) = phase_vo*local_data(i_local, j_local) + END IF + END DO + END DO + + CALL timestop(handle) + END SUBROUTINE rotate_rho_phase + +! ************************************************************************************************** +!> \brief Build a lab-frame copy of the (possibly rotating-frame) density rho for I/O. +!> On the TDA + symmetric-shift path returns rho_lab(t) by multiplying OV/VO by +!> exp(-/+ i Ω_0 t). Otherwise returns a plain copy. Writes into rho_new_last +!> (mo_struct-sized, idle outside ETRS) and returns a pointer to it; falls back to +!> the input rho when no scratch is available. +!> \param rtbse_env RT-BSE environment +!> \param rho_in Rotating-frame density (per spin) +!> \param t_phys Physical time associated with rho_in +!> \param rho_lab On exit, points to a per-spin cfm array holding rho in the lab frame. +! ************************************************************************************************** + SUBROUTINE build_rho_lab(rtbse_env, rho_in, t_phys, rho_lab) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_in + REAL(kind=dp), INTENT(IN) :: t_phys + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_lab + + CHARACTER(len=*), PARAMETER :: routineN = 'build_rho_lab' + + INTEGER :: handle, i + + IF (rtbse_env%omega_shift == 0.0_dp .OR. .NOT. ASSOCIATED(rtbse_env%rho_new_last)) THEN + rho_lab => rho_in + RETURN + END IF + + CALL timeset(routineN, handle) + + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_to_cfm(rho_in(i), rtbse_env%rho_new_last(i)) + ! Lab-frame rho_OV(t) = exp(+i*Ω_0*t) * rho_tilde_OV(t) + ! (sign derived from [h_shifted, rho_tilde]_OV = (-eps_ai + Ω_0) rho_tilde_OV). + CALL rotate_rho_phase(rtbse_env, rtbse_env%rho_new_last(i), i, rtbse_env%omega_shift*t_phys) + END DO + rho_lab => rtbse_env%rho_new_last + + CALL timestop(handle) + END SUBROUTINE build_rho_lab + +! ************************************************************************************************** +!> \brief Bridge the restart density from the previous run's active-MO gauge into this run's: +!> overlap-metric basis change U_mn = sum_µν C2_µm S_µν C1_νn (mo_active × mo_active), +!> then ρ_mn ← sum_pq U_mp ρ_pq U_nq (ρ ← U ρ U^T, U real orthogonal up to FP). +!> Exact under per-MO sign flips and degenerate-subspace rotations of the SCF solution. +!> Diagnostics per spin: max|U−1| (total gauge correction), sign-flip count, max off-diag +!> (degenerate rotation), max|U^T U−1| (representability loss; warn ≥1e-10, abort ≥1e-3), +!> max|U_OV| (occ/virt mixing; warn ≥1e-6). No-op (U=1) when the two gauges agree. +!> \param rtbse_env RT-BSE environment +! ************************************************************************************************** + SUBROUTINE apply_restart_basis_bridge(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'apply_restart_basis_bridge' + COMPLEX(kind=dp), PARAMETER :: c_one = CMPLX(1.0_dp, 0.0_dp, kind=dp), & + c_zero = CMPLX(0.0_dp, 0.0_dp, kind=dp) + + INTEGER :: handle, i, i_glob, i_mo, ii, j_glob, & + j_mo, jj, n_flip, ncol_local, & + nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: found + REAL(kind=dp) :: dev_ident, dev_offdiag, dev_ov, & + dev_unitary + REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: u_diag + REAL(kind=dp), CONTIGUOUS, DIMENSION(:, :), & + POINTER :: u_data + TYPE(cp_fm_type) :: SC_old + TYPE(cp_fm_type), DIMENSION(:), POINTER :: C_old + + CALL timeset(routineN, handle) + + NULLIFY (C_old) + ALLOCATE (C_old(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_fm_create(C_old(i), rtbse_env%fm_struct_ao_mo_active) + END DO + CALL read_restart_C(rtbse_env, C_old, found) + IF (.NOT. found) THEN + DO i = 1, rtbse_env%n_spin + CALL cp_fm_release(C_old(i)) + END DO + DEALLOCATE (C_old) + CALL timestop(handle) + RETURN + END IF + + CALL cp_fm_create(SC_old, rtbse_env%fm_struct_ao_mo_active) + ALLOCATE (u_diag(rtbse_env%mo_active)) + + DO i = 1, rtbse_env%n_spin + ! S C1 : [S C1]_µn = sum_ν S_µν C1_νn + CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%S_fm, C_old(i), 0.0_dp, SC_old) + ! U = C2^T (S C1) : U_mn = sum_µ C2_µm [S C1]_µn -> real_workspace_mo(1) + CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & + 1.0_dp, rtbse_env%C_active(i), SC_old, 0.0_dp, rtbse_env%real_workspace_mo(1)) + + ! Diagnostics on U (local blocks + global MAX reduction; diagonal is gathered globally) + CALL cp_fm_get_diag(rtbse_env%real_workspace_mo(1), u_diag) + n_flip = COUNT(u_diag < 0.0_dp) + CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices, local_data=u_data) + dev_ident = 0.0_dp; dev_offdiag = 0.0_dp; dev_ov = 0.0_dp + DO ii = 1, nrow_local + i_glob = row_indices(ii) + i_mo = i_glob + rtbse_env%first_active_mo - 1 + DO jj = 1, ncol_local + j_glob = col_indices(jj) + j_mo = j_glob + rtbse_env%first_active_mo - 1 + IF (i_glob == j_glob) THEN + dev_ident = MAX(dev_ident, ABS(u_data(ii, jj) - 1.0_dp)) + ELSE + dev_ident = MAX(dev_ident, ABS(u_data(ii, jj))) + dev_offdiag = MAX(dev_offdiag, ABS(u_data(ii, jj))) + END IF + IF ((i_mo <= rtbse_env%n_occ(i)) .NEQV. (j_mo <= rtbse_env%n_occ(i))) THEN + dev_ov = MAX(dev_ov, ABS(u_data(ii, jj))) + END IF + END DO + END DO + ! U^T U − 1 : [U^T U]_mn = sum_p U_pm U_pn -> real_workspace_mo(2) + CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + 1.0_dp, rtbse_env%real_workspace_mo(1), rtbse_env%real_workspace_mo(1), & + 0.0_dp, rtbse_env%real_workspace_mo(2)) + CALL cp_fm_get_info(rtbse_env%real_workspace_mo(2), nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices, local_data=u_data) + dev_unitary = 0.0_dp + DO ii = 1, nrow_local + i_glob = row_indices(ii) + DO jj = 1, ncol_local + j_glob = col_indices(jj) + dev_unitary = MAX(dev_unitary, ABS(u_data(ii, jj) - MERGE(1.0_dp, 0.0_dp, i_glob == j_glob))) + END DO + END DO + CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_ident) + CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_offdiag) + CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_ov) + CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_unitary) + + IF (rtbse_env%unit_nr > 0) THEN + WRITE (rtbse_env%unit_nr, '(A,I3,A)') " RTBSE| Restart basis bridge U = C2^T S C1 (spin ", i, "):" + WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max |U - 1| ", dev_ident, & + " (total gauge correction)" + WRITE (rtbse_env%unit_nr, '(A,I12)') " RTBSE| sign flips (U_ii<0)", n_flip + WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max offdiag |U_ij| ", dev_offdiag, & + " (degenerate-subspace rotation)" + WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max |U^T U - 1| ", dev_unitary, & + " (representability loss)" + WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max |U_OV| ", dev_ov, & + " (occ/virt structure change)" + END IF + IF (dev_unitary >= 1.0e-3_dp) THEN + CALL cp_abort(__LOCATION__, & + "Restart basis bridge: active spaces of the two runs differ severely (|U^T U - 1| >= 1e-3)") + END IF + IF (dev_unitary >= 1.0e-10_dp .AND. dev_unitary < 1.0e-3_dp) THEN + CALL cp_warn(__LOCATION__, & + "Restart basis bridge: representability loss above 1e-10 - active windows differ slightly.") + END IF + ! 1e-6 floor: benign SCF reconvergence gives ~1e-9 occ/virt gauge noise (the bridge maps it + ! correctly either way); only a genuine occupation-structure change reaches this threshold. + IF (dev_ov >= 1.0e-6_dp) THEN + CALL cp_warn(__LOCATION__, & + "Restart basis bridge: occupied/virtual mixing above 1e-6 - occupation structure changed.") + END IF + + ! ρ ← U ρ U^T : lift U to complex, [Uρ]_mn = sum_p U_mp ρ_pn, then ρ_mn = sum_q [Uρ]_mq U_nq + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%rho_workspace(1)) + CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + c_one, rtbse_env%rho_workspace(1), rtbse_env%rho(i), c_zero, rtbse_env%rho_workspace(2)) + CALL cp_cfm_gemm('N', 'C', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & + c_one, rtbse_env%rho_workspace(2), rtbse_env%rho_workspace(1), c_zero, rtbse_env%rho(i)) + END DO + + DEALLOCATE (u_diag) + CALL cp_fm_release(SC_old) + DO i = 1, rtbse_env%n_spin + CALL cp_fm_release(C_old(i)) + END DO + DEALLOCATE (C_old) + CALL timestop(handle) + END SUBROUTINE apply_restart_basis_bridge + +! ************************************************************************************************** +!> \brief Complex-linear Hartree contraction. Calls the real-input get_hartree on +!> Re(rho_AO) and on Im(rho_AO) separately and assembles +!> v_AO = V_H[Re(rho_AO)] + i * V_H[Im(rho_AO)] . +!> Required by the TDA propagator where the per-pass input Delta rho_OV (or +!> Delta rho_VO) is non-Hermitian, so the imaginary part must be carried. +!> The real kernel get_hartree realises V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) Δρ_µν]. +!> \param rtbse_env RT-BSE environment +!> \param rho_cfm AO complex input density +!> \param v_cfm AO complex Hartree output (overwritten) +!> \param ispin Spin index (selects scratch slots in rtbse_env) +! ************************************************************************************************** + SUBROUTINE get_hartree_complex(rtbse_env, rho_cfm, v_cfm, ispin) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(cp_cfm_type), INTENT(IN) :: rho_cfm + TYPE(cp_cfm_type) :: v_cfm + INTEGER, INTENT(IN) :: ispin + + CHARACTER(len=*), PARAMETER :: routineN = 'get_hartree_complex' + + INTEGER :: handle + + MARK_USED(ispin) + + CALL timeset(routineN, handle) + + ! Mirrors get_sigma_complex: split rho_cfm into real and imaginary fm parts, + ! call the real-input Hartree contraction on each, then assemble + ! v_cfm = V_H[Re(rho_cfm)] + i*V_H[Im(rho_cfm)]. + ! Scratch usage: + ! real_workspace(1) - holds Re(rho) then V_H[Re] + ! real_workspace(2) - holds Im(rho) then V_H[Im] + ! sigma_complex_workspace(1) - cfm wrapper feeding the real-input slot of get_hartree + + ! V^H[Re(Δρ^AO)] -> real_workspace(1) + CALL cp_cfm_to_fm(msource=rho_cfm, mtargetr=rtbse_env%real_workspace(1)) + CALL cp_cfm_set_all(rtbse_env%sigma_complex_workspace(1), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(1), & + mtarget=rtbse_env%sigma_complex_workspace(1)) + CALL get_hartree(rtbse_env, rtbse_env%sigma_complex_workspace(1), & + rtbse_env%real_workspace(1)) + + ! Imaginary part: extract Im(rho_cfm) into real_workspace(2) + CALL cp_cfm_to_fm(msource=rho_cfm, mtargeti=rtbse_env%real_workspace(2)) + CALL cp_cfm_set_all(rtbse_env%sigma_complex_workspace(1), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(2), & + mtarget=rtbse_env%sigma_complex_workspace(1)) + CALL get_hartree(rtbse_env, rtbse_env%sigma_complex_workspace(1), & + rtbse_env%real_workspace(2)) + + ! Assemble v_cfm = real_workspace(1) + i * real_workspace(2) + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(1), & + msourcei=rtbse_env%real_workspace(2), & + mtarget=v_cfm) + + CALL timestop(handle) + END SUBROUTINE get_hartree_complex + +! ************************************************************************************************** +!> \brief δ-kick (Marek2025) seeding the linearized EOM: builds the MO-active dipole operator +!> A = intensity * sum_k kvec_k r_k (MO basis), Hermitizes it, and propagates ρ by exp(-iA), +!> so Δρ^+_nm = i(f_n - f_m) A_nm excites only the OV/VO blocks. +!> \param rtbse_env RT-BSE environment +!> \author Stepan Marek (09.24) +!> \author Maximilian Graml - trafo to MO and linearized version following 10.1021/acs.jctc.2c00644 (03.26) +! ************************************************************************************************** + SUBROUTINE apply_delta_pulse_MO(rtbse_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + + CHARACTER(len=*), PARAMETER :: routineN = 'apply_delta_pulse_MO' + + INTEGER :: handle, i, k + REAL(kind=dp) :: intensity, metric + REAL(kind=dp), DIMENSION(3) :: kvec + + CALL timeset(routineN, handle) + + ! Report application + IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A28)') ' RTBSE| Applying delta pulse' + ! Extra minus for the propagation of density + intensity = -rtbse_env%dft_control%rtp_control%delta_pulse_scale + metric = 0.0_dp + kvec(:) = rtbse_env%dft_control%rtp_control%delta_pulse_direction(:) + IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A38,E14.4E3,E14.4E3,E14.4E3)') & + " RTBSE| Delta pulse elements (a.u.) : ", intensity*kvec(:) + ! Per-spin kick: each spin uses its own MO-active dipole operator (C_active(i_spin) basis) + DO i = 1, rtbse_env%n_spin + CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) + DO k = 1, 3 + CALL cp_fm_scale_and_add(1.0_dp, rtbse_env%real_workspace_mo(1), & + kvec(k), rtbse_env%moments_field(k, i)) + END DO + ! enforce hermiticity of the effective Hamiltonian + CALL cp_fm_transpose(rtbse_env%real_workspace_mo(1), rtbse_env%real_workspace_mo(2)) + CALL cp_fm_scale_and_add(0.5_dp, rtbse_env%real_workspace_mo(1), & + 0.5_dp, rtbse_env%real_workspace_mo(2)) + ! multiply by intensity, set as the imaginary exponent for this spin + CALL cp_fm_scale(intensity, rtbse_env%real_workspace_mo(1)) + CALL cp_fm_to_cfm(msourcei=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%ham_workspace(i)) + END DO + ! Propagate the density by the effect of the delta pulse + CALL propagate_density(rtbse_env, rtbse_env%ham_workspace, rtbse_env%rho, rtbse_env%rho_new) + metric = rho_metric(rtbse_env%rho_new, rtbse_env%rho, rtbse_env%n_spin) + IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, ('(A42,E38.8E3)')) " RTBSE| Metric difference after delta kick", metric + ! Copy the new density to the old density + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_to_cfm(rtbse_env%rho_new(i), rtbse_env%rho(i)) + END DO + + CALL timestop(handle) + END SUBROUTINE apply_delta_pulse_MO + +! ************************************************************************************************** +!> \brief Zero the OO and VV blocks of an MO-basis derivative cfm in place. Used to enforce +!> strict linear response on the RK4 derivatives so that the linearized propagator +!> only carries the OV/VO branches and the OO/VV orbital-energy spreads do not enter +!> the RK4 stability bound. +!> \param rtbse_env Entry point - rtbse environment +!> \param cfm Derivative-like cfm in MO basis for one spin channel (modified in place) +!> \param i_spin Spin index +! ************************************************************************************************** + SUBROUTINE project_drho_to_ov(rtbse_env, cfm, i_spin) + TYPE(rtbse_env_type), INTENT(IN) :: rtbse_env + TYPE(cp_cfm_type), INTENT(INOUT) :: cfm + INTEGER, INTENT(IN) :: i_spin + + COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data + INTEGER :: i_global, i_global_mo, i_local, & + j_global, j_global_mo, j_local, n_occ, & + ncol_local, nrow_local, shift + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + + n_occ = rtbse_env%n_occ(i_spin) + shift = rtbse_env%first_active_mo - 1 + + CALL cp_cfm_get_info(matrix=cfm, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + local_data => cfm%local_data + + ! keep OV/VO, zero OO/VV: project Δρ onto the δ-kick sectors + DO j_local = 1, ncol_local + j_global = col_indices(j_local) + j_global_mo = j_global + shift + DO i_local = 1, nrow_local + i_global = row_indices(i_local) + i_global_mo = i_global + shift + IF ((i_global_mo <= n_occ .AND. j_global_mo <= n_occ) .OR. & + (i_global_mo > n_occ .AND. j_global_mo > n_occ)) THEN + local_data(i_local, j_local) = CMPLX(0.0_dp, 0.0_dp, kind=dp) + END IF + END DO + END DO + END SUBROUTINE project_drho_to_ov + +! ************************************************************************************************** +!> \brief Per-spin electron numbers from the MO density: N_e^σ = spin_degeneracy * Re Tr[ρ^σ], +!> returned as one entry per spin channel (alpha/beta). The node-local diagonal partial +!> sums are reduced over the BLACS grid before scaling; the imaginary trace is a +!> non-Hermiticity diagnostic. +!> \param rtbse_env Entry point - rtbse environment +!> \param rho Density matrix in MO basis (per spin) +!> \param electron_n_re Real electron number per spin channel (size n_spin) +!> \param electron_n_im Imaginary electron number per spin channel (numerical non-hermiticity) +! ************************************************************************************************** + SUBROUTINE get_electron_number_MO(rtbse_env, rho, electron_n_re, electron_n_im) + TYPE(rtbse_env_type) :: rtbse_env + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho + REAL(kind=dp), DIMENSION(:), INTENT(OUT) :: electron_n_re, electron_n_im + + CHARACTER(len=*), PARAMETER :: routineN = 'get_electron_number_MO' + + COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data + INTEGER :: handle, i_global, i_local, j, j_global, & + j_local, ncol_local, nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + + CALL timeset(routineN, handle) + electron_n_re(:) = 0.0_dp + electron_n_im(:) = 0.0_dp + DO j = 1, rtbse_env%n_spin + CALL cp_cfm_get_info(matrix=rho(j), & + nrow_local=nrow_local, & + ncol_local=ncol_local, & + row_indices=row_indices, & + col_indices=col_indices) + local_data => rho(j)%local_data + ! accumulate Tr[ρ^σ] = sum_m ρ^σ_mm (real and imaginary parts separately) + DO i_local = 1, nrow_local + i_global = row_indices(i_local) + ! Search column indices for the diagonal position + DO j_local = 1, ncol_local + j_global = col_indices(j_local) + IF (j_global == i_global) THEN + ! Found diagonal element + electron_n_re(j) = electron_n_re(j) + REAL(local_data(i_local, j_local), kind=dp) + electron_n_im(j) = electron_n_im(j) + AIMAG(local_data(i_local, j_local)) + EXIT + END IF + END DO + END DO + ! reduce the per-rank partial traces over the process grid (the MO diagonal is distributed) + CALL rho(j)%matrix_struct%para_env%sum(electron_n_re(j)) + CALL rho(j)%matrix_struct%para_env%sum(electron_n_im(j)) + ! N_e^σ = spin_degeneracy * Tr[ρ^σ] (g=2 closed shell; 1 per channel open shell) + electron_n_re(j) = electron_n_re(j)*rtbse_env%spin_degeneracy + electron_n_im(j) = electron_n_im(j)*rtbse_env%spin_degeneracy + END DO + + CALL timestop(handle) + END SUBROUTINE get_electron_number_MO + +END MODULE rt_bse_linearized diff --git a/src/emd/rt_bse_ri_rs.F b/src/emd/rt_bse_ri_rs.F new file mode 100644 index 0000000000..1ca8ddd9da --- /dev/null +++ b/src/emd/rt_bse_ri_rs.F @@ -0,0 +1,759 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief RT-BSE RI-RS kernels: SEX and Hartree evaluated by collocation on grid points r_l. +!> Once-built grid objects: +!> φ_µ(r_l) [grid×AO], Z_lP [grid×RI], +!> V^aux_PQ = [M^-1 V^tr M^-1]_PQ [RI×RI], W^0_ll' = sum_PQ Z_lP (V + W^c(ω=0))_PQ Z_l'Q. +!> Per-call kernels, collocation X = φ_µ(r_l) (AO domain, written φ_lµ below): +!> SEX: ρ^grid_ll' = sum_µν φ_lµ Δρ_µν φ_l'ν ; +!> Σ_µν = pref * sum_ll' φ_lµ [ρ^grid ∘ W^0]_ll' φ_l'ν +!> Hartree: n_l = sum_µν φ_lµ Δρ_µν φ_lν ; +!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (applied factorized, stage 2) ; +!> V^H_µν = sum_l φ_lµ v_l φ_lν (diagonal-only, no grid×grid) +!> Independent of which GW variant produced bs_env%fm_W_MIC_freq_zero. +!> \author Maximilian Graml (05.26) +! ************************************************************************************************** +MODULE rt_bse_ri_rs + USE cp_cfm_basic_linalg, ONLY: cp_cfm_scale_and_add + USE cp_cfm_types, ONLY: cp_cfm_create,& + cp_cfm_release,& + cp_cfm_to_fm,& + cp_cfm_type,& + cp_fm_to_cfm + USE cp_dbcsr_api, ONLY: & + dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_distribution_type, dbcsr_get_info, & + dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, dbcsr_iterator_start, & + dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, dbcsr_release, dbcsr_scale, & + dbcsr_type, dbcsr_type_no_symmetry + USE cp_dbcsr_contrib, ONLY: dbcsr_get_diag + USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& + copy_fm_to_dbcsr + USE cp_fm_types, ONLY: cp_fm_create,& + cp_fm_release,& + cp_fm_type + USE gw_large_cell_Gamma_ri_rs, ONLY: contract_A_B_A,& + hadamard_product_inplace,& + release_dbcsr_topology_and_matrices,& + setup_square_topology + USE gw_large_cell_gamma, ONLY: multiply_fm_W_MIC_time_with_Minv_Gamma + USE gw_non_periodic_ri_rs, ONLY: atomic_basis_at_grid_point,& + compute_coeff_Z_lP,& + precompute_ri_rs_radii,& + ri_rs_grid_assembler + USE kinds, ONLY: dp + USE machine, ONLY: m_walltime + USE message_passing, ONLY: mp_para_env_type + USE mp2_ri_2c, ONLY: RI_2c_integral_mat + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE qs_environment_types, ONLY: qs_environment_type +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rt_bse_ri_rs' + + PUBLIC :: rt_bse_ri_rs_ensure_grid, & + rt_bse_ri_rs_ensure_V_grid, & + rt_bse_ri_rs_ensure_W0_grid, & + compute_sigma_ri_rs, & + compute_sigma_ri_rs_complex, & + compute_hartree_ri_rs, & + compute_hartree_ri_rs_complex, & + compute_hartree_ri_rs_from_diag, & + hartree_potential_from_diag_ri_rs + +CONTAINS + +! ************************************************************************************************** +!> \brief Make sure the AO collocation φ_µ(r_l) (mat_phi_mu_l) and the RI fit coefficients +!> Z_lP (mat_Z_lP) are populated in memory. +!> If GW was run with RI-RS the grid is already built; otherwise build it here so the +!> AO-RI GW + RI-RS RT-BSE combination is possible. +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE rt_bse_ri_rs_ensure_grid(bs_env, qs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_bse_ri_rs_ensure_grid' + + INTEGER :: handle + REAL(KIND=dp) :: t1 + + CALL timeset(routineN, handle) + + IF (bs_env%ri_rs%grid_built) THEN + CALL timestop(handle) + RETURN + END IF + + t1 = m_walltime() + + CALL ri_rs_grid_assembler(qs_env, bs_env, bs_env%ri_rs%grid_points) + ! Per-atom AO/RI screening radii required by the screened grid-fill and d_lP routines; the + ! GW RI-RS driver populates these, but the standalone RT-BSE grid build must do so itself. + IF (.NOT. ALLOCATED(bs_env%ri_rs%radius_ao_per_atom)) THEN + CALL precompute_ri_rs_radii(qs_env, bs_env) + END IF + CALL atomic_basis_at_grid_point(qs_env, bs_env, bs_env%ri_rs%grid_points, & + bs_env%ri_rs%mat_phi_mu_l) + CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & + bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) + + bs_env%ri_rs%grid_built = .TRUE. + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & + 'Built RI-RS grid for RT-BSE (no GW_RI_RS used),', ' Execution time', & + m_walltime() - t1, ' s' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + + CALL timestop(handle) + + END SUBROUTINE rt_bse_ri_rs_ensure_grid + +! ************************************************************************************************** +!> \brief Build V^aux_PQ = [M^-1 V^tr M^-1]_PQ (truncated Coulomb in the RI basis, M^-1-sandwiched +!> to match the W^MIC convention). The grid Coulomb V_ll' = sum_PQ Z_lP V^aux_PQ Z_l'Q is +!> never materialized -- the Hartree stage applies it factorized: +!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' +!> Needed by RT-BSE RI-RS Hartree. +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE rt_bse_ri_rs_ensure_V_grid(bs_env, qs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_bse_ri_rs_ensure_V_grid' + + INTEGER :: handle + INTEGER, DIMENSION(:), POINTER :: blk_aux, dist_row_aux + REAL(KIND=dp) :: t1 + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma + TYPE(dbcsr_distribution_type) :: dist_aux_aux + + CALL timeset(routineN, handle) + + IF (bs_env%ri_rs%V_grid_built) THEN + CALL timestop(handle) + RETURN + END IF + + CALL rt_bse_ri_rs_ensure_grid(bs_env, qs_env) + t1 = m_walltime() + + CALL setup_square_topology(bs_env%ri_rs%mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) + + CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & + bs_env%trunc_coulomb, do_kpoints=.FALSE.) + ! Apply M^-1 sandwich to match the W^MIC convention; same scale as W^c when both used. + CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) + + ! Store the M^-1-sandwiched RI-basis Coulomb; the grid kernel Z V Z^T is applied factorized. + CALL dbcsr_create(bs_env%ri_rs%mat_V_aux_rtbse, "V_aux_rtbse", dist_aux_aux, & + dbcsr_type_no_symmetry, blk_aux, blk_aux) + CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), bs_env%ri_rs%mat_V_aux_rtbse, & + keep_sparsity=.FALSE.) + + bs_env%ri_rs%V_grid_built = .TRUE. + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & + 'Precomputed RT-BSE RI-RS V_aux kernel,', ' Execution time', & + m_walltime() - t1, ' s' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + + CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux) + CALL cp_fm_release(fm_Vtr_Gamma) + + CALL timestop(handle) + + END SUBROUTINE rt_bse_ri_rs_ensure_V_grid + +! ************************************************************************************************** +!> \brief Build W^0_ll' = sum_PQ Z_lP (V + W^c(ω=0))_PQ Z_l'Q (statically screened W on the grid). +!> Needed by RT-BSE RI-RS SEX/COH. Reuses bs_env%fm_W_MIC_freq_zero which must already +!> contain M^-1 W^c(ω=0) M^-1 (built by either GW path under the BSE rtp_method gate). +!> W^0 enters only through the Hadamard ρ^grid ∘ W^0 -- its elements are needed, so it is +!> the one persistent grid×grid object of the kernel layer. +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE rt_bse_ri_rs_ensure_W0_grid(bs_env, qs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_bse_ri_rs_ensure_W0_grid' + + INTEGER :: handle + INTEGER, DIMENSION(:), POINTER :: blk_aux, blk_grid, dist_col_grid, & + dist_row_aux + REAL(KIND=dp) :: t1 + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma + TYPE(dbcsr_distribution_type) :: dist_aux_aux, dist_grid_grid + TYPE(dbcsr_type) :: matrix_V_aux, matrix_W_aux + + CALL timeset(routineN, handle) + + IF (bs_env%ri_rs%W0_grid_built) THEN + CALL timestop(handle) + RETURN + END IF + + ! W(w=0) is built by the GW step only under its RTBSE rtp_method gate; reaching this consumer + ! without it means gate and consumer disagree. Abort rather than read a never-created cp_fm. + IF (.NOT. ASSOCIATED(bs_env%fm_W_MIC_freq_zero%matrix_struct)) THEN + CALL cp_abort(__LOCATION__, & + "RT-BSE RI-RS kernel needs the screened interaction W(w=0), which the GW "// & + "step did not build. Select the RT-BSE propagator with '&RTBSE' or "// & + "'&RTBSE RTBSE', not '&RTBSE TDDFT'.") + END IF + + CALL rt_bse_ri_rs_ensure_grid(bs_env, qs_env) + t1 = m_walltime() + + CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, & + dist_col_grid) + CALL setup_square_topology(bs_env%ri_rs%mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) + + CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & + bs_env%trunc_coulomb, do_kpoints=.FALSE.) + CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) + + CALL dbcsr_create(matrix_V_aux, "V_aux_rtbse_W0", dist_aux_aux, dbcsr_type_no_symmetry, & + blk_aux, blk_aux) + CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.FALSE.) + + CALL dbcsr_create(matrix_W_aux, "W_aux_rtbse", dist_aux_aux, dbcsr_type_no_symmetry, & + blk_aux, blk_aux) + CALL copy_fm_to_dbcsr(bs_env%fm_W_MIC_freq_zero, matrix_W_aux, keep_sparsity=.FALSE.) + CALL dbcsr_add(matrix_W_aux, matrix_V_aux, 1.0_dp, 1.0_dp) + + CALL dbcsr_create(bs_env%ri_rs%mat_W0_grid_rtbse, "W0_grid_rtbse", dist_grid_grid, & + dbcsr_type_no_symmetry, blk_grid, blk_grid) + CALL contract_A_B_A("N", "T", bs_env%ri_rs%mat_Z_lP, matrix_W_aux, & + bs_env%ri_rs%mat_W0_grid_rtbse, bs_env%eps_filter) + + bs_env%ri_rs%W0_grid_built = .TRUE. + bs_env%ri_rs%rtbse_kernels_ready = .TRUE. + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & + 'Precomputed RT-BSE RI-RS W0_grid kernel,', ' Execution time', & + m_walltime() - t1, ' s' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + + CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid) + CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux, & + m1=matrix_V_aux, m2=matrix_W_aux) + CALL cp_fm_release(fm_Vtr_Gamma) + + CALL timestop(handle) + + END SUBROUTINE rt_bse_ri_rs_ensure_W0_grid + +! ************************************************************************************************** +!> \brief AO-domain SEX: Σ_µν = pref * sum_ll' φ_lµ [ρ^grid ∘ W^0]_ll' φ_l'ν, +!> ρ^grid_ll' = sum_µν φ_lµ Δρ_µν φ_l'ν. +!> The grid×grid ρ^grid is intrinsic to SEX -- the Hadamard needs W^0's elements, so no +!> factorized application exists (unlike the Hartree V_ll'). Real input, real output; +!> used for COH (input S^-1) and the init reference (ρ^0); dynamic Δρ goes through the +!> complex variant. Mirrors the AO-RI get_sigma(rtbse_env, sigma_fm, prefactor, rho_fm) API. +!> \param bs_env ... +!> \param sigma_AO_fm result, AO x AO +!> \param prefactor scaling applied to the final result +!> \param rho_AO_fm input density-like matrix, AO x AO +!> \param grid_diag_accum ... +! ************************************************************************************************** + SUBROUTINE compute_sigma_ri_rs(bs_env, sigma_AO_fm, prefactor, rho_AO_fm, & + grid_diag_accum) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(cp_fm_type), INTENT(INOUT) :: sigma_AO_fm + REAL(KIND=dp), INTENT(IN) :: prefactor + TYPE(cp_fm_type), INTENT(IN) :: rho_AO_fm + REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: grid_diag_accum(:) + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_sigma_ri_rs' + + INTEGER :: handle, n_grid + INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_grid, & + dist_row_ao + REAL(KIND=dp), ALLOCATABLE :: diag_local(:) + TYPE(dbcsr_distribution_type) :: dist_ao_ao, dist_grid_grid + TYPE(dbcsr_type) :: matrix_rho_AO, matrix_rho_grid, & + matrix_Sigma_AO + + CALL timeset(routineN, handle) + + CPASSERT(bs_env%ri_rs%W0_grid_built) + + CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) + CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, & + dist_col_grid) + + CALL dbcsr_create(matrix_rho_AO, "rho_AO_ri_rs", dist_ao_ao, dbcsr_type_no_symmetry, & + blk_ao, blk_ao) + CALL copy_fm_to_dbcsr(rho_AO_fm, matrix_rho_AO, keep_sparsity=.FALSE.) + + ! ρ^grid_ll' = sum_µν φ_lµ Δρ_µν φ_l'ν (the SEX-intrinsic grid×grid transient) + CALL dbcsr_create(matrix_rho_grid, "rho_grid_ri_rs", dist_grid_grid, & + dbcsr_type_no_symmetry, blk_grid, blk_grid) + ! No eps_filter on the SEX projections: a Δρ-dependent block drop breaks kernel + ! self-adjointness (L non-Hermitian). The W0 Hadamard below supplies the symmetric, + ! Δρ-independent grid sparsity, so unfiltered projections stay sparse via W0. + ! PERF(rirs-selfadjoint): a retain_sparsity-to-W0 build (dbcsr_multiply) gives identical + ! numbers with W0-sparse memory; NOT YET APPLIED, needs a perf test. + CALL contract_A_B_A("N", "T", bs_env%ri_rs%mat_phi_mu_l, matrix_rho_AO, & + matrix_rho_grid, 0.0_dp) + + ! Harvest n_l = diag(ρ^grid) BEFORE the in-place Hadamard destroys it; the Hartree reuses it + ! (compute_hartree_ri_rs_from_diag) instead of rebuilding φρφ^T. Bare accumulate (caller + ! pre-zeroes): the cross-spin Hartree density is the spin SUM of these, and spin_degeneracy is + ! applied to the V_H OUTPUT (post-filter, bit-identical) -- never to the diagonal, which would + ! shift the stage-3 eps_filter cut (coarse-filter sensitivity). + IF (PRESENT(grid_diag_accum)) THEN + n_grid = SIZE(grid_diag_accum) + ALLOCATE (diag_local(n_grid)) + diag_local = 0.0_dp + CALL dbcsr_get_diag(matrix_rho_grid, diag_local) + CALL bs_env%para_env%sum(diag_local) + grid_diag_accum(:) = grid_diag_accum(:) + diag_local(:) + DEALLOCATE (diag_local) + END IF + + ! ρ^grid_ll' <- ρ^grid_ll' * W^0_ll' (in place; blocks without a W^0 partner zeroed) + CALL hadamard_product_inplace(matrix_rho_grid, bs_env%ri_rs%mat_W0_grid_rtbse, & + 1.0_dp) + + ! Σ_µν = sum_ll' φ_lµ [ρ^grid ∘ W^0]_ll' φ_l'ν + CALL dbcsr_create(matrix_Sigma_AO, template=matrix_rho_AO) + ! Unfiltered for self-adjointness (see the forward projection above; PERF note there). + CALL contract_A_B_A("T", "N", bs_env%ri_rs%mat_phi_mu_l, matrix_rho_grid, & + matrix_Sigma_AO, 0.0_dp) + + CALL dbcsr_scale(matrix_Sigma_AO, prefactor) + CALL copy_dbcsr_to_fm(matrix_Sigma_AO, sigma_AO_fm) + + CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, & + m1=matrix_rho_AO, m2=matrix_Sigma_AO) + CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid, & + m1=matrix_rho_grid) + + CALL timestop(handle) + + END SUBROUTINE compute_sigma_ri_rs + +! ************************************************************************************************** +!> \brief Complex-input AO SEX via Re/Im split: the kernel is real, so complex linearity holds as +!> Σ[Δρ] = Σ[Re Δρ] + i Σ[Im Δρ]. Required for non-Hermitian Δρ inputs +!> (TDA OV-only / ABBA OV+VO). +!> \param bs_env ... +!> \param sigma_AO_cfm result, AO x AO (complex) +!> \param prefactor scaling applied to the final result +!> \param rho_AO_cfm input AO x AO complex matrix +!> \param grid_diag_re_accum optional: accumulate diag(φ.Re(ρ).φ^T) (bare; for the Hartree reuse) +!> \param grid_diag_im_accum optional: accumulate diag(φ.Im(ρ).φ^T) (bare; for the Hartree reuse) +! ************************************************************************************************** + SUBROUTINE compute_sigma_ri_rs_complex(bs_env, sigma_AO_cfm, prefactor, rho_AO_cfm, & + grid_diag_re_accum, grid_diag_im_accum) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(cp_cfm_type), INTENT(INOUT) :: sigma_AO_cfm + REAL(KIND=dp), INTENT(IN) :: prefactor + TYPE(cp_cfm_type), INTENT(IN) :: rho_AO_cfm + REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: grid_diag_re_accum(:), & + grid_diag_im_accum(:) + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_sigma_ri_rs_complex' + + INTEGER :: handle + TYPE(cp_cfm_type) :: cfm_real_part + TYPE(cp_fm_type) :: fm_rho, fm_sigma + + CALL timeset(routineN, handle) + + CALL cp_fm_create(fm_rho, bs_env%fm_s_Gamma%matrix_struct) + CALL cp_fm_create(fm_sigma, bs_env%fm_s_Gamma%matrix_struct) + CALL cp_cfm_create(cfm_real_part, bs_env%fm_s_Gamma%matrix_struct) + + ! Re/Im each harvest into their own accumulator; absent optionals propagate as absent. + CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargetr=fm_rho) + CALL compute_sigma_ri_rs(bs_env, fm_sigma, prefactor, fm_rho, & + grid_diag_accum=grid_diag_re_accum) + CALL cp_fm_to_cfm(msourcer=fm_sigma, mtarget=cfm_real_part) + + CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargeti=fm_rho) + CALL compute_sigma_ri_rs(bs_env, fm_sigma, prefactor, fm_rho, & + grid_diag_accum=grid_diag_im_accum) + CALL cp_fm_to_cfm(msourcei=fm_sigma, mtarget=sigma_AO_cfm) + + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), sigma_AO_cfm, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), cfm_real_part) + + CALL cp_fm_release(fm_rho) + CALL cp_fm_release(fm_sigma) + CALL cp_cfm_release(cfm_real_part) + + CALL timestop(handle) + + END SUBROUTINE compute_sigma_ri_rs_complex + +! ************************************************************************************************** +!> \brief AO-domain Hartree via RI-RS: +!> n_l = sum_µν φ_lµ Δρ_µν φ_lν = (φ ρ φ^T)_ll (diagonal of materialized grid×grid) ; +!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (factorized, stage 2) ; +!> V^H_µν = sum_l φ_lµ v_l φ_lν (diagonal-only row-scale, stage 3) +!> Real input, real output; complex inputs go through compute_hartree_ri_rs_complex. +!> \param bs_env ... +!> \param rho_AO_fm input AO x AO density matrix +!> \param V_H_AO_fm output AO x AO Hartree potential +! ************************************************************************************************** + SUBROUTINE compute_hartree_ri_rs(bs_env, rho_AO_fm, V_H_AO_fm) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(cp_fm_type), INTENT(IN) :: rho_AO_fm + TYPE(cp_fm_type), INTENT(INOUT) :: V_H_AO_fm + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_hartree_ri_rs' + + INTEGER :: handle, n_grid + INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_grid, & + dist_row_ao + REAL(KIND=dp), ALLOCATABLE :: n_vec(:) + TYPE(dbcsr_distribution_type) :: dist_ao_ao, dist_grid_grid + TYPE(dbcsr_type) :: matrix_rho_AO, matrix_rho_grid + + CALL timeset(routineN, handle) + + CPASSERT(bs_env%ri_rs%V_grid_built) + + CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) + CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, & + dist_col_grid) + + CALL dbcsr_create(matrix_rho_AO, "rho_AO_hartree", dist_ao_ao, dbcsr_type_no_symmetry, & + blk_ao, blk_ao) + CALL copy_fm_to_dbcsr(rho_AO_fm, matrix_rho_AO, keep_sparsity=.FALSE.) + + n_grid = SUM(blk_grid) + ALLOCATE (n_vec(n_grid)) + + ! stage 1: n_l = (φ ρ φ^T)_ll. A grid×AO row-dot (iterate φρ, look up φ) silently drops + ! off-rank pairs at ≥2 ranks — φ is sparse and the product is not co-located with φ — so + ! materialize φρφ^T and take its diagonal, co-location-safe like the SEX grid kernel. + CALL dbcsr_create(matrix_rho_grid, "rho_grid_hartree", dist_grid_grid, & + dbcsr_type_no_symmetry, blk_grid, blk_grid) + ! No eps_filter: a Δρ-dependent diagonal-block drop zeroes n_l inconsistently between OV + ! pairs and breaks Hartree self-adjointness (L non-Hermitian). + ! PERF(rirs-selfadjoint): this full grid×grid is built only for its diagonal n_l; a + ! diagonal-only build would avoid it. NOT YET APPLIED, needs a perf test. + CALL contract_A_B_A("N", "T", bs_env%ri_rs%mat_phi_mu_l, matrix_rho_AO, & + matrix_rho_grid, 0.0_dp) + n_vec = 0.0_dp + CALL dbcsr_get_diag(matrix_rho_grid, n_vec) + CALL bs_env%para_env%sum(n_vec) + CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid, & + m1=matrix_rho_grid) + CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, & + m1=matrix_rho_AO) + + ! stages 2-3: factorized Coulomb v = Z V^aux Z^T n, then V^H = φ^T diag(v) φ. + CALL hartree_potential_from_diag_ri_rs(bs_env, n_vec, V_H_AO_fm) + + DEALLOCATE (n_vec) + + CALL timestop(handle) + + END SUBROUTINE compute_hartree_ri_rs + +! ************************************************************************************************** +!> \brief Hartree stages 2-3 from a precomputed grid density n_l (skips the stage-1 φρφ^T build): +!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (factorized Coulomb) ; +!> V^H_µν = sum_l φ_lµ v_l φ_lν (Φ_lν = v_l φ_lν rowscale, then V^H = φ^T Φ). +!> n_l is harvested as diag(φρφ^T) inside compute_sigma_ri_rs (the SEX grid kernel), so the +!> Hartree never rebuilds the grid×grid product. Real in/out. +!> \param bs_env ... +!> \param n_vec grid density n_l (length n_grid, replicated) +!> \param V_H_AO_fm output AO x AO Hartree potential +! ************************************************************************************************** + SUBROUTINE hartree_potential_from_diag_ri_rs(bs_env, n_vec, V_H_AO_fm) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp), INTENT(IN) :: n_vec(:) + TYPE(cp_fm_type), INTENT(INOUT) :: V_H_AO_fm + + CHARACTER(LEN=*), PARAMETER :: routineN = 'hartree_potential_from_diag_ri_rs' + + INTEGER :: handle + INTEGER, DIMENSION(:), POINTER :: blk_ao, dist_row_ao + REAL(KIND=dp), ALLOCATABLE :: u_ri(:), v_vec(:), w_ri(:) + TYPE(dbcsr_distribution_type) :: dist_ao_ao + TYPE(dbcsr_type) :: matrix_Phi, matrix_V_H_AO + + CALL timeset(routineN, handle) + + CPASSERT(bs_env%ri_rs%V_grid_built) + + CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) + ALLOCATE (v_vec(SIZE(n_vec))) + + ! stage 2: v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (factorized; helper zeroes each output) + ALLOCATE (w_ri(bs_env%n_RI), u_ri(bs_env%n_RI)) + ! w_Q = sum_l Z_lQ n_l + CALL dbcsr_matvec_replicated(bs_env%ri_rs%mat_Z_lP, n_vec, w_ri, bs_env%para_env, & + transposed=.TRUE.) + ! u_P = sum_Q V^aux_PQ w_Q + CALL dbcsr_matvec_replicated(bs_env%ri_rs%mat_V_aux_rtbse, w_ri, u_ri, bs_env%para_env) + ! v_l = sum_P Z_lP u_P + CALL dbcsr_matvec_replicated(bs_env%ri_rs%mat_Z_lP, u_ri, v_vec, bs_env%para_env) + DEALLOCATE (w_ri, u_ri) + + ! stage 3: V^H_µν = sum_l φ_lµ v_l φ_lν (Φ_lν = v_l φ_lν rowscale, then V^H = φ^T Φ) + CALL dbcsr_create(matrix_Phi, template=bs_env%ri_rs%mat_phi_mu_l) + CALL dbcsr_copy(matrix_Phi, bs_env%ri_rs%mat_phi_mu_l) + CALL dbcsr_scale_rows_replicated(matrix_Phi, v_vec) + + CALL dbcsr_create(matrix_V_H_AO, "V_H_AO_hartree", dist_ao_ao, dbcsr_type_no_symmetry, & + blk_ao, blk_ao) + ! No eps_filter: a Δρ-dependent block drop breaks Hartree kernel self-adjointness. + CALL dbcsr_multiply("T", "N", 1.0_dp, bs_env%ri_rs%mat_phi_mu_l, matrix_Phi, & + 0.0_dp, matrix_V_H_AO, filter_eps=0.0_dp) + CALL dbcsr_release(matrix_Phi) + + CALL copy_dbcsr_to_fm(matrix_V_H_AO, V_H_AO_fm) + + DEALLOCATE (v_vec) + + CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, & + m1=matrix_V_H_AO) + + CALL timestop(handle) + + END SUBROUTINE hartree_potential_from_diag_ri_rs + +! ************************************************************************************************** +!> \brief Complex Hartree from precomputed grid diagonals: V^H = V^H[n_re] + i V^H[n_im], each via +!> hartree_potential_from_diag_ri_rs (stages 2-3 only). n_re/n_im are the spin-summed grid +!> densities harvested in the SEX kernel; this is the cross-spin / TDA complex consumer that +!> replaces compute_hartree_ri_rs_complex when SEX already built the grid. n_im optional: when +!> absent the result is purely real (matches the Re-only real-input Hartree). +!> \param bs_env ... +!> \param n_re grid density Re part (length n_grid, replicated) +!> \param V_H_AO_cfm output AO x AO complex Hartree potential +!> \param n_im optional grid density Im part (length n_grid, replicated) +! ************************************************************************************************** + SUBROUTINE compute_hartree_ri_rs_from_diag(bs_env, n_re, V_H_AO_cfm, n_im) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp), INTENT(IN) :: n_re(:) + TYPE(cp_cfm_type), INTENT(INOUT) :: V_H_AO_cfm + REAL(KIND=dp), INTENT(IN), OPTIONAL :: n_im(:) + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_hartree_ri_rs_from_diag' + + INTEGER :: handle + TYPE(cp_cfm_type) :: cfm_real_part + TYPE(cp_fm_type) :: fm_v + + CALL timeset(routineN, handle) + + CALL cp_fm_create(fm_v, bs_env%fm_s_Gamma%matrix_struct) + + CALL hartree_potential_from_diag_ri_rs(bs_env, n_re, fm_v) + IF (PRESENT(n_im)) THEN + CALL cp_cfm_create(cfm_real_part, bs_env%fm_s_Gamma%matrix_struct) + CALL cp_fm_to_cfm(msourcer=fm_v, mtarget=cfm_real_part) + CALL hartree_potential_from_diag_ri_rs(bs_env, n_im, fm_v) + CALL cp_fm_to_cfm(msourcei=fm_v, mtarget=V_H_AO_cfm) + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), V_H_AO_cfm, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), cfm_real_part) + CALL cp_cfm_release(cfm_real_part) + ELSE + CALL cp_fm_to_cfm(msourcer=fm_v, mtarget=V_H_AO_cfm) + END IF + + CALL cp_fm_release(fm_v) + + CALL timestop(handle) + + END SUBROUTINE compute_hartree_ri_rs_from_diag + +! ************************************************************************************************** +!> \brief Complex-input Hartree potential via RI-RS. Re/Im split: feed each part to the real +!> compute_hartree_ri_rs and reassemble. Real-input Hartree on a non-Hermitian input +!> would silently drop Im and break Hermitian conjugacy of OV+VO contributions in TDA. +!> \param bs_env ... +!> \param rho_AO_cfm input AO x AO complex density-like matrix +!> \param V_H_AO_cfm output AO x AO complex Hartree potential +! ************************************************************************************************** + SUBROUTINE compute_hartree_ri_rs_complex(bs_env, rho_AO_cfm, V_H_AO_cfm) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(cp_cfm_type), INTENT(IN) :: rho_AO_cfm + TYPE(cp_cfm_type), INTENT(INOUT) :: V_H_AO_cfm + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_hartree_ri_rs_complex' + + INTEGER :: handle + TYPE(cp_cfm_type) :: cfm_real_part + TYPE(cp_fm_type) :: fm_rho, fm_v + + CALL timeset(routineN, handle) + + CALL cp_fm_create(fm_rho, bs_env%fm_s_Gamma%matrix_struct) + CALL cp_fm_create(fm_v, bs_env%fm_s_Gamma%matrix_struct) + CALL cp_cfm_create(cfm_real_part, bs_env%fm_s_Gamma%matrix_struct) + + CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargetr=fm_rho) + CALL compute_hartree_ri_rs(bs_env, fm_rho, fm_v) + CALL cp_fm_to_cfm(msourcer=fm_v, mtarget=cfm_real_part) + + CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargeti=fm_rho) + CALL compute_hartree_ri_rs(bs_env, fm_rho, fm_v) + CALL cp_fm_to_cfm(msourcei=fm_v, mtarget=V_H_AO_cfm) + + CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), V_H_AO_cfm, & + CMPLX(1.0_dp, 0.0_dp, kind=dp), cfm_real_part) + + CALL cp_fm_release(fm_rho) + CALL cp_fm_release(fm_v) + CALL cp_cfm_release(cfm_real_part) + + CALL timestop(handle) + + END SUBROUTINE compute_hartree_ri_rs_complex + +! ************************************************************************************************** +!> \brief Scale each row of a dbcsr matrix by a replicated full-length vector: +!> block(ir,ic) <- vec(global_row(ir)) * block(ir,ic). Value mutation only. +!> \param matrix ... +!> \param vec full-length replicated row-scaling vector +! ************************************************************************************************** + SUBROUTINE dbcsr_scale_rows_replicated(matrix, vec) + + TYPE(dbcsr_type), INTENT(INOUT) :: matrix + REAL(KIND=dp), INTENT(IN) :: vec(:) + + INTEGER :: col_blk, ic, ir, nblkrows_total, & + row_blk, row_off + INTEGER, ALLOCATABLE :: row_offset(:) + INTEGER, DIMENSION(:), POINTER :: row_blk_size + REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk + TYPE(dbcsr_iterator_type) :: iter + + CALL dbcsr_get_info(matrix, nblkrows_total=nblkrows_total, row_blk_size=row_blk_size) + ALLOCATE (row_offset(nblkrows_total + 1)) + row_offset(1) = 0 + DO ir = 1, nblkrows_total + row_offset(ir + 1) = row_offset(ir) + row_blk_size(ir) + END DO + + CALL dbcsr_iterator_start(iter, matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, row_blk, col_blk, blk) + row_off = row_offset(row_blk) + DO ic = 1, SIZE(blk, 2) + DO ir = 1, SIZE(blk, 1) + blk(ir, ic) = vec(row_off + ir)*blk(ir, ic) + END DO + END DO + END DO + CALL dbcsr_iterator_stop(iter) + + DEALLOCATE (row_offset) + + END SUBROUTINE dbcsr_scale_rows_replicated + +! ************************************************************************************************** +!> \brief Replicated matvec: vec_out = matrix * vec_in (or matrix^T * vec_in if transposed) for a +!> possibly rectangular distributed dbcsr matrix and replicated full-length vectors. +!> Iterates over local blocks and reduces. +!> \param matrix distributed dbcsr matrix (may be rectangular) +!> \param vec_in full input vector, replicated on all ranks (column length, or row length if transposed) +!> \param vec_out full output vector, replicated on all ranks (zeroed on entry; sum-reduced on exit) +!> \param para_env ... +!> \param transposed if .TRUE. compute vec_out = matrix^T * vec_in +! ************************************************************************************************** + SUBROUTINE dbcsr_matvec_replicated(matrix, vec_in, vec_out, para_env, transposed) + + TYPE(dbcsr_type), INTENT(INOUT) :: matrix + REAL(KIND=dp), INTENT(IN) :: vec_in(:) + REAL(KIND=dp), INTENT(INOUT) :: vec_out(:) + TYPE(mp_para_env_type), POINTER :: para_env + LOGICAL, INTENT(IN), OPTIONAL :: transposed + + INTEGER :: col_blk, col_off, ic, ir, & + nblkcols_total, nblkrows_total, & + row_blk, row_off + INTEGER, ALLOCATABLE :: col_offset(:), row_offset(:) + INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size + LOGICAL :: my_trans + REAL(KIND=dp), DIMENSION(:, :), POINTER :: block + TYPE(dbcsr_iterator_type) :: iter + + my_trans = .FALSE. + IF (PRESENT(transposed)) my_trans = transposed + + CALL dbcsr_get_info(matrix, nblkrows_total=nblkrows_total, & + nblkcols_total=nblkcols_total, & + row_blk_size=row_blk_size, col_blk_size=col_blk_size) + + ALLOCATE (row_offset(nblkrows_total + 1), col_offset(nblkcols_total + 1)) + row_offset(1) = 0 + DO ir = 1, nblkrows_total + row_offset(ir + 1) = row_offset(ir) + row_blk_size(ir) + END DO + col_offset(1) = 0 + DO ic = 1, nblkcols_total + col_offset(ic + 1) = col_offset(ic) + col_blk_size(ic) + END DO + + vec_out(:) = 0.0_dp + + CALL dbcsr_iterator_start(iter, matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, row_blk, col_blk, block) + row_off = row_offset(row_blk) + col_off = col_offset(col_blk) + IF (my_trans) THEN + DO ic = 1, SIZE(block, 2) + DO ir = 1, SIZE(block, 1) + vec_out(col_off + ic) = vec_out(col_off + ic) + & + block(ir, ic)*vec_in(row_off + ir) + END DO + END DO + ELSE + DO ic = 1, SIZE(block, 2) + DO ir = 1, SIZE(block, 1) + vec_out(row_off + ir) = vec_out(row_off + ir) + & + block(ir, ic)*vec_in(col_off + ic) + END DO + END DO + END IF + END DO + CALL dbcsr_iterator_stop(iter) + + DEALLOCATE (row_offset, col_offset) + + CALL para_env%sum(vec_out) + + END SUBROUTINE dbcsr_matvec_replicated + +END MODULE rt_bse_ri_rs diff --git a/src/emd/rt_bse_types.F b/src/emd/rt_bse_types.F index b9b647119f..07e1e64872 100644 --- a/src/emd/rt_bse_types.F +++ b/src/emd/rt_bse_types.F @@ -17,6 +17,9 @@ MODULE rt_bse_types cp_fm_release, & cp_fm_create, & cp_fm_set_all + USE cp_fm_struct, ONLY: cp_fm_struct_type, & + cp_fm_struct_create, & + cp_fm_struct_release USE cp_cfm_types, ONLY: cp_cfm_type, & cp_cfm_set_all, & cp_cfm_create, & @@ -38,16 +41,24 @@ MODULE rt_bse_types USE qs_environment_types, ONLY: qs_environment_type, & get_qs_env USE force_env_types, ONLY: force_env_type - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type, & + eps_qp_gap, & + max_qp_gap USE rt_propagation_types, ONLY: rt_prop_type USE rt_propagation_utils, ONLY: warn_section_unused USE gw_integrals, ONLY: build_3c_integral_block USE gw_large_cell_Gamma, ONLY: compute_3c_integrals + USE gw_utils, ONLY: rtbse_resolve_rirs_flag USE qs_tensors, ONLY: neighbor_list_3c_destroy USE libint_2c_3c, ONLY: libint_potential_type USE input_constants, ONLY: use_mom_ref_coac, & do_bch, & - do_exact + do_exact, & + rtp_bse_ham_g0w0, & + rtp_method_bse_linearized + USE bse_util, ONLY: determine_cutoff_indices + USE cp_log_handling, ONLY: cp_to_string + USE physcon, ONLY: evolt USE mathconstants, ONLY: z_zero USE input_section_types, ONLY: section_vals_type, & section_vals_val_get, & @@ -86,14 +97,15 @@ MODULE rt_bse_types !> \param n_occ Number of occupied orbitals, spin dependent !> \param spin_degeneracy Number of electrons per orbital !> \param field Electric field calculated at the given timestep -!> \param moments Moment operators along cartesian directions - centered at zero charge - used for plotting -!> \param moments_field Moment operators along cartesian directions - used to coupling to the field - +!> \param moments Moment operators (2nd index = spin) along cartesian directions - centered at zero charge - used for plotting +!> \param moments_field Moment operators (2nd index = spin) along cartesian directions - used to coupling to the field - !> origin bound to unit cell !> \param sim_step Current step of the simulation !> \param sim_start Starting step of the simulation !> \param sim_nsteps Number of steps of the simulation !> \param sim_time Current time of the simulation !> \param sim_dt Timestep of the simulation +!> \param sim_dt_restart Original-run timestep read from the trace on restart (< 0 when not a restart) !> \param etrs_threshold Self-consistency threshold for enforced time reversal symmetry propagation !> \param exp_accuracy Threshold for matrix exponential calculation !> \param dft_control DFT control parameters @@ -140,9 +152,58 @@ MODULE rt_bse_types n_ao = -1, & n_RI = -1 INTEGER, DIMENSION(2) :: n_occ = -1 + ! Active MO window for linearized RT-BSE truncation. When no truncation is requested, + ! first_active_mo=1, last_active_mo=n_ao, and mo_active=n_ao. The window is the + ! combined inclusive bound that covers both spin channels. + INTEGER :: first_active_mo = 1, & + last_active_mo = -1, & + mo_active = -1 + REAL(KIND=dp) :: rtbse_energy_cutoff_occ = -1.0_dp, & + rtbse_energy_cutoff_empty = -1.0_dp + LOGICAL :: active_mo_truncation = .FALSE. + LOGICAL :: linearized = .FALSE. + ! Tamm-Dancoff approximation switch (linearized RT-BSE only). + LOGICAL :: tda_active = .FALSE. + ! First-peak shift for the TDA path (linearized RT-BSE only). + ! Shifts active-MO single-particle diagonals by +Omega_0/2 (occ) / -Omega_0/2 (virt) + ! with Omega_0 = eps_min_ai so the lowest active OV mode oscillates at zero in the + ! rotating frame (RK4-exact for peak 1). omega_max becomes the full active OV width + ! Delta = eps_max_ai - eps_min_ai. The resulting rotating-frame density is undone + ! at I/O so observables stay lab-frame. + LOGICAL :: tda_shift_to_first_peak = .FALSE. + REAL(kind=dp) :: omega_shift = 0.0_dp + ! Debug-only kernel switches shared by initialization and propagation. + LOGICAL :: debug_disable_hartree = .FALSE., & + debug_disable_sex = .FALSE. + ! RI framework for the linRTBSE Hartree + screened-exchange kernels, set by the KERNEL_RI + ! input keyword (DEFAULT inherits bs_env%do_gw_ri_rs; RS/AO force; full RT-BSE forced AO). + ! .TRUE. = RI-RS grid kernels, .FALSE. = AO-RI. The required grid and V_grid/W0_grid + ! kernels are built on demand and reused across steps. + LOGICAL :: rirs_kernel = .FALSE. + ! Liouvillian eigenvalue diagnostic (TDA + n_spin=1 only). When .TRUE., at job + ! init the linearized RT-BSE assembles the OV-subspace Liouvillian by probing + ! apply_liouvillian_to_drho with canonical OV basis vectors and diagonalizes + ! via cp_cfm_heevd. In TDA this equals the Casida-A eigenvalue problem. + ! Run once, no propagation impact. + LOGICAL :: diagnose_liouvillian_eig = .FALSE. + ! Whether to enforce max_dt within stability region of rk4 + LOGICAL :: enforce_max_dt = .FALSE. + ! Owned fm structures sized to the active MO window. Equal to the full n_ao x n_ao + ! when no truncation is active. + TYPE(cp_fm_struct_type), POINTER :: fm_struct_mo_active => NULL() + ! n_ao x mo_active fm struct used for C_active and AO<->MO rectangular intermediates. + TYPE(cp_fm_struct_type), POINTER :: fm_struct_ao_mo_active => NULL() + ! Liouvillian-diagnostic struct: (N_OV_joint x N_OV_joint), spin blocks stacked, on the + ! same BLACS context as fm_struct_mo_active. Allocated only when diagnose_liouvillian_eig=.TRUE.. + TYPE(cp_fm_struct_type), POINTER :: fm_struct_ov_pairs => NULL() + ! Truncated MO coefficient slabs C_active(:,:) of size n_ao x mo_active for each spin + ! (only allocated for the linearized path). + TYPE(cp_fm_type), DIMENSION(:), POINTER :: C_active => NULL() + ! Rectangular n_ao x mo_active scratch used by linearized AO<->MO transforms. + TYPE(cp_fm_type), DIMENSION(:), POINTER :: ao_mo_workspace => NULL() REAL(kind=dp) :: spin_degeneracy = 2 REAL(kind=dp), DIMENSION(3) :: field = 0.0_dp - TYPE(cp_fm_type), DIMENSION(:), POINTER :: moments => NULL(), & + TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: moments => NULL(), & moments_field => NULL() INTEGER :: sim_step = 0, & sim_start = 0, & @@ -152,9 +213,18 @@ MODULE rt_bse_types ! Default reference point type for output moments ! Field moments always use zero reference moment_ref_type = use_mom_ref_coac + ! Restart output bookkeeping: RESTART.trace header+prefix and (linearized) C_active are + ! (re)written on the first output_restart call of a run, then .trace is appended per step. + LOGICAL :: restart_trace_written = .FALSE., & + restart_C_written = .FALSE. REAL(kind=dp), DIMENSION(:), POINTER :: user_moment_ref_point => NULL() REAL(kind=dp) :: sim_time = 0.0_dp, & sim_dt = 0.1_dp, & + ! Original-run dt from the trace header on restart (< 0 when not + ! a restart); ENFORCE_MAX_DT reuses it instead of recomputing dt + sim_dt_restart = -1.0_dp, & + maximum_timestep = -1.0_dp, & + omega_max = -1.0_dp, & etrs_threshold = 1.0e-7_dp, & exp_accuracy = 1.0e-10_dp, & ft_damping = 0.0_dp, & @@ -171,6 +241,7 @@ MODULE rt_bse_types rho_section => NULL(), & ft_section => NULL(), & pol_section => NULL(), & + eig_section => NULL(), & moments_section => NULL(), & rtp_section => NULL() LOGICAL :: restart_extracted = .FALSE. @@ -178,16 +249,64 @@ MODULE rt_bse_types ! Different indices signify different spins TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_effective => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_reference => NULL() + !Only for linearised RTBSE + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_reference_singleparticle => NULL() + ! Active single-particle energies = diag(ham_reference_singleparticle), replicated over all + ! ranks. Drives the [H^0,rho]_mn = (eps_m - eps_n) rho_mn element-wise commutator (mo_active x n_spin). + REAL(kind=dp), DIMENSION(:, :), POINTER :: eps_active => NULL() + ! Original run's active eigenvalues stashed from RESTART.trace at read time; compared against + ! the recomputed eps_active once the Hamiltonian is built (consistency heads-up), then freed. + REAL(kind=dp), DIMENSION(:, :), POINTER :: eps_active_restart => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_workspace => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: sigma_SEX => NULL() TYPE(cp_fm_type), DIMENSION(:), POINTER :: sigma_COH => NULL(), & hartree_curr => NULL() + ! AO-sized scratch buffers used in the linearized RT-BSE path so that the MO-sized + ! sigma_COH/sigma_SEX/hartree_curr matrices above can be allocated on + ! fm_struct_mo_active. Only allocated when linearized=.TRUE.. + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: sigma_SEX_ao => NULL() + TYPE(cp_fm_type), DIMENSION(:), POINTER :: hartree_curr_ao => NULL() + ! Open-shell cross-spin Hartree (TDA AO-RI), single shared AO buffers built once per + ! RK4 stage: rho_total_ao_scratch (fm_s struct, matches rho_ao_scratch for the spin sum); + ! hartree_total_ao = V_H[sum] (fm_ks struct, matches sigma_SEX_ao as the Hartree output). + TYPE(cp_cfm_type) :: rho_total_ao_scratch = cp_cfm_type(), & + hartree_total_ao = cp_cfm_type() + ! RI-RS Hartree diagonal reuse: spin-summed grid density n_l = diag(phi.rho.phi^T), harvested + ! from the SEX rho_grid (before its Hadamard, scaled by spin_degeneracy) and consumed by + ! compute_hartree_ri_rs_from_diag so Hartree never rebuilds the grid product. Re/Im; sized + ! n_grid; allocated in initialize_hartree_potential when rirs_kernel. rtbse_env-owned (not + ! bs_env%ri_rs) to avoid aliasing bs_env when passed through get_sigma_complex. + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: hartree_diag_re, hartree_diag_im + ! mo_active x mo_active real workspace pair used in MO-side transforms (linearized only). + TYPE(cp_fm_type), DIMENSION(:), POINTER :: real_workspace_mo => NULL() + ! Liouvillian-diagnostic scratch (allocated only when diagnose_liouvillian_eig=.TRUE.). + ! drho_probe(:) / L_drho(:) are per-spin arrays on fm_struct_mo_active: the joint TDA + ! diagnostic probes one spin and reads the Liouvillian response on every spin block. + ! L_pairs / eigvecs_pairs live on fm_struct_ov_pairs (N_OV_joint x N_OV_joint, the spin + ! blocks stacked). A_mat / B_mat / AmB_scratch / ApB_scratch are ABBA-only blocks holding + ! A, B, (A-B) -> (A-B)^{1/2}, and (A+B) for the Furche reduction; allocated only + ! when .NOT. tda_active (n_spin=1; TDA path uses L_pairs alone). + ! eigenvalues_liouvillian holds the N_OV_joint real eigenvalues from cp_cfm_heevd. + TYPE(cp_cfm_type) :: L_pairs = cp_cfm_type(), & + eigvecs_pairs = cp_cfm_type(), & + A_mat = cp_cfm_type(), & + B_mat = cp_cfm_type(), & + AmB_scratch = cp_cfm_type(), & + ApB_scratch = cp_cfm_type() + REAL(kind=dp), DIMENSION(:), POINTER :: eigenvalues_liouvillian => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho => NULL(), & rho_new => NULL(), & rho_new_last => NULL(), & rho_M => NULL(), & - rho_orig => NULL() + rho_orig => NULL(), & + rho_ao_scratch => NULL(), & + rho_delta_mo => NULL(), & + drho_probe => NULL(), & + L_drho => NULL() + ! Workspace for rk4 in linearized RTBSE + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rk4_coefficients => NULL() + TYPE(cp_fm_type) :: S_inv_fm = cp_fm_type(), & S_fm = cp_fm_type() ! Many routines require overlap in the complex format @@ -198,6 +317,8 @@ MODULE rt_bse_types TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_workspace => NULL() ! Many methods use real and imaginary parts separately - prevent unnecessary reallocation TYPE(cp_fm_type), DIMENSION(:), POINTER :: real_workspace => NULL() + ! AO-sized complex scratch used to stage the real part in get_sigma_complex. + TYPE(cp_cfm_type), DIMENSION(:), POINTER :: sigma_complex_workspace => NULL() ! Workspace required for exact matrix exponentiation REAL(kind=dp), DIMENSION(:), POINTER :: real_eigvals => NULL() COMPLEX(kind=dp), DIMENSION(:), POINTER :: exp_eigvals => NULL() @@ -247,26 +368,29 @@ CONTAINS ! ************************************************************************************************** !> \brief Allocates structures and prepares rtbse_env for run !> \param rtbse_env rtbse_env_type that is initialised -!> \param qs_env Entry point of the calculation +!> \param force_env Force environment - entry point of the calculation +!> \param linearized Optional; when present and .TRUE., configure the environment for the linearized RT-BSE path !> \author Stepan Marek !> \date 02.2024 ! ************************************************************************************************** - SUBROUTINE create_rtbse_env(rtbse_env, qs_env, force_env) + SUBROUTINE create_rtbse_env(rtbse_env, force_env, linearized) TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(qs_environment_type), POINTER :: qs_env TYPE(force_env_type), POINTER :: force_env + LOGICAL, OPTIONAL :: linearized TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(rt_prop_type), POINTER :: rtp TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s TYPE(mo_set_type), DIMENSION(:), POINTER :: mos - INTEGER :: i, k + INTEGER :: i, k, n_ov, i_spin TYPE(section_vals_type), POINTER :: input, bs_sec, md_sec + TYPE(cp_fm_struct_type), POINTER :: mo_struct ! Allocate the storage for the gwbse environment - NULLIFY (rtbse_env) + NULLIFY (rtbse_env, mo_struct) ALLOCATE (rtbse_env) + IF (PRESENT(linearized)) rtbse_env%linearized = linearized ! Extract the other types first - CALL get_qs_env(qs_env, & + CALL get_qs_env(force_env%qs_env, & bs_env=bs_env, & rtp=rtp, & matrix_s=matrix_s, & @@ -279,6 +403,14 @@ CONTAINS END IF ! Number of spins rtbse_env%n_spin = bs_env%n_spin + ! Open shell (n_spin>1) is only implemented and tested for the linearized + ! propagation; the full RT-BSE open-shell path is untested. + IF (rtbse_env%n_spin > 1 .AND. .NOT. rtbse_env%linearized) THEN + CALL cp_abort(__LOCATION__, & + "Open-shell (n_spin>1) RT-BSE is only implemented and tested for the "// & + "linearized propagation. Set DFT%REAL_TIME_PROPAGATION%RTBSE%LRRTBSE "// & + ".TRUE.; the full (non-linearized) open-shell RT-BSE path is untested.") + END IF ! Number of atomic orbitals rtbse_env%n_ao = bs_env%n_ao ! Number of auxiliary basis orbitals @@ -306,6 +438,74 @@ CONTAINS i_val=rtbse_env%etrs_max_iter) CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%MAT_EXP", & i_val=rtbse_env%mat_exp_method) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%ENERGY_CUTOFF_OCC", & + r_val=rtbse_env%rtbse_energy_cutoff_occ) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%ENERGY_CUTOFF_EMPTY", & + r_val=rtbse_env%rtbse_energy_cutoff_empty) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%TDA", & + l_val=rtbse_env%tda_active) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%TDA_SHIFT_TO_FIRST_PEAK", & + l_val=rtbse_env%tda_shift_to_first_peak) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%ENFORCE_MAX_DT", & + l_val=rtbse_env%enforce_max_dt) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%DEBUG_DISABLE_HARTREE", & + l_val=rtbse_env%debug_disable_hartree) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%DEBUG_DISABLE_SEX", & + l_val=rtbse_env%debug_disable_sex) + ! RI-RS kernel switch (KERNEL_RI: DEFAULT=do_gw_ri_rs, RS/AO force, full-RTBSE force-off) + ! is resolved by the shared helper so de_init_bs_env reaches the same verdict when + ! deciding whether to retain nl_3c. + CALL rtbse_resolve_rirs_flag(force_env%qs_env, bs_env, rirs_kernel=rtbse_env%rirs_kernel) + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%DIAGNOSE_LIOUVILLIAN_EIG", & + l_val=rtbse_env%diagnose_liouvillian_eig) + + IF (.NOT. rtbse_env%dft_control%rtp_control%rtp_method == rtp_method_bse_linearized) THEN + rtbse_env%rtbse_energy_cutoff_occ = -1.0_dp + rtbse_env%rtbse_energy_cutoff_empty = -1.0_dp + rtbse_env%enforce_max_dt = .FALSE. + rtbse_env%debug_disable_hartree = .FALSE. + rtbse_env%debug_disable_sex = .FALSE. + rtbse_env%tda_shift_to_first_peak = .FALSE. + ! rirs_kernel is already forced .FALSE. here by rtbse_resolve_rirs_flag. + rtbse_env%diagnose_liouvillian_eig = .FALSE. + END IF + ! First-peak shift only makes sense within TDA; force-disable otherwise. + IF (.NOT. rtbse_env%tda_active) rtbse_env%tda_shift_to_first_peak = .FALSE. + rtbse_env%omega_shift = 0.0_dp + + IF (rtbse_env%tda_active .AND. .NOT. rtbse_env%linearized) THEN + CPABORT("RTBSE TDA keyword requires LINEARIZED_BSE_PROPAGATION=.TRUE.") + END IF + ! Open shell: omega_shift would be referenced to a non-physical cross-spin + ! pseudo-gap (global MIN/MAX over both spins); abort until made per-spin. + IF (rtbse_env%tda_shift_to_first_peak .AND. rtbse_env%n_spin > 1) THEN + CALL cp_abort(__LOCATION__, & + "TDA_SHIFT_TO_FIRST_PEAK is not implemented for open-shell (n_spin>1) "// & + "systems - the first-peak gap estimate would mix spin channels. "// & + "Set TDA_SHIFT_TO_FIRST_PEAK=.FALSE. for open-shell runs.") + END IF + CALL check_qp_gap_sanity(rtbse_env, bs_env) + CALL determine_active_mo_window(rtbse_env, bs_env) + ! Owned active-MO matrix structure (currently identical to the full n_ao x n_ao struct + ! when no truncation is active; will be used by the linearized RT-BSE allocation path). + NULLIFY (rtbse_env%fm_struct_mo_active) + CALL cp_fm_struct_create(rtbse_env%fm_struct_mo_active, & + bs_env%fm_ks_Gamma(1)%matrix_struct%para_env, & + bs_env%fm_ks_Gamma(1)%matrix_struct%context, & + rtbse_env%mo_active, rtbse_env%mo_active) + ! Rectangular n_ao x mo_active struct used for C_active and AO<->MO intermediates + NULLIFY (rtbse_env%fm_struct_ao_mo_active) + CALL cp_fm_struct_create(rtbse_env%fm_struct_ao_mo_active, & + bs_env%fm_ks_Gamma(1)%matrix_struct%para_env, & + bs_env%fm_ks_Gamma(1)%matrix_struct%context, & + rtbse_env%n_ao, rtbse_env%mo_active) + ! Choose the matrix struct used for MO-side persistent matrices. + ! Linearized RT-BSE: mo_active x mo_active. Full RT-BSE: full AO struct (unchanged). + IF (rtbse_env%linearized) THEN + mo_struct => rtbse_env%fm_struct_mo_active + ELSE + mo_struct => bs_env%fm_ks_Gamma(1)%matrix_struct + END IF ! Output unit number, recovered from the post_scf_bandstructure_type rtbse_env%unit_nr = bs_env%unit_nr ! Sim start index and total number of steps as well @@ -332,6 +532,7 @@ CONTAINS rtbse_env%rho_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%DENSITY_MATRIX") rtbse_env%ft_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%MOMENTS_FT") rtbse_env%pol_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%POLARIZABILITY") + rtbse_env%eig_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%LIOUVILLIAN_EIG") ! Warn the user about print sections which are not yet implemented in the RTBSE run CALL warn_section_unused(rtbse_env%rtp_section, "PRINT%CURRENT", & "CURRENT print section not yet implemented for RTBSE.") @@ -343,8 +544,8 @@ CONTAINS "PROJECTION_MO print section not yet implemented for RTBSE.") CALL warn_section_unused(rtbse_env%rtp_section, "PRINT%RESTART_HISTORY", & "RESTART_HISTORY print section not yet implemented for RTBSE.") - ! DEBUG : References to previous environments - rtbse_env%qs_env => qs_env + ! References to the parent qs_env / bs_env + rtbse_env%qs_env => force_env%qs_env rtbse_env%bs_env => bs_env ! Padé refinement rtbse_env%pade_requested = rtbse_env%dft_control%rtp_control%pade_requested @@ -363,45 +564,69 @@ CONTAINS END DO END IF - ! Allocate moments matrices + ! Allocate moments matrices. + ! In linearized RT-BSE these store the MO-active transformed dipole moments; + ! in full RT-BSE they remain AO-sized (initialized from overlap template). NULLIFY (rtbse_env%moments) - ALLOCATE (rtbse_env%moments(3)) + ALLOCATE (rtbse_env%moments(3, rtbse_env%n_spin)) NULLIFY (rtbse_env%moments_field) - ALLOCATE (rtbse_env%moments_field(3)) - DO k = 1, 3 - ! Matrices are created from overlap template - ! Values are initialized in initialize_rtbse_env - CALL cp_fm_create(rtbse_env%moments(k), bs_env%fm_s_Gamma%matrix_struct) - CALL cp_fm_create(rtbse_env%moments_field(k), bs_env%fm_s_Gamma%matrix_struct) + ALLOCATE (rtbse_env%moments_field(3, rtbse_env%n_spin)) + DO i_spin = 1, rtbse_env%n_spin + DO k = 1, 3 + CALL cp_fm_create(rtbse_env%moments(k, i_spin), mo_struct) + CALL cp_fm_create(rtbse_env%moments_field(k, i_spin), mo_struct) + END DO END DO - ! Allocate space for density propagation and other operations + ! Allocate space for density propagation and other operations. + ! In linearized RT-BSE these workspaces are MO-active sized; in full RT-BSE + ! they remain at the full AO size. NULLIFY (rtbse_env%rho_workspace) ALLOCATE (rtbse_env%rho_workspace(4)) DO i = 1, SIZE(rtbse_env%rho_workspace) - CALL cp_cfm_create(rtbse_env%rho_workspace(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%rho_workspace(i), mo_struct) CALL cp_cfm_set_all(rtbse_env%rho_workspace(i), CMPLX(0.0, 0.0, kind=dp)) END DO + + ! TODO: gate workspace allocation so methods skip workspaces they don't need + ! Allocate real workspace NULLIFY (rtbse_env%real_workspace) - SELECT CASE (rtbse_env%mat_exp_method) - CASE (do_exact) - ALLOCATE (rtbse_env%real_workspace(4)) - CASE (do_bch) + IF (rtbse_env%linearized) THEN ALLOCATE (rtbse_env%real_workspace(2)) - CASE DEFAULT - CPABORT("Only exact and BCH matrix propagation implemented in RT-BSE") - END SELECT + ELSE + SELECT CASE (rtbse_env%mat_exp_method) + CASE (do_exact) + ALLOCATE (rtbse_env%real_workspace(4)) + CASE (do_bch) + ALLOCATE (rtbse_env%real_workspace(2)) + CASE DEFAULT + CPABORT("Only exact and BCH matrix propagation implemented in RT-BSE") + END SELECT + END IF DO i = 1, SIZE(rtbse_env%real_workspace) CALL cp_fm_create(rtbse_env%real_workspace(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_fm_set_all(rtbse_env%real_workspace(i), 0.0_dp) END DO - ! Allocate density matrix + NULLIFY (rtbse_env%sigma_complex_workspace) + ALLOCATE (rtbse_env%sigma_complex_workspace(1)) + CALL cp_cfm_create(rtbse_env%sigma_complex_workspace(1), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_set_all(rtbse_env%sigma_complex_workspace(1), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + ! Allocate density matrix (MO-active sized when linearized; AO-sized otherwise) NULLIFY (rtbse_env%rho) ALLOCATE (rtbse_env%rho(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%rho(i), matrix_struct=bs_env%fm_s_Gamma%matrix_struct) + CALL cp_cfm_create(rtbse_env%rho(i), matrix_struct=mo_struct) END DO + ! Allocate additional space for AO density matrix + ! in linearised RTBSE, where default is MO + IF (rtbse_env%linearized) THEN + NULLIFY (rtbse_env%rho_ao_scratch) + ALLOCATE (rtbse_env%rho_ao_scratch(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_create(rtbse_env%rho_ao_scratch(i), matrix_struct=bs_env%fm_s_Gamma%matrix_struct) + END DO + END IF ! Create the inverse overlap matrix, for use in density propagation ! Start by creating the actual overlap matrix CALL cp_fm_create(rtbse_env%S_fm, bs_env%fm_s_Gamma%matrix_struct) @@ -409,19 +634,32 @@ CONTAINS CALL cp_cfm_create(rtbse_env%S_cfm, bs_env%fm_s_Gamma%matrix_struct) ! Create the single particle hamiltonian - ! Allocate workspace + ! Allocate workspace (MO-active sized in linearized RT-BSE; AO sized otherwise) NULLIFY (rtbse_env%ham_workspace) ALLOCATE (rtbse_env%ham_workspace(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_workspace(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%ham_workspace(i), mo_struct) CALL cp_cfm_set_all(rtbse_env%ham_workspace(i), CMPLX(0.0, 0.0, kind=dp)) END DO ! Now onto the Hamiltonian itself + ! full RTBSE: Contains energy differences and Hartree/COHSEX ρ_0 parts + ! linearised RTBSE: Contains only the Hartree/SEX ρ_0 parts as Δε * Δρ(t) need to be updated NULLIFY (rtbse_env%ham_reference) ALLOCATE (rtbse_env%ham_reference(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_reference(i), bs_env%fm_ks_Gamma(i)%matrix_struct) + CALL cp_cfm_create(rtbse_env%ham_reference(i), mo_struct) END DO + ! Single particle Hamiltonian (Δε * Δρ(t)) for updates during timesteps in LR-RTBSE + IF (rtbse_env%linearized) THEN + NULLIFY (rtbse_env%ham_reference_singleparticle) + ALLOCATE (rtbse_env%ham_reference_singleparticle(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_create(rtbse_env%ham_reference_singleparticle(i), mo_struct) + END DO + NULLIFY (rtbse_env%eps_active) + ALLOCATE (rtbse_env%eps_active(rtbse_env%mo_active, rtbse_env%n_spin)) + rtbse_env%eps_active(:, :) = 0.0_dp + END IF ! Create the matrices and workspaces for ETRS propagation NULLIFY (rtbse_env%ham_effective) @@ -435,17 +673,30 @@ CONTAINS ALLOCATE (rtbse_env%rho_M(rtbse_env%n_spin)) ALLOCATE (rtbse_env%rho_orig(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_effective(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%ham_effective(i), mo_struct) CALL cp_cfm_set_all(rtbse_env%ham_effective(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_new(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%rho_new(i), mo_struct) CALL cp_cfm_set_all(rtbse_env%rho_new(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_new_last(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%rho_new_last(i), mo_struct) CALL cp_cfm_set_all(rtbse_env%rho_new_last(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_M(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%rho_M(i), mo_struct) CALL cp_cfm_set_all(rtbse_env%rho_M(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_orig(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%rho_orig(i), mo_struct) END DO + !For LR-RTBSE we need RK4 coefficients - create new workspace + IF (rtbse_env%linearized) THEN + ! Indexed by SPIN, not by RK4 stage: the spin loop is inner to each stage (do_rk4_stage), so every + ! spin's current-stage k must be live at once, but only one stage's k per spin - each is folded + ! into rho_end and the next stage density before the next stage overwrites it. Hence size n_spin. + NULLIFY (rtbse_env%rk4_coefficients) + ALLOCATE (rtbse_env%rk4_coefficients(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_create(rtbse_env%rk4_coefficients(i), mo_struct) + CALL cp_cfm_set_all(rtbse_env%rk4_coefficients(i), CMPLX(0.0, 0.0, kind=dp)) + END DO + END IF + ! Fields for exact diagonalisation NULLIFY (rtbse_env%real_eigvals) ALLOCATE (rtbse_env%real_eigvals(rtbse_env%n_ao)) @@ -463,7 +714,9 @@ CONTAINS NULLIFY (rtbse_env%time_trace) ALLOCATE (rtbse_env%time_trace(rtbse_env%sim_nsteps + 1), source=0.0_dp) - ! Allocate self-energy parts and dynamic Hartree potential + ! Allocate self-energy parts and dynamic Hartree potential. + ! In linearized RT-BSE these matrices hold the MO-active-sized result of the + ! AO->MO transform; the AO-sized buffer is allocated as sigma_*_ao below. NULLIFY (rtbse_env%hartree_curr) NULLIFY (rtbse_env%sigma_SEX) NULLIFY (rtbse_env%sigma_COH) @@ -471,19 +724,111 @@ CONTAINS ALLOCATE (rtbse_env%sigma_SEX(rtbse_env%n_spin)) ALLOCATE (rtbse_env%sigma_COH(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_fm_create(rtbse_env%sigma_COH(i), bs_env%fm_ks_Gamma(1)%matrix_struct) - CALL cp_cfm_create(rtbse_env%sigma_SEX(i), bs_env%fm_ks_Gamma(1)%matrix_struct) - CALL cp_fm_create(rtbse_env%hartree_curr(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_fm_create(rtbse_env%sigma_COH(i), mo_struct) + CALL cp_cfm_create(rtbse_env%sigma_SEX(i), mo_struct) + CALL cp_fm_create(rtbse_env%hartree_curr(i), mo_struct) CALL cp_fm_set_all(rtbse_env%sigma_COH(i), 0.0_dp) CALL cp_cfm_set_all(rtbse_env%sigma_SEX(i), CMPLX(0.0, 0.0, kind=dp)) CALL cp_fm_set_all(rtbse_env%hartree_curr(i), 0.0_dp) END DO + ! AO-sized scratch buffers used by the linearized RT-BSE path + IF (rtbse_env%linearized) THEN + NULLIFY (rtbse_env%hartree_curr_ao) + NULLIFY (rtbse_env%sigma_SEX_ao) + ALLOCATE (rtbse_env%hartree_curr_ao(rtbse_env%n_spin)) + ALLOCATE (rtbse_env%sigma_SEX_ao(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_create(rtbse_env%sigma_SEX_ao(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_fm_create(rtbse_env%hartree_curr_ao(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_set_all(rtbse_env%sigma_SEX_ao(i), CMPLX(0.0, 0.0, kind=dp)) + CALL cp_fm_set_all(rtbse_env%hartree_curr_ao(i), 0.0_dp) + END DO + ! mo_active x mo_active real workspace pair for MO-side intermediates + NULLIFY (rtbse_env%real_workspace_mo) + ALLOCATE (rtbse_env%real_workspace_mo(2)) + DO i = 1, SIZE(rtbse_env%real_workspace_mo) + CALL cp_fm_create(rtbse_env%real_workspace_mo(i), rtbse_env%fm_struct_mo_active) + CALL cp_fm_set_all(rtbse_env%real_workspace_mo(i), 0.0_dp) + END DO + NULLIFY (rtbse_env%ao_mo_workspace) + ALLOCATE (rtbse_env%ao_mo_workspace(1)) + CALL cp_fm_create(rtbse_env%ao_mo_workspace(1), rtbse_env%fm_struct_ao_mo_active) + CALL cp_fm_set_all(rtbse_env%ao_mo_workspace(1), 0.0_dp) + ! Truncated MO coefficient slabs C_active (n_ao x mo_active) for each spin. + ! Filled in initialize_rtbse_env from bs_env%fm_mo_coeff_Gamma via submatrix copy. + NULLIFY (rtbse_env%C_active) + ALLOCATE (rtbse_env%C_active(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_fm_create(rtbse_env%C_active(i), rtbse_env%fm_struct_ao_mo_active) + CALL cp_fm_set_all(rtbse_env%C_active(i), 0.0_dp) + END DO + ! Masked-copy staging scratch for the builder (all propagation paths including closed-shell ABBA). + ! Also used as conjugate-transpose scratch in the TDA consumer. + NULLIFY (rtbse_env%rho_delta_mo) + ALLOCATE (rtbse_env%rho_delta_mo(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_create(rtbse_env%rho_delta_mo(i), rtbse_env%fm_struct_mo_active) + CALL cp_cfm_set_all(rtbse_env%rho_delta_mo(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + ! Shared AO Hartree buffers: widened from (tda_active .OR. n_spin>1) so n_spin=1 ABBA + ! (diagnostic + propagator) gets a dedicated buffer instead of aliasing sigma_SEX_ao. + IF (.NOT. rtbse_env%debug_disable_hartree) THEN + CALL cp_cfm_create(rtbse_env%rho_total_ao_scratch, bs_env%fm_s_Gamma%matrix_struct) + CALL cp_cfm_create(rtbse_env%hartree_total_ao, bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_set_all(rtbse_env%rho_total_ao_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_cfm_set_all(rtbse_env%hartree_total_ao, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END IF + ! Liouvillian-eigenvalue diagnostic state. n_spin=1 enforced upstream. + ! Shared scratch (TDA + ABBA) allocated on diagnose_liouvillian_eig=T; + ! ABBA-only A/B/A±B blocks added below under .NOT. tda_active. Mirror of the + ! existing shared-scratch pattern, with the extra tda_active gate as the deviation. + IF (rtbse_env%diagnose_liouvillian_eig) THEN + ! Joint OV dimension: the spin blocks are stacked (n_spin=1 -> the old single-spin + ! size). drho_probe/L_drho stay mo_active-sized per spin; L_pairs is N_OV_joint. + n_ov = 0 + DO i = 1, rtbse_env%n_spin + n_ov = n_ov + (rtbse_env%n_occ(i) - rtbse_env%first_active_mo + 1)* & + (rtbse_env%last_active_mo - rtbse_env%n_occ(i)) + END DO + NULLIFY (rtbse_env%fm_struct_ov_pairs) + CALL cp_fm_struct_create(rtbse_env%fm_struct_ov_pairs, & + bs_env%fm_ks_Gamma(1)%matrix_struct%para_env, & + bs_env%fm_ks_Gamma(1)%matrix_struct%context, & + n_ov, n_ov) + ALLOCATE (rtbse_env%drho_probe(rtbse_env%n_spin)) + ALLOCATE (rtbse_env%L_drho(rtbse_env%n_spin)) + DO i = 1, rtbse_env%n_spin + CALL cp_cfm_create(rtbse_env%drho_probe(i), rtbse_env%fm_struct_mo_active) + CALL cp_cfm_create(rtbse_env%L_drho(i), rtbse_env%fm_struct_mo_active) + CALL cp_cfm_set_all(rtbse_env%drho_probe(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_cfm_set_all(rtbse_env%L_drho(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END DO + CALL cp_cfm_create(rtbse_env%L_pairs, rtbse_env%fm_struct_ov_pairs) + CALL cp_cfm_create(rtbse_env%eigvecs_pairs, rtbse_env%fm_struct_ov_pairs) + CALL cp_cfm_set_all(rtbse_env%L_pairs, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_cfm_set_all(rtbse_env%eigvecs_pairs, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + NULLIFY (rtbse_env%eigenvalues_liouvillian) + ALLOCATE (rtbse_env%eigenvalues_liouvillian(n_ov)) + rtbse_env%eigenvalues_liouvillian = 0.0_dp + ! ABBA-only Furche-reduction scratch (A, B, A-B->sqrt, A+B). + IF (.NOT. rtbse_env%tda_active) THEN + CALL cp_cfm_create(rtbse_env%A_mat, rtbse_env%fm_struct_ov_pairs) + CALL cp_cfm_create(rtbse_env%B_mat, rtbse_env%fm_struct_ov_pairs) + CALL cp_cfm_create(rtbse_env%AmB_scratch, rtbse_env%fm_struct_ov_pairs) + CALL cp_cfm_create(rtbse_env%ApB_scratch, rtbse_env%fm_struct_ov_pairs) + CALL cp_cfm_set_all(rtbse_env%A_mat, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_cfm_set_all(rtbse_env%B_mat, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_cfm_set_all(rtbse_env%AmB_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + CALL cp_cfm_set_all(rtbse_env%ApB_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) + END IF + END IF + END IF ! Allocate workspaces for get_sigma - CALL create_sigma_workspace(rtbse_env, qs_env) + CALL create_sigma_workspace(rtbse_env) ! Depending on the chosen methods, allocate extra workspace - CALL create_hartree_ri_workspace(rtbse_env, qs_env) + CALL create_hartree_ri_workspace(rtbse_env) END SUBROUTINE create_rtbse_env @@ -519,13 +864,22 @@ CONTAINS CALL cp_cfm_release_pa1(rtbse_env%sigma_SEX) CALL cp_fm_release(rtbse_env%hartree_curr) CALL cp_cfm_release_pa1(rtbse_env%ham_reference) + IF (ASSOCIATED(rtbse_env%ham_reference_singleparticle)) THEN + CALL cp_cfm_release_pa1(rtbse_env%ham_reference_singleparticle) + END IF + IF (ASSOCIATED(rtbse_env%eps_active)) DEALLOCATE (rtbse_env%eps_active) + IF (ASSOCIATED(rtbse_env%eps_active_restart)) DEALLOCATE (rtbse_env%eps_active_restart) CALL cp_cfm_release_pa1(rtbse_env%rho) CALL cp_cfm_release_pa1(rtbse_env%rho_workspace) CALL cp_cfm_release_pa1(rtbse_env%rho_new) CALL cp_cfm_release_pa1(rtbse_env%rho_new_last) CALL cp_cfm_release_pa1(rtbse_env%rho_M) CALL cp_cfm_release_pa1(rtbse_env%rho_orig) + IF (ASSOCIATED(rtbse_env%rk4_coefficients)) THEN + CALL cp_cfm_release_pa1(rtbse_env%rk4_coefficients) + END IF CALL cp_fm_release(rtbse_env%real_workspace) + IF (ASSOCIATED(rtbse_env%sigma_complex_workspace)) CALL cp_cfm_release_pa1(rtbse_env%sigma_complex_workspace) CALL cp_fm_release(rtbse_env%S_inv_fm) CALL cp_fm_release(rtbse_env%S_fm) CALL cp_cfm_release(rtbse_env%S_cfm) @@ -548,33 +902,209 @@ CONTAINS ! Deallocate the neighbour list that is not deallocated in gw anymore IF (ASSOCIATED(rtbse_env%bs_env%nl_3c%ij_list)) CALL neighbor_list_3c_destroy(rtbse_env%bs_env%nl_3c) + ! Release linearized-only AO scratches and MO-side workspaces + IF (ASSOCIATED(rtbse_env%rho_ao_scratch)) CALL cp_cfm_release_pa1(rtbse_env%rho_ao_scratch) + IF (ASSOCIATED(rtbse_env%sigma_SEX_ao)) CALL cp_cfm_release_pa1(rtbse_env%sigma_SEX_ao) + IF (ASSOCIATED(rtbse_env%hartree_curr_ao)) CALL cp_fm_release(rtbse_env%hartree_curr_ao) + IF (ASSOCIATED(rtbse_env%real_workspace_mo)) CALL cp_fm_release(rtbse_env%real_workspace_mo) + IF (ASSOCIATED(rtbse_env%ao_mo_workspace)) CALL cp_fm_release(rtbse_env%ao_mo_workspace) + IF (ASSOCIATED(rtbse_env%C_active)) CALL cp_fm_release(rtbse_env%C_active) + IF (ASSOCIATED(rtbse_env%rho_delta_mo)) CALL cp_cfm_release_pa1(rtbse_env%rho_delta_mo) + ! Release shared bare-Hartree scratch. Mirror the alloc gate exactly (linearized .AND. + ! .NOT. debug_disable_hartree, every shell incl closed-shell ABBA) — the old + ! (tda_active .OR. n_spin>1) gate leaked both buffers on the closed-shell ABBA path. + IF (rtbse_env%linearized .AND. .NOT. rtbse_env%debug_disable_hartree) THEN + CALL cp_cfm_release(rtbse_env%rho_total_ao_scratch) + CALL cp_cfm_release(rtbse_env%hartree_total_ao) + END IF + ! Release the RI-RS Hartree diagonal-reuse accumulators (allocated in initialize_hartree_potential). + IF (ALLOCATED(rtbse_env%hartree_diag_re)) DEALLOCATE (rtbse_env%hartree_diag_re) + IF (ALLOCATED(rtbse_env%hartree_diag_im)) DEALLOCATE (rtbse_env%hartree_diag_im) + ! Release Liouvillian-diagnostic scratch (only when the diagnostic was requested). + IF (rtbse_env%diagnose_liouvillian_eig) THEN + IF (ASSOCIATED(rtbse_env%drho_probe)) CALL cp_cfm_release_pa1(rtbse_env%drho_probe) + IF (ASSOCIATED(rtbse_env%L_drho)) CALL cp_cfm_release_pa1(rtbse_env%L_drho) + CALL cp_cfm_release(rtbse_env%L_pairs) + CALL cp_cfm_release(rtbse_env%eigvecs_pairs) + IF (ASSOCIATED(rtbse_env%eigenvalues_liouvillian)) DEALLOCATE (rtbse_env%eigenvalues_liouvillian) + IF (.NOT. rtbse_env%tda_active) THEN + CALL cp_cfm_release(rtbse_env%A_mat) + CALL cp_cfm_release(rtbse_env%B_mat) + CALL cp_cfm_release(rtbse_env%AmB_scratch) + CALL cp_cfm_release(rtbse_env%ApB_scratch) + END IF + IF (ASSOCIATED(rtbse_env%fm_struct_ov_pairs)) THEN + CALL cp_fm_struct_release(rtbse_env%fm_struct_ov_pairs) + END IF + END IF + ! Release owned active-MO matrix structures + IF (ASSOCIATED(rtbse_env%fm_struct_mo_active)) THEN + CALL cp_fm_struct_release(rtbse_env%fm_struct_mo_active) + END IF + IF (ASSOCIATED(rtbse_env%fm_struct_ao_mo_active)) THEN + CALL cp_fm_struct_release(rtbse_env%fm_struct_ao_mo_active) + END IF ! Deallocate the storage for the environment itself DEALLOCATE (rtbse_env) ! Nullify to make sure it is not used again NULLIFY (rtbse_env) END SUBROUTINE release_rtbse_env + +! ************************************************************************************************** +!> \brief Abort if the quasiparticle spectrum handed to the propagator is inverted or has diverged. +!> +!> Tests the fundamental gap per spin channel - not E(HOMO+1) - E(HOMO), since G0W0 reorders levels - +!> on the very array the propagator consumes. Under RTBSE_HAMILTONIAN KS the quasiparticle energies +!> never enter the propagator, so a broken G0W0 spectrum is irrelevant there and does not abort. +!> \param rtbse_env RT-BSE environment with n_ao, n_occ, n_spin, ham_reference_type populated. +!> \param bs_env Bandstructure environment providing the eigenvalues. +! ************************************************************************************************** + SUBROUTINE check_qp_gap_sanity(rtbse_env, bs_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + INTEGER :: homo, ispin + REAL(KIND=dp) :: gap, gap_scf + + IF (rtbse_env%ham_reference_type /= rtp_bse_ham_g0w0) RETURN + + DO ispin = 1, rtbse_env%n_spin + homo = rtbse_env%n_occ(ispin) + IF (homo < 1 .OR. homo >= rtbse_env%n_ao) CYCLE + + gap = MINVAL(bs_env%eigenval_G0W0(homo + 1:rtbse_env%n_ao, 1, ispin)) - & + MAXVAL(bs_env%eigenval_G0W0(1:homo, 1, ispin)) + gap_scf = MINVAL(bs_env%eigenval_scf_Gamma(homo + 1:rtbse_env%n_ao, ispin)) - & + MAXVAL(bs_env%eigenval_scf_Gamma(1:homo, ispin)) + + ! requiring a healthy SCF gap keeps the inversion test from firing on a genuine metal + IF (gap < -eps_qp_gap .AND. gap_scf > eps_qp_gap) THEN + CALL cp_abort(__LOCATION__, & + "RTBSE: G0W0 gap of spin "//TRIM(ADJUSTL(cp_to_string(ispin)))// & + " is negative ("//TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))// & + " eV): propagating an inverted spectrum is meaningless. Check the GW "// & + "numerical parameters, or use RTBSE_HAMILTONIAN KS.") + ELSE IF (ABS(gap) > max_qp_gap) THEN + CALL cp_abort(__LOCATION__, & + "RTBSE: G0W0 gap of spin "//TRIM(ADJUSTL(cp_to_string(ispin)))// & + " is implausibly large ("// & + TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))//" eV): the GW step "// & + "has likely diverged. Check the GW numerical parameters, or use "// & + "RTBSE_HAMILTONIAN KS.") + END IF + END DO + + END SUBROUTINE check_qp_gap_sanity + +! ************************************************************************************************** +!> \brief Determine the combined active MO window for linearized RT-BSE truncation. +!> +!> Evaluates BSE-like cutoff indices per spin from the requested single-particle spectrum +!> (G0W0 or KS Gamma-point eigenvalues) and collapses them into a single combined window +!> covering both spin channels by choosing the most inclusive bounds. Issues a CPWARN if the +!> spin-resolved cutoff candidates differ. When cutoffs are disabled (or the run is not +!> linearized RT-BSE), the window is set to the full MO range. +!> \param rtbse_env RT-BSE environment with cutoff values, n_ao, n_occ, n_spin, ham_reference_type +!> already populated. +!> \param bs_env Bandstructure environment providing the eigenvalues. +! ************************************************************************************************** + SUBROUTINE determine_active_mo_window(rtbse_env, bs_env) + TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + CHARACTER(LEN=*), PARAMETER :: routineN = "determine_active_mo_window" + + INTEGER :: handle, ispin, n_ao_full, n_virt + INTEGER :: homo_red, virt_red, homo_incl, virt_incl + INTEGER :: combined_first_occ, combined_last_virt + INTEGER :: first_occ_prev, last_virt_prev + LOGICAL :: spins_differ, do_truncation + REAL(KIND=dp) :: cutoff_occ, cutoff_empty + + CALL timeset(routineN, handle) + + n_ao_full = rtbse_env%n_ao + cutoff_occ = rtbse_env%rtbse_energy_cutoff_occ + cutoff_empty = rtbse_env%rtbse_energy_cutoff_empty + do_truncation = rtbse_env%linearized .AND. (cutoff_occ > 0.0_dp .OR. cutoff_empty > 0.0_dp) + + ! Default: full MO window + rtbse_env%first_active_mo = 1 + rtbse_env%last_active_mo = n_ao_full + rtbse_env%mo_active = n_ao_full + rtbse_env%active_mo_truncation = .FALSE. + + IF (.NOT. do_truncation) THEN + CALL timestop(handle) + RETURN + END IF + + combined_first_occ = n_ao_full + combined_last_virt = 1 + first_occ_prev = -1 + last_virt_prev = -1 + spins_differ = .FALSE. + + DO ispin = 1, rtbse_env%n_spin + n_virt = n_ao_full - rtbse_env%n_occ(ispin) + ! Cut on the DFT axis, as LRBSE does: it is ascending by construction, so the window is a + ! well-defined contiguous MO range, which is all C_active can extract. The G0W0 axis is + ! not ordered. + CALL determine_cutoff_indices(bs_env%eigenval_scf_Gamma(:, ispin), & + rtbse_env%n_occ(ispin), n_virt, & + homo_red, virt_red, homo_incl, virt_incl, & + cutoff_occ, cutoff_empty) + ! Translate the per-spin candidate to global MO indices [homo_incl, homo + virt_incl] + IF (ispin > 1) THEN + IF (homo_incl /= first_occ_prev .OR. (rtbse_env%n_occ(ispin) + virt_incl) /= last_virt_prev) THEN + spins_differ = .TRUE. + END IF + END IF + first_occ_prev = homo_incl + last_virt_prev = rtbse_env%n_occ(ispin) + virt_incl + combined_first_occ = MIN(combined_first_occ, homo_incl) + combined_last_virt = MAX(combined_last_virt, rtbse_env%n_occ(ispin) + virt_incl) + END DO + + IF (spins_differ) THEN + CPWARN("RTBSE: spin-resolved active MO cutoff candidates differ; using combined window.") + END IF + + rtbse_env%first_active_mo = combined_first_occ + rtbse_env%last_active_mo = combined_last_virt + rtbse_env%mo_active = combined_last_virt - combined_first_occ + 1 + rtbse_env%active_mo_truncation = (rtbse_env%mo_active < n_ao_full) + + CALL timestop(handle) + END SUBROUTINE determine_active_mo_window + ! ************************************************************************************************** !> \brief Allocates the workspaces for Hartree RI method !> \note RI method calculates the Hartree contraction without the use of DBT, as it cannot emulate vectors !> \param rtbse_env -!> \param qs_env Quickstep environment - entry point of calculation !> \author Stepan Marek !> \date 05.2024 ! ************************************************************************************************** - SUBROUTINE create_hartree_ri_workspace(rtbse_env, qs_env) + SUBROUTINE create_hartree_ri_workspace(rtbse_env) TYPE(rtbse_env_type) :: rtbse_env - TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env - CALL get_qs_env(qs_env, bs_env=bs_env) + ! Skip the AO-RI Hartree scratch when the RT-BSE Hartree path is fully RI-RS. + ! In that case rho_dbcsr / v_ao_dbcsr / int_3c_array are never read. + ! get_sigma_real (AO-RI SX) used to borrow rho_dbcsr as a workspace; that + ! cross-dependency was removed by giving get_sigma_real its own local + ! dbcsr scratch (see rt_bse.F::get_sigma_real). rho_dbcsr is now AO-RI + ! Hartree only, as its name suggests. + IF (rtbse_env%rirs_kernel) RETURN + + CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) CALL dbcsr_create(rtbse_env%rho_dbcsr, name="Sparse density", template=bs_env%mat_ao_ao%matrix) CALL dbcsr_create(rtbse_env%v_ao_dbcsr, name="Sparse Hartree", template=bs_env%mat_ao_ao%matrix) CALL create_hartree_ri_3c(rtbse_env%rho_dbcsr, rtbse_env%int_3c_array, rtbse_env%n_ao, rtbse_env%n_RI, & bs_env%basis_set_AO, bs_env%basis_set_RI, bs_env%i_RI_start_from_atom, & - bs_env%ri_metric, qs_env, rtbse_env%unit_nr) + bs_env%ri_metric, rtbse_env%qs_env, rtbse_env%unit_nr) END SUBROUTINE create_hartree_ri_workspace ! ************************************************************************************************** !> \brief Separated method for allocating the 3c integrals for RI Hartree @@ -676,27 +1206,31 @@ CONTAINS SUBROUTINE release_hartree_ri_workspace(rtbse_env) TYPE(rtbse_env_type) :: rtbse_env - DEALLOCATE (rtbse_env%int_3c_array) - - CALL dbcsr_release(rtbse_env%rho_dbcsr) - - CALL dbcsr_release(rtbse_env%v_dbcsr) - - CALL dbcsr_release(rtbse_env%v_ao_dbcsr) - + ! Mirror the gate in create_hartree_ri_workspace and the v_dbcsr gate in + ! initialize_hartree_potential. With one KERNEL_RI switch the AO-RI Hartree + ! scratch (3c integrals + dbcsr work + v_dbcsr) is created iff `.NOT. rirs_kernel`. + IF (.NOT. rtbse_env%rirs_kernel) THEN + DEALLOCATE (rtbse_env%int_3c_array) + CALL dbcsr_release(rtbse_env%rho_dbcsr) + CALL dbcsr_release(rtbse_env%v_ao_dbcsr) + CALL dbcsr_release(rtbse_env%v_dbcsr) + END IF END SUBROUTINE release_hartree_ri_workspace ! ************************************************************************************************** !> \brief Allocates the workspaces for self-energy determination routine !> \param rtbse_env Structure for holding information and workspace structures -!> \param qs_env Quickstep environment - entry point of calculation !> \author Stepan Marek !> \date 02.2024 ! ************************************************************************************************** - SUBROUTINE create_sigma_workspace(rtbse_env, qs_env) + SUBROUTINE create_sigma_workspace(rtbse_env) TYPE(rtbse_env_type) :: rtbse_env - TYPE(qs_environment_type), POINTER :: qs_env - CALL create_sigma_workspace_qs_only(qs_env, rtbse_env%screened_dbt, rtbse_env%w_dbcsr, & + ! Skip the AO-RI sigma scratch (W matrix + 3c integrals + work tensors) + ! when the RT-BSE SEX path is fully RI-RS — these workspaces are read + ! only by get_sigma in the `.NOT. rirs_kernel` branches. + IF (rtbse_env%rirs_kernel) RETURN + + CALL create_sigma_workspace_qs_only(rtbse_env%qs_env, rtbse_env%screened_dbt, rtbse_env%w_dbcsr, & rtbse_env%t_3c_w, rtbse_env%t_3c_work_RI_AO__AO, & rtbse_env%t_3c_work2_RI_AO__AO, rtbse_env%greens_dbt) END SUBROUTINE create_sigma_workspace @@ -746,6 +1280,9 @@ CONTAINS SUBROUTINE release_sigma_workspace(rtbse_env) TYPE(rtbse_env_type) :: rtbse_env + ! Mirror the gate in create_sigma_workspace. + IF (rtbse_env%rirs_kernel) RETURN + CALL dbt_destroy(rtbse_env%t_3c_w) CALL dbt_destroy(rtbse_env%t_3c_work_RI_AO__AO) CALL dbt_destroy(rtbse_env%t_3c_work2_RI_AO__AO) diff --git a/src/emd/rt_propagation_ft.F b/src/emd/rt_propagation_ft.F index f3b5021231..fee7959fd0 100644 --- a/src/emd/rt_propagation_ft.F +++ b/src/emd/rt_propagation_ft.F @@ -111,7 +111,7 @@ CONTAINS POINTER :: ft_samples, samples, samples_input INTEGER :: handle, i, i0, j, nsamples, nseries, stat LOGICAL :: subtract_initial - REAL(kind=dp) :: damping, t0, t_total + REAL(kind=dp) :: damping, delta_t, t0, t_total TYPE(fft_plan_type) :: fft_plan ! For value and result series: Index 1 - different series, Index 2 - single series entry @@ -120,6 +120,9 @@ CONTAINS ! Start with t0 t0 = 0.0_dp IF (PRESENT(t0_opt)) t0 = t0_opt + IF (SIZE(time_series) < 2) THEN + CPABORT("multi_fft requires at least two time samples.") + END IF ! Determine zero index i0 = 1 DO i = 1, SIZE(time_series) @@ -130,8 +133,18 @@ CONTAINS END DO ! Determine nsamples nsamples = SIZE(time_series) - i0 + 1 + IF (nsamples < 2) THEN + CPABORT("multi_fft requires at least two samples in the selected time window.") + END IF ! Determine total time t_total = time_series(SIZE(time_series)) - time_series(i0) + delta_t = time_series(i0 + 1) - time_series(i0) + IF (t_total /= t_total .OR. ABS(t_total) >= HUGE(t_total) .OR. t_total <= 0.0_dp) THEN + CPABORT("multi_fft detected an abnormal total time window (NaN/Inf/non-positive).") + END IF + IF (delta_t /= delta_t .OR. ABS(delta_t) >= HUGE(delta_t) .OR. delta_t <= 0.0_dp) THEN + CPABORT("multi_fft detected an abnormal timestep (NaN/Inf/non-positive).") + END IF ! Now can determine default damping damping = 4.0_dp/(t_total) ! Damping option supplied in au units of time @@ -143,6 +156,9 @@ CONTAINS damping = 0.0_dp END IF END IF + IF (damping /= damping .OR. ABS(damping) >= HUGE(damping)) THEN + CPABORT("multi_fft detected an abnormal damping factor (NaN/Inf).") + END IF ! subtract initial subtract_initial = .TRUE. subtract_value = 0.0_dp @@ -159,6 +175,10 @@ CONTAINS ! Calculate the omega series values, ordered from negative to positive IF (PRESENT(omega_series)) THEN CALL fft_freqs(nsamples, t_total, omega_series, fft_ordering_opt=.FALSE.) + IF (ANY(omega_series /= omega_series) .OR. & + ANY(ABS(omega_series) >= HUGE(omega_series))) THEN + CPABORT("multi_fft produced abnormal frequencies (NaN/Inf).") + END IF END IF ! Use FFTW3 library @@ -187,7 +207,7 @@ CONTAINS CALL fft_create_plan_1dm(fft_plan, fft_library("FFTW3"), -1, .FALSE., nsamples, nseries, samples, ft_samples, 3) ! Carry out the transform ! Scale by dt - to transform to an integral - CALL fft_1dm(fft_plan, samples_input, ft_samples, time_series(2) - time_series(1), stat) + CALL fft_1dm(fft_plan, samples_input, ft_samples, delta_t, stat) IF (stat /= 0) THEN ! Failed fftw3 - go to backup ! Uses value_series and result_series - no need to reassign data @@ -207,6 +227,12 @@ CONTAINS result_series(i, :) = ft_samples((i - 1)*nsamples + 1:i*nsamples) END DO END IF + IF (ANY(REAL(result_series, kind=dp) /= REAL(result_series, kind=dp)) .OR. & + ANY(AIMAG(result_series) /= AIMAG(result_series)) .OR. & + ANY(ABS(REAL(result_series, kind=dp)) >= HUGE(1.0_dp)) .OR. & + ANY(ABS(AIMAG(result_series)) >= HUGE(1.0_dp))) THEN + CPABORT("multi_fft produced abnormal Fourier amplitudes (NaN/Inf).") + END IF ! Deallocate CALL fft_dealloc(samples) CALL fft_dealloc(ft_samples) diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index 8a78ff7660..4a6e8db128 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -1289,15 +1289,18 @@ CONTAINS INTEGER, OPTIONAL :: info_opt TYPE(cell_type), OPTIONAL, POINTER :: cell + CHARACTER(len=*), PARAMETER :: routineN = 'print_ft' + CHARACTER(len=11), DIMENSION(2) :: file_extensions CHARACTER(len=20), ALLOCATABLE, DIMENSION(:) :: headers CHARACTER(len=21) :: prefix CHARACTER(len=5) :: prefix_format COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:) :: omegas_complex, omegas_pade - COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: field_results, field_results_pade, & - pol_results, pol_results_pade, & - results, results_pade, value_series - INTEGER :: ft_unit, i, info_unit, k, n, n_elems, & + COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: field_results, field_results_pade, & + pol_results, pol_results_pade, pol_results_pade_spin_total, pol_results_spin_total, & + results, results_pade, results_pade_spin_total, results_spin_total, value_series + INTEGER :: ft_unit, handle, i, idx_omega_zero, & + info_unit, k, k_static, n, n_elems, & n_pade, nspin LOGICAL :: do_moments_ft, do_polarizability REAL(kind=dp) :: damping, t0 @@ -1306,6 +1309,7 @@ CONTAINS TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: moment_ft_section, pol_section + CALL timeset(routineN, handle) ! For results, using spin * direction for first index, e.g. for nspin = 2 ! results(1,:) = (spin=1 and direction=1,:), ! results(5,:) = (spin=2 and direction=2,:) @@ -1400,6 +1404,40 @@ CONTAINS END IF CALL cp_print_key_finished_output(ft_unit, logger, moment_ft_section) END DO + ! Spin-summed total moments FT (open shell only; inert for nspin=1) + IF (nspin > 1) THEN + ALLOCATE (results_spin_total(3, n)) + results_spin_total(:, :) = (0.0_dp, 0.0_dp) + DO i = 1, nspin + DO k = 1, 3 + results_spin_total(k, :) = results_spin_total(k, :) + results(3*(i - 1) + k, :) + END DO + END DO + ft_unit = cp_print_key_unit_nr(logger, moment_ft_section, extension="_SPIN_TOTAL.dat", & + file_form="FORMATTED", file_position="REWIND") + IF (ft_unit > 0) THEN + ALLOCATE (headers(7)) + headers(2) = " x,real [at.u.]" + headers(3) = " x,imag [at.u.]" + headers(4) = " y,real [at.u.]" + headers(5) = " y,imag [at.u.]" + headers(6) = " z,real [at.u.]" + headers(7) = " z,imag [at.u.]" + IF (info_unit == ft_unit) THEN + headers(1) = "# Energy [eV]" + prefix = " MOMENTS_FT|" + prefix_format = "(A12)" + CALL print_rt_file(ft_unit, headers, omegas, results_spin_total, & + prefix, prefix_format, evolt) + ELSE + headers(1) = "# omega [at.u.]" + CALL print_rt_file(ft_unit, headers, omegas, results_spin_total) + END IF + DEALLOCATE (headers) + END IF + CALL cp_print_key_finished_output(ft_unit, logger, moment_ft_section) + DEALLOCATE (results_spin_total) + END IF END IF IF (rtc%pade_requested .AND. (do_moments_ft .OR. do_polarizability)) THEN @@ -1443,6 +1481,39 @@ CONTAINS DEALLOCATE (headers) END IF END DO + ! Spin-summed total moments-FT Padé (open shell only; inert for nspin=1) + IF (nspin > 1) THEN + ALLOCATE (results_pade_spin_total(3, n_pade)) + results_pade_spin_total(:, :) = (0.0_dp, 0.0_dp) + DO i = 1, nspin + DO k = 1, 3 + results_pade_spin_total(k, :) = results_pade_spin_total(k, :) + results_pade(3*(i - 1) + k, :) + END DO + END DO + ft_unit = cp_print_key_unit_nr(logger, moment_ft_section, extension="_PADE_SPIN_TOTAL.dat", & + file_form="FORMATTED", file_position="REWIND") + IF (ft_unit > 0) THEN + ALLOCATE (headers(7)) + headers(2) = " x,real,pade [at.u.]" + headers(3) = " x,imag,pade [at.u.]" + headers(4) = " y,real,pade [at.u.]" + headers(5) = " y,imag,pade [at.u.]" + headers(6) = " z,real,pade [at.u.]" + headers(7) = " z,imag,pade [at.u.]" + IF (info_unit == ft_unit) THEN + headers(1) = "# Energy [eV]" + prefix = " MOMENTS_FT_PADE|" + prefix_format = "(A17)" + CALL print_rt_file(ft_unit, headers, omegas_pade_real, results_pade_spin_total, & + prefix, prefix_format, evolt) + ELSE + headers(1) = "# omega [at.u.]" + CALL print_rt_file(ft_unit, headers, omegas_pade_real, results_pade_spin_total) + END IF + DEALLOCATE (headers) + END IF + DEALLOCATE (results_pade_spin_total) + END IF END IF IF (do_polarizability) THEN @@ -1483,7 +1554,77 @@ CONTAINS DEALLOCATE (headers) END IF CALL cp_print_key_finished_output(ft_unit, logger, pol_section) + ! Static polarizability alpha(0): pol_results at the FFT-grid omega + ! closest to zero. Re is alpha(0); Im should be machine-zero (sanity). + IF (info_unit > 0) THEN + idx_omega_zero = MINLOC(ABS(omegas), DIM=1) + IF (i == 1) THEN + WRITE (info_unit, '(A,T22,A,T28,A,T36,A,T59,A)') & + " STATIC_POL|", "spin", "element", "Re [a.u.]", "Im [a.u.]" + END IF + DO k_static = 1, n_elems + WRITE (info_unit, '(A,T22,I4,T28,I3,",",I3,T36,ES22.10E3,T59,ES22.10E3)') & + " STATIC_POL|", i, & + rtc%print_pol_elements(k_static, 1), & + rtc%print_pol_elements(k_static, 2), & + REAL(pol_results(k_static, idx_omega_zero), kind=dp), & + AIMAG(pol_results(k_static, idx_omega_zero)) + END DO + END IF END DO + ! Spin-summed total polarizability (open shell only; inert for nspin=1). + ! Field is spin-independent, so (sum_s moments_s)/field == sum_s (moments_s/field). + IF (nspin > 1) THEN + ALLOCATE (pol_results_spin_total(n_elems, n)) + pol_results_spin_total(:, :) = (0.0_dp, 0.0_dp) + DO k = 1, n_elems + DO i = 1, nspin + pol_results_spin_total(k, :) = pol_results_spin_total(k, :) + & + results(3*(i - 1) + rtc%print_pol_elements(k, 1), :) + END DO + pol_results_spin_total(k, :) = pol_results_spin_total(k, :)/ & + (field_results(rtc%print_pol_elements(k, 2), :) + & + 1.0e-10*field_results(rtc%print_pol_elements(k, 2), 2)) + END DO + ft_unit = cp_print_key_unit_nr(logger, pol_section, extension="_SPIN_TOTAL.dat", & + file_form="FORMATTED", file_position="REWIND") + IF (ft_unit > 0) THEN + ALLOCATE (headers(2*n_elems + 1)) + DO k = 1, n_elems + WRITE (headers(2*k), "(A16,I2,I2)") "real pol. elem.", & + rtc%print_pol_elements(k, 1), & + rtc%print_pol_elements(k, 2) + WRITE (headers(2*k + 1), "(A16,I2,I2)") "imag pol. elem.", & + rtc%print_pol_elements(k, 1), & + rtc%print_pol_elements(k, 2) + END DO + IF (info_unit == ft_unit) THEN + headers(1) = "# Energy [eV]" + prefix = " POLARIZABILITY|" + prefix_format = "(A16)" + CALL print_rt_file(ft_unit, headers, omegas, pol_results_spin_total, & + prefix, prefix_format, evolt) + ELSE + headers(1) = "# omega [at.u.]" + CALL print_rt_file(ft_unit, headers, omegas, pol_results_spin_total) + END IF + DEALLOCATE (headers) + END IF + CALL cp_print_key_finished_output(ft_unit, logger, pol_section) + ! Static polarizability total (header row already emitted by the per-spin block) + IF (info_unit > 0) THEN + idx_omega_zero = MINLOC(ABS(omegas), DIM=1) + DO k_static = 1, n_elems + WRITE (info_unit, '(A,T22,A,T28,I3,",",I3,T36,ES22.10E3,T59,ES22.10E3)') & + " STATIC_POL|", "TOT", & + rtc%print_pol_elements(k_static, 1), & + rtc%print_pol_elements(k_static, 2), & + REAL(pol_results_spin_total(k_static, idx_omega_zero), kind=dp), & + AIMAG(pol_results_spin_total(k_static, idx_omega_zero)) + END DO + END IF + DEALLOCATE (pol_results_spin_total) + END IF END IF ! Padé polarizability @@ -1539,6 +1680,46 @@ CONTAINS END IF CALL cp_print_key_finished_output(ft_unit, logger, pol_section) END DO + ! Spin-summed total Padé polarizability (open shell only; inert for nspin=1) + IF (nspin > 1) THEN + ALLOCATE (pol_results_pade_spin_total(n_elems, n_pade)) + pol_results_pade_spin_total(:, :) = (0.0_dp, 0.0_dp) + DO k = 1, n_elems + DO i = 1, nspin + pol_results_pade_spin_total(k, :) = pol_results_pade_spin_total(k, :) + & + results_pade(3*(i - 1) + rtc%print_pol_elements(k, 1), :) + END DO + pol_results_pade_spin_total(k, :) = pol_results_pade_spin_total(k, :)/( & + field_results_pade(rtc%print_pol_elements(k, 2), :) + & + field_results_pade(rtc%print_pol_elements(k, 2), 2)*1.0e-10_dp) + END DO + ft_unit = cp_print_key_unit_nr(logger, pol_section, extension="_PADE_SPIN_TOTAL.dat", & + file_form="FORMATTED", file_position="REWIND") + IF (ft_unit > 0) THEN + ALLOCATE (headers(2*n_elems + 1)) + DO k = 1, n_elems + WRITE (headers(2*k), "(A16,I2,I2)") "re,pade,pol.", & + rtc%print_pol_elements(k, 1), & + rtc%print_pol_elements(k, 2) + WRITE (headers(2*k + 1), "(A16,I2,I2)") "im,pade,pol.", & + rtc%print_pol_elements(k, 1), & + rtc%print_pol_elements(k, 2) + END DO + IF (info_unit == ft_unit) THEN + headers(1) = "# Energy [eV]" + prefix = " POLARIZABILITY_PADE|" + prefix_format = "(A21)" + CALL print_rt_file(ft_unit, headers, omegas_pade_real, pol_results_pade_spin_total, & + prefix, prefix_format, evolt) + ELSE + headers(1) = "# omega [at.u.]" + CALL print_rt_file(ft_unit, headers, omegas_pade_real, pol_results_pade_spin_total) + END IF + DEALLOCATE (headers) + END IF + CALL cp_print_key_finished_output(ft_unit, logger, pol_section) + DEALLOCATE (pol_results_pade_spin_total) + END IF DEALLOCATE (field_results_pade) DEALLOCATE (pol_results_pade) END IF @@ -1559,6 +1740,9 @@ CONTAINS DEALLOCATE (results) DEALLOCATE (omegas) END IF + + CALL timestop(handle) + END SUBROUTINE print_ft ! ************************************************************************************************** diff --git a/src/greenx_interface.F b/src/greenx_interface.F index be070d3bc6..50a5253c8b 100644 --- a/src/greenx_interface.F +++ b/src/greenx_interface.F @@ -13,7 +13,8 @@ MODULE greenx_interface USE kinds, ONLY: dp USE cp_log_handling, ONLY: cp_logger_type, & - cp_get_default_logger + cp_get_default_logger, & + cp_logger_get_default_io_unit USE cp_output_handling, ONLY: cp_print_key_unit_nr, & cp_print_key_finished_output, & cp_print_key_generate_filename, & @@ -209,15 +210,22 @@ CONTAINS y_eval INTEGER, OPTIONAL :: n_pade_opt #if defined (__GREENX) + CHARACTER(len=*), PARAMETER :: routineN = 'greenx_refine_ft' + INTEGER :: fit_start, & fit_end, & max_fit, & n_fit, & n_pade, & n_eval, & - i + i, & + handle, & + unit_nr + TYPE(cp_logger_type), POINTER :: logger TYPE(params) :: pade_params + CALL timeset(routineN, handle) + ! Get the sizes from arrays max_fit = SIZE(x_fit) n_eval = SIZE(x_eval) @@ -241,10 +249,30 @@ CONTAINS n_pade = n_fit/2 IF (PRESENT(n_pade_opt)) n_pade = n_pade_opt + ! Too few FT points (e.g. very short propagation with &FT on) leave n_pade < 1; + ! the Thiele recurrence would then divide by zero. Skip, returning zeros. + IF (n_pade < 1) THEN + CPWARN("FT deck too short for Padé; raise STEPS or disable &FT.") + y_eval(1:n_eval) = CMPLX(0.0, 0.0, kind=dp) + CALL timestop(handle) + RETURN + END IF + ! Warn about a large number of Padé parameters IF (n_pade > 1000) THEN CPWARN("More then 1000 Padé parameters requested - may reduce with FIT_E_MIN/FIT_E_MAX.") END IF + + ! The Padé order is derived from the FT bins inside [FIT_E_MIN, FIT_E_MAX]; report it so a + ! spectrum's fit is reconstructable from the log. Distinct from the GW AC Padé (nparam_pade). + logger => cp_get_default_logger() + unit_nr = cp_logger_get_default_io_unit(logger) + IF (unit_nr > 0) THEN + WRITE (UNIT=unit_nr, FMT="(T3,A,T45,I6,I8,2F11.4)") & + "GREENX FT_PADE| n_pade, n_fit, window [eV]", n_pade, n_fit, & + REAL(x_fit(fit_start), kind=dp)*evolt, REAL(x_fit(fit_end), kind=dp)*evolt + END IF + ! TODO : Symmetry mode settable? ! Here, we assume that ft corresponds to transform of real trace pade_params = create_thiele_pade(n_pade, x_fit(fit_start:fit_end), y_fit(fit_start:fit_end), & @@ -254,6 +282,7 @@ CONTAINS y_eval(1:n_eval) = evaluate_thiele_pade_at(pade_params, x_eval) CALL free_params(pade_params) + CALL timestop(handle) #else ! Mark used MARK_USED(fit_e_min) diff --git a/src/gw_large_cell_gamma.F b/src/gw_large_cell_gamma.F index 96ab647bdb..574f484230 100644 --- a/src/gw_large_cell_gamma.F +++ b/src/gw_large_cell_gamma.F @@ -64,7 +64,8 @@ MODULE gw_large_cell_gamma USE gw_utils, ONLY: analyt_conti_and_print,& de_init_bs_env,& time_to_freq - USE input_constants, ONLY: rtp_method_bse + USE input_constants, ONLY: rtp_method_bse,& + rtp_method_bse_linearized USE input_section_types, ONLY: section_vals_type USE kinds, ONLY: default_path_length,& dp,& @@ -145,7 +146,7 @@ CONTAINS ! Σ^c_λσ(iτ,k=0) -> Σ^c_nn(ϵ,k); ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ,k) + Σ^x_nn(k) - v^xc_nn(k) CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) - CALL de_init_bs_env(bs_env) + CALL de_init_bs_env(qs_env, bs_env) CALL timestop(handle) @@ -1030,7 +1031,14 @@ CONTAINS ! Marek : Reading of the W(w=0) potential for RTP ! TODO : is the condition bs_env%all_W_exist sufficient for reading? - IF (bs_env%rtp_method == rtp_method_bse) THEN + ! This block builds + ! bs_env%fm_W_MIC_freq_zero specifically for RT-BSE consumption (read by + ! rt_bse_linearized.F initialize_cohsex_selfenergy and by + ! rt_bse_ri_rs.F rt_bse_ri_rs_ensure_W0_grid). RT-BSE-specific compute + ! embedded in GW; left here because moving it would require keeping + ! fm_W_MIC_time alive past compute_W_MIC. + IF (bs_env%rtp_method == rtp_method_bse .OR. & + bs_env%rtp_method == rtp_method_bse_linearized) THEN CALL cp_fm_create(bs_env%fm_W_MIC_freq_zero, bs_env%fm_W_MIC_freq%matrix_struct) t1 = m_walltime() CALL fm_read(bs_env%fm_W_MIC_freq_zero, bs_env, "W_freq_rtp", 0) @@ -1134,7 +1142,9 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(mat_chi_Gamma_tau) ! Marek : Fourier transform W^MIC(itau) back to get it at a specific im.frequency point - iomega = 0 - IF (bs_env%rtp_method == rtp_method_bse) THEN + ! Same RT-BSE coupling as read_W_MIC_time. + IF (bs_env%rtp_method == rtp_method_bse .OR. & + bs_env%rtp_method == rtp_method_bse_linearized) THEN t1 = m_walltime() CALL cp_fm_create(bs_env%fm_W_MIC_freq_zero, bs_env%fm_W_MIC_freq%matrix_struct) ! Set to zero diff --git a/src/gw_large_cell_gamma_ri_rs.F b/src/gw_large_cell_gamma_ri_rs.F index 5ed9974a7b..b60e118222 100644 --- a/src/gw_large_cell_gamma_ri_rs.F +++ b/src/gw_large_cell_gamma_ri_rs.F @@ -89,7 +89,11 @@ MODULE gw_large_cell_Gamma_ri_rs CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_large_cell_Gamma_ri_rs' - PUBLIC :: gw_calc_large_cell_Gamma_ri_rs + PUBLIC :: gw_calc_large_cell_Gamma_ri_rs, & + contract_A_B_A, & + hadamard_product_inplace, & + release_dbcsr_topology_and_matrices, & + setup_square_topology CONTAINS @@ -152,6 +156,7 @@ CONTAINS !!======================================================================== CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) + bs_env%ri_rs%grid_built = .TRUE. !!======================================================================== !! 4. Compute Independent-Particle Polarizability (χ) @@ -199,7 +204,7 @@ CONTAINS !!======================================================================== CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) - CALL de_init_bs_env(bs_env) + CALL de_init_bs_env(qs_env, bs_env) CALL timestop(handle) @@ -1357,6 +1362,46 @@ CONTAINS END SUBROUTINE hadamard_product +! ************************************************************************************************** +!> \brief In-place Hadamard A <- fac * (A ◦ B). Value mutation only (no block insert/delete), +!> so iterating A while writing through the block pointer is safe. +!> \param matrix_A in/out factor (overwritten by the product) +!> \param matrix_B second factor (looked up; blocks absent in B zero the A block) +!> \param fac (Scaling factor applied to the product) +! ************************************************************************************************** + SUBROUTINE hadamard_product_inplace(matrix_A, matrix_B, fac) + + TYPE(dbcsr_type), INTENT(INOUT) :: matrix_A, matrix_B + REAL(KIND=dp), INTENT(IN) :: fac + + CHARACTER(LEN=*), PARAMETER :: routineN = 'hadamard_product_inplace' + + INTEGER :: col, handle, row + LOGICAL :: found + REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk_A, blk_B + TYPE(dbcsr_iterator_type) :: iter + + CALL timeset(routineN, handle) + + CALL dbcsr_iterator_start(iter, matrix_A) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, row, col, blk_A) + + CALL dbcsr_get_block_p(matrix_B, row, col, blk_B, found) + + IF (found) THEN + blk_A(:, :) = fac*blk_A(:, :)*blk_B(:, :) + ELSE + ! If B is sparse here, the product is zero + blk_A(:, :) = 0.0_dp + END IF + END DO + CALL dbcsr_iterator_stop(iter) + + CALL timestop(handle) + + END SUBROUTINE hadamard_product_inplace + ! ************************************************************************************************** !> \brief Compute screened Coulomb interaction matrix !> \param bs_env ... diff --git a/src/gw_non_periodic_ri_rs.F b/src/gw_non_periodic_ri_rs.F index 40b9532453..915b654f4e 100644 --- a/src/gw_non_periodic_ri_rs.F +++ b/src/gw_non_periodic_ri_rs.F @@ -109,7 +109,8 @@ MODULE gw_non_periodic_ri_rs INTEGER(KIND=int_8), PARAMETER, PRIVATE :: dbcsr_msg_elem_limit = INT(HUGE(0_int_4), int_8) PUBLIC :: gw_calc_non_periodic_ri_rs, ri_rs_grid_assembler, & - get_basis_offsets, precompute_ri_rs_radii, solve_D_lp_distributed + get_basis_offsets, precompute_ri_rs_radii, solve_D_lp_distributed, & + atomic_basis_at_grid_point, compute_coeff_Z_lP CONTAINS @@ -173,6 +174,8 @@ CONTAINS ! ======================================================================== CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) + ! flag the RI-RS grid as built so a subsequent RT-BSE run reuses Z_lP instead of rebuilding it + bs_env%ri_rs%grid_built = .TRUE. ! ======================================================================== ! 4. Polarizability matrix χ on the imaginary-time grid @@ -219,7 +222,7 @@ CONTAINS ! ======================================================================== CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) - CALL de_init_bs_env(bs_env) + CALL de_init_bs_env(qs_env, bs_env) CALL timestop(handle) @@ -532,8 +535,14 @@ CONTAINS suffix = "_def2-tzvp-rs.ion" ELSE IF (bs_env%ri_rs%grid_select == 2) THEN suffix = "_cc-pvtz-rs.ion" + ELSE IF (bs_env%ri_rs%grid_select == 3) THEN + IF (LEN_TRIM(bs_env%ri_rs%grid_file_suffix) > 0) THEN + suffix = TRIM(bs_env%ri_rs%grid_file_suffix) + ELSE + suffix = "_rirs.ion" + END IF ELSE - CPABORT("Unknown grid_select value. Valid options are 1 (def2-TZVPP) or 2 (cc-pVTZ).") + CPABORT("Unknown grid_select (1=def2-TZVPP, 2=cc-pVTZ, 3=user-provided).") END IF nkind = SIZE(atomic_kind_set) diff --git a/src/gw_small_cell_full_kp.F b/src/gw_small_cell_full_kp.F index 6090d40408..9dc891c980 100644 --- a/src/gw_small_cell_full_kp.F +++ b/src/gw_small_cell_full_kp.F @@ -112,7 +112,7 @@ CONTAINS ! Σ^c_λσ^R(iτ,k=0) -> Σ^c_nn(ϵ,k); ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ,k) + Σ^x_nn(k) - v^xc_nn(k) CALL compute_QP_energies(bs_env) - CALL de_init_bs_env(bs_env) + CALL de_init_bs_env(qs_env, bs_env) CALL timestop(handle) diff --git a/src/gw_utils.F b/src/gw_utils.F index 9caead6cee..c039f425a5 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -60,14 +60,10 @@ MODULE gw_utils USE distribution_2d_types, ONLY: distribution_2d_type USE gw_communication, ONLY: fm_to_local_array USE gw_integrals, ONLY: build_3c_integral_block - USE input_constants, ONLY: do_potential_truncated,& - large_cell_Gamma,& - large_cell_Gamma_ri_rs,& - non_periodic_ri_rs,& - ri_rpa_g0w0_crossing_newton,& - rtp_method_bse,& - small_cell_full_kp,& - xc_none + USE input_constants, ONLY: & + do_potential_truncated, large_cell_Gamma, large_cell_Gamma_ri_rs, non_periodic_ri_rs, & + ri_rpa_g0w0_crossing_newton, rtp_bse_kernel_ri_ao, rtp_bse_kernel_ri_rs, rtp_method_bse, & + rtp_method_bse_linearized, small_cell_full_kp, xc_none USE input_section_types, ONLY: section_vals_get,& section_vals_get_subs_vals,& section_vals_type,& @@ -139,7 +135,8 @@ MODULE gw_utils PUBLIC :: create_and_init_bs_env_for_gw, de_init_bs_env, get_i_j_atoms, & compute_xkp, time_to_freq, analyt_conti_and_print, & - add_R, is_cell_in_index_to_cell, get_V_tr_R, power + add_R, is_cell_in_index_to_cell, get_V_tr_R, power, & + rtbse_resolve_rirs_flag CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_utils' @@ -234,15 +231,19 @@ CONTAINS END SUBROUTINE create_and_init_bs_env_for_gw ! ************************************************************************************************** -!> \brief ... -!> \param bs_env ... +!> \brief Releases the memory-heavy GW intermediates that cannot be freed in bs_env_release, +!> retaining the 3c neighbor list only when an AO-RI RT-BSE self-energy still needs it +!> \param qs_env Quickstep environment - used to resolve the RT-BSE kernel-RI setting +!> \param bs_env Bandstructure environment whose intermediates are released ! ************************************************************************************************** - SUBROUTINE de_init_bs_env(bs_env) + SUBROUTINE de_init_bs_env(qs_env, bs_env) + TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env CHARACTER(LEN=*), PARAMETER :: routineN = 'de_init_bs_env' INTEGER :: handle + LOGICAL :: retain_nl_3c, rirs_kernel CALL timeset(routineN, handle) ! deallocate quantities here which: @@ -250,8 +251,16 @@ CONTAINS ! 2. consume a lot of memory and should not be kept until the quantity is ! deallocated in bs_env_release + ! nl_3c feeds only the AO-RI SEX self-energy (compute_3c_integrals); the RI-RS SEX + ! path never reads it, and AO-RI Hartree builds its own blocks. Retain iff AO-RI SEX. + retain_nl_3c = .FALSE. IF (ASSOCIATED(bs_env%nl_3c%ij_list) .AND. (bs_env%rtp_method == rtp_method_bse)) THEN - IF (bs_env%unit_nr > 0) WRITE (bs_env%unit_nr, *) "Retaining nl_3c for RTBSE" + CALL rtbse_resolve_rirs_flag(qs_env, bs_env, rirs_kernel=rirs_kernel) + retain_nl_3c = .NOT. rirs_kernel + END IF + + IF (retain_nl_3c) THEN + IF (bs_env%unit_nr > 0) WRITE (bs_env%unit_nr, *) "Retaining nl_3c for AO-RI RT-BSE self-energy" ELSE CALL neighbor_list_3c_destroy(bs_env%nl_3c) END IF @@ -262,6 +271,52 @@ CONTAINS END SUBROUTINE de_init_bs_env +! ************************************************************************************************** +!> \brief Resolve the linRTBSE RI-RS kernel switch from the KERNEL_RI input and the GW default. +!> \param qs_env Quickstep environment - source of the input section and the RTP method +!> \param bs_env Bandstructure environment - provides the do_gw_ri_rs default +!> \param rirs_kernel (optional) .TRUE. if the Hartree + SEX kernels use the RI-RS grid backend +!> \author Maximilian Graml +!> \note Single source of truth shared by create_rtbse_env (sets the flag) and de_init_bs_env +!> (decides whether to retain nl_3c). KERNEL_RI=DEFAULT follows bs_env%do_gw_ri_rs; +!> RS/AO force; forced .FALSE. for non-linearized (full) RT-BSE (warn on explicit RS). +! ************************************************************************************************** + SUBROUTINE rtbse_resolve_rirs_flag(qs_env, bs_env, rirs_kernel) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + LOGICAL, INTENT(OUT), OPTIONAL :: rirs_kernel + + INTEGER :: kernel_ri + LOGICAL :: my_rirs_kernel + TYPE(dft_control_type), POINTER :: dft_control + TYPE(section_vals_type), POINTER :: input + + NULLIFY (dft_control, input) + CALL get_qs_env(qs_env, dft_control=dft_control, input=input) + + CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%KERNEL_RI", & + i_val=kernel_ri) + SELECT CASE (kernel_ri) + CASE (rtp_bse_kernel_ri_rs) + my_rirs_kernel = .TRUE. + CASE (rtp_bse_kernel_ri_ao) + my_rirs_kernel = .FALSE. + CASE DEFAULT ! rtp_bse_kernel_ri_default + my_rirs_kernel = bs_env%do_gw_ri_rs + END SELECT + + ! RI-RS kernels are implemented for linearized RT-BSE only; full RT-BSE always uses AO-RI. + IF (dft_control%rtp_control%rtp_method /= rtp_method_bse_linearized) THEN + IF (kernel_ri == rtp_bse_kernel_ri_rs) THEN + CPWARN("RI-RS kernels are implemented for linearized RT-BSE only; forcing AO") + END IF + my_rirs_kernel = .FALSE. + END IF + + IF (PRESENT(rirs_kernel)) rirs_kernel = my_rirs_kernel + + END SUBROUTINE rtbse_resolve_rirs_flag + ! ************************************************************************************************** !> \brief ... !> \param bs_env ... @@ -296,6 +351,7 @@ CONTAINS CALL section_vals_val_get(gw_sec, "PRINT%PRINT_DBT_CONTRACT_VERBOSE", l_val=bs_env%print_contract_verbose) CALL section_vals_val_get(gw_sec, "TIKHONOV", r_val=bs_env%ri_rs%tikhonov) CALL section_vals_val_get(gw_sec, "GRID_SELECT", i_val=bs_env%ri_rs%grid_select) + CALL section_vals_val_get(gw_sec, "GRID_FILE_SUFFIX", c_val=bs_env%ri_rs%grid_file_suffix) CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_RI", r_val=bs_env%ri_rs%cutoff_radius_ri_rs) CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_AO", r_val=bs_env%ri_rs%cutoff_radius_ri_ao) CALL section_vals_val_get(gw_sec, "N_PROCS_PER_ATOM_Z_LP", i_val=bs_env%ri_rs%n_procs_per_atom_z_lp) @@ -1324,10 +1380,12 @@ CONTAINS WRITE (frmt, '(A)') '(3A,I1,A)' WRITE (f_S_p, frmt) TRIM(prefix), bs_env%Sigma_p_name, "_0", ind, ".matrix" WRITE (f_S_n, frmt) TRIM(prefix), bs_env%Sigma_n_name, "_0", ind, ".matrix" - ELSE IF (i_t_or_w < 100) THEN + ELSE IF (ind < 100) THEN WRITE (frmt, '(A)') '(3A,I2,A)' WRITE (f_S_p, frmt) TRIM(prefix), bs_env%Sigma_p_name, "_", ind, ".matrix" WRITE (f_S_n, frmt) TRIM(prefix), bs_env%Sigma_n_name, "_", ind, ".matrix" + ELSE + CPABORT('Please implement more than 99 combined spin+freq indices.') END IF INQUIRE (file=TRIM(f_S_p), exist=Sigma_pos_time_exists) @@ -1341,7 +1399,8 @@ CONTAINS END DO ! Marek : In the RTBSE run, check also for zero frequency W - IF (bs_env%rtp_method == rtp_method_bse) THEN + IF (bs_env%rtp_method == rtp_method_bse .OR. & + bs_env%rtp_method == rtp_method_bse_linearized) THEN WRITE (f_W_t, '(3A,I1,A)') TRIM(prefix), "W_freq_rtp", "_0", 0, ".matrix" INQUIRE (file=TRIM(f_W_t), exist=W_time_exists) bs_env%all_W_exist = bs_env%all_W_exist .AND. W_time_exists @@ -1918,6 +1977,15 @@ CONTAINS E_max = MAX(E_max, E_max_ispin) END DO + ! Open-shell uses ONE minimax grid for the combined [min gap, max span] over both spins (the + ! superset covers each channel, so it is accurate; per-spin grids would only be more efficient). + IF (bs_env%n_spin > 1) THEN + CALL cp_hint(__LOCATION__, & + "Open-shell GW uses one minimax grid spanning [min gap, max span] across both "// & + "spin channels; raise NUM_TIME_FREQ_POINTS if QP convergence is marginal for "// & + "strongly spin-asymmetric systems.") + END IF + E_range = E_max/E_min ALLOCATE (points_and_weights(2*num_time_freq_points)) diff --git a/src/input_constants.F b/src/input_constants.F index 093c401959..3de5c8335e 100644 --- a/src/input_constants.F +++ b/src/input_constants.F @@ -980,11 +980,16 @@ MODULE input_constants rtp_localize_each = 2 INTEGER, PARAMETER, PUBLIC :: rtp_method_tddft = 1, & - rtp_method_bse = 2 + rtp_method_bse = 2, & + rtp_method_bse_linearized = 3 INTEGER, PARAMETER, PUBLIC :: rtp_bse_ham_ks = 1, & rtp_bse_ham_g0w0 = 2 + INTEGER, PARAMETER, PUBLIC :: rtp_bse_kernel_ri_default = 0, & + rtp_bse_kernel_ri_rs = 1, & + rtp_bse_kernel_ri_ao = 2 + ! how to solve polarizable force fields INTEGER, PARAMETER, PUBLIC :: do_fist_pol_none = 1, & do_fist_pol_sc = 2, & diff --git a/src/input_cp2k_dft.F b/src/input_cp2k_dft.F index 74c65fff9f..5ed7d32a5a 100644 --- a/src/input_cp2k_dft.F +++ b/src/input_cp2k_dft.F @@ -44,7 +44,8 @@ MODULE input_cp2k_dft numerical, plus_u_lowdin, plus_u_mulliken, plus_u_mulliken_charges, real_time_propagation, & rel_dkh, rel_none, rel_pot_erfc, rel_pot_full, rel_sczora_mp, rel_trans_atom, & rel_trans_full, rel_trans_molecule, rel_zora, rel_zora_full, rel_zora_mp, & - rtp_bse_ham_g0w0, rtp_bse_ham_ks, rtp_method_bse, rtp_method_tddft, sccs_andreussi, & + rtp_bse_ham_g0w0, rtp_bse_ham_ks, rtp_bse_kernel_ri_ao, rtp_bse_kernel_ri_default, & + rtp_bse_kernel_ri_rs, rtp_method_bse, rtp_method_tddft, sccs_andreussi, & sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, sccs_derivative_fft, & sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, sic_list_all, sic_list_unpaired, & sic_mauri_spz, sic_mauri_us, sic_none, slater, use_mom_ref_coac, use_mom_ref_com, & @@ -1980,6 +1981,21 @@ CONTAINS CALL keyword_release(keyword) CALL section_add_subsection(print_section, print_key) CALL section_release(print_key) + ! Liouvillian eigenvalue diagnostic (linearized RT-BSE, TDA only) + CALL cp_print_key_section_create(print_key, __LOCATION__, "LIOUVILLIAN_EIG", & + description="Prints the eigenvalues of the linearized RT-BSE "// & + "Liouvillian on the OV subspace, computed once at job init from a "// & + "matrix-free probe of the kernel (no time propagation). In TDA this "// & + "equals the Casida-A eigenvalue problem and gives a broadening-free, "// & + "finite-time-free correctness check against bse_full.F. "// & + "Activated by RTBSE%DIAGNOSE_LIOUVILLIAN_EIG. Output lists "// & + "eigenvalues in atomic units and eV.", & + print_level=medium_print_level, common_iter_levels=0, & + each_iter_names=s2a("MD"), & + each_iter_values=[1], & + filename="LIOUVILLIAN_EIG") + CALL section_add_subsection(print_section, print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, __LOCATION__, "E_CONSTITUENTS", & description="Print the energy constituents (relevant to RTP) which make up "// & @@ -2055,6 +2071,133 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + ! Switch for linearized rtbse propagation + CALL keyword_create(keyword, __LOCATION__, name="LINEARIZED_BSE_PROPAGATION", & + variants=s2a("LRRTBSE"), & + description="Linearizes the BSE propagation", & + usage="LINEARIZED_BSE_PROPAGATION .T.", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + ! Energy cutoff (occupied) for active MO window in linearized RT-BSE + CALL keyword_create(keyword, __LOCATION__, name="ENERGY_CUTOFF_OCC", & + description="Energy cutoff (relative to HOMO) defining the lowest "// & + "occupied molecular orbital included in the active MO window of the "// & + "linearized RT-BSE propagation. Only used when "// & + "LINEARIZED_BSE_PROPAGATION=.TRUE.. A non-positive value disables the "// & + "occupied truncation.", & + usage="ENERGY_CUTOFF_OCC 5.0", & + unit_str="eV", & + default_r_val=-1.0_dp/evolt) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + ! Energy cutoff (empty) for active MO window in linearized RT-BSE + CALL keyword_create(keyword, __LOCATION__, name="ENERGY_CUTOFF_EMPTY", & + description="Energy cutoff (relative to LUMO) defining the highest "// & + "virtual molecular orbital included in the active MO window of the "// & + "linearized RT-BSE propagation. Only used when "// & + "LINEARIZED_BSE_PROPAGATION=.TRUE.. A non-positive value disables the "// & + "virtual truncation.", & + usage="ENERGY_CUTOFF_EMPTY 5.0", & + unit_str="eV", & + default_r_val=-1.0_dp/evolt) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="ENFORCE_MAX_DT", & + description="For linearized RT-BSE, recompute TIMESTEP and STEPS so the same total "// & + "propagation time is covered with the largest timestep that does not exceed the "// & + "estimated RK4 stability limit.", & + usage="ENFORCE_MAX_DT", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + ! Tamm-Dancoff approximation for the linearized RT-BSE kernel + CALL keyword_create(keyword, __LOCATION__, name="TDA", & + description="Apply the Tamm-Dancoff approximation to the linearized RT-BSE kernel: "// & + "the Hartree and screened-exchange contributions are restricted so that the OV and VO "// & + "blocks of the density response remain decoupled (i.e. only A-block coupling is kept, "// & + "B-block coupling is dropped). Only effective when "// & + "LINEARIZED_BSE_PROPAGATION=.TRUE..", & + usage="TDA", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + ! First-peak shift for the TDA path + CALL keyword_create(keyword, __LOCATION__, name="TDA_SHIFT_TO_FIRST_PEAK", & + description="For the linearized RT-BSE TDA path, shift the active-MO single-particle "// & + "diagonals by +Omega_0/2 (occupied) and -Omega_0/2 (virtual) with "// & + "Omega_0 = eps_min_ai, so the lowest active OV mode oscillates at zero frequency "// & + "in the rotating frame (RK4-exact for peak 1). omega_max becomes the full active "// & + "OV width Delta = eps_max_ai - eps_min_ai. The rotation is undone at I/O so "// & + "observables remain in the lab frame. Only effective when TDA=.TRUE.. "// & + "Use with caution, additional convergence checks w.r.t. dt needed.", & + usage="TDA_SHIFT_TO_FIRST_PEAK", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="DEBUG_DISABLE_HARTREE", & + description="Debug option for linearized RT-BSE: disables the Hartree kernel in both "// & + "the static reference initialization and the propagation. The Coulomb RI setup is "// & + "still built so the run stays internally consistent.", & + usage="DEBUG_DISABLE_HARTREE", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="KERNEL_RI", & + description="Select the RI framework used to evaluate the linearized RT-BSE "// & + "Hartree and screened-exchange kernels (propagation and reference). "// & + "DEFAULT infers from the GW flavor: RI-RS if the GW_RI_RS section was active, "// & + "AO-RI otherwise. RS/AO force that framework regardless of how GW was run. The "// & + "RI-RS grid (mat_phi_mu_l, mat_Z_lP) and the V_grid/W0_grid kernels are built on "// & + "demand. RI-RS is implemented for linearized RT-BSE only; for full RT-BSE an "// & + "explicit RS is overridden to AO with a warning.", & + usage="KERNEL_RI RS", & + enum_c_vals=s2a("DEFAULT", "RS", "AO"), & + enum_i_vals=[rtp_bse_kernel_ri_default, rtp_bse_kernel_ri_rs, rtp_bse_kernel_ri_ao], & + enum_desc=s2a("Infer from the GW flavor (GW_RI_RS active -> RS, else AO).", & + "Real-space RI grid kernels (linearized RT-BSE only).", & + "AO-RI kernels."), & + default_i_val=rtp_bse_kernel_ri_default, n_var=1) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="DEBUG_DISABLE_SEX", & + description="Debug option for linearized RT-BSE: disables the screened-exchange kernel "// & + "in both the static reference initialization and the propagation.", & + usage="DEBUG_DISABLE_SEX", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + ! Liouvillian eigenvalue diagnostic (matrix-free probe at init; TDA + ABBA) + CALL keyword_create(keyword, __LOCATION__, name="DIAGNOSE_LIOUVILLIAN_EIG", & + description="Diagnostic for linearized RT-BSE: at job initialization, build the "// & + "Liouvillian on the OV subspace by probing the kernel routine with canonical OV basis "// & + "vectors, then diagonalize. In TDA this equals the Casida-A eigenvalue problem, giving a "// & + "broadening-free, finite-time-free correctness check against bse_full.F. "// & + "In ABBA it builds and diagonalizes the full coupled (A, B) Liouvillian via the "// & + "Furche reduction. "// & + "Output is controlled by the LIOUVILLIAN_EIG print key in the parent "// & + "&REAL_TIME_PROPAGATION%&PRINT section.", & + usage="DIAGNOSE_LIOUVILLIAN_EIG", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + END SUBROUTINE create_rtbse_section ! ************************************************************************************************** !> \brief Creates the subsection for Fourier transform options applicable to RTP output diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index 9d08365f9d..9e9ecb5e4d 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -2632,12 +2632,24 @@ CONTAINS "(1) def2-TZVPP: Available for elements up to the fourth row "// & "of the periodic table (see https://doi.org/10.1021/acs.jctc.1c00101). "// & "(2) cc-pVTZ: Available for H, C, N, and O atoms "// & - "(see https://doi.org/10.1063/1.5090605).", & + "(see https://doi.org/10.1063/1.5090605). "// & + "(3) User-provided grids: per-element grid files supplied by the "// & + "user, read as ri_rs_grid/ in the same format as "// & + "the built-in sets; the suffix is _rirs.ion by default and can be "// & + "changed with GRID_FILE_SUFFIX.", & usage="GRID_SELECT 1", & default_i_val=1) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="GRID_FILE_SUFFIX", & + description="Overrides the per-element grid file suffix used by "// & + "GRID_SELECT 3; grid files are read as ri_rs_grid/.", & + usage="GRID_FILE_SUFFIX _my-grids.ion", & + default_lc_val="") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_RI", & description="Real-space cutoff radius (in Angstrom) for evaluating "// & "the RI-RS integration domain $B^P$. Overrides the default "// & diff --git a/src/mp2_gpw.F b/src/mp2_gpw.F index 46cb0e6a20..a4e5b00af6 100644 --- a/src/mp2_gpw.F +++ b/src/mp2_gpw.F @@ -139,11 +139,11 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_gpw_main' - INTEGER :: blacs_grid_layout, bse_lev_virt, color_sub, dimen_RI, dimen_RI_red, eri_method, & - handle, ispin, local_unit_nr, my_group_L_end, my_group_L_size, my_group_L_start, nmo, & - nspins, potential_type, ri_metric_type - INTEGER, ALLOCATABLE, DIMENSION(:) :: ends_array_mc, ends_array_mc_block, gw_corr_lev_occ, & - gw_corr_lev_virt, homo, starts_array_mc, starts_array_mc_block + INTEGER :: blacs_grid_layout, color_sub, dimen_RI, dimen_RI_red, eri_method, handle, ispin, & + local_unit_nr, my_group_L_end, my_group_L_size, my_group_L_start, nmo, nspins, & + potential_type, ri_metric_type + INTEGER, ALLOCATABLE, DIMENSION(:) :: bse_lev_virt, ends_array_mc, ends_array_mc_block, & + gw_corr_lev_occ, gw_corr_lev_virt, homo, starts_array_mc, starts_array_mc_block INTEGER, DIMENSION(3) :: periodic LOGICAL :: blacs_repeatable, do_bse, do_im_time, do_kpoints_cubic_RPA, my_do_gw, & my_do_ri_mp2, my_do_ri_rpa, my_do_ri_sos_laplace_mp2 @@ -151,7 +151,6 @@ CONTAINS Emp2_EX_BB, eps_gvg_rspace_old, & eps_pgf_orb_old, eps_rho_rspace_old REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Eigenval - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: BIb_C_bse_ab, BIb_C_bse_ij REAL(KIND=dp), DIMENSION(:), POINTER :: mo_eigenvalues TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(block_ind_type), ALLOCATABLE, & @@ -174,10 +173,9 @@ CONTAINS TYPE(dbt_type) :: t_3c_M TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_O TYPE(dft_control_type), POINTER :: dft_control - TYPE(group_dist_d1_type) :: gd_array, gd_B_all, gd_B_occ_bse, & - gd_B_virt_bse + TYPE(group_dist_d1_type) :: gd_array, gd_B_all TYPE(group_dist_d1_type), ALLOCATABLE, & - DIMENSION(:) :: gd_B_virtual + DIMENSION(:) :: gd_B_occ_bse, gd_B_virt_bse, gd_B_virtual TYPE(hfx_compression_type), ALLOCATABLE, & DIMENSION(:, :, :) :: t_3c_O_compressed TYPE(kpoint_type), POINTER :: kpoints, kpoints_from_DFT @@ -189,7 +187,8 @@ CONTAINS TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(three_dim_real_array), ALLOCATABLE, & - DIMENSION(:) :: BIb_C, BIb_C_gw + DIMENSION(:) :: BIb_C, BIb_C_bse_ab, BIb_C_bse_ij, & + BIb_C_gw CALL timeset(routineN, handle) @@ -341,7 +340,7 @@ CONTAINS ! check if we want to do ri-g0w0 on top of ri-rpa my_do_gw = mp2_env%ri_rpa%do_ri_g0w0 - ALLOCATE (gw_corr_lev_occ(nspins), gw_corr_lev_virt(nspins)) + ALLOCATE (gw_corr_lev_occ(nspins), gw_corr_lev_virt(nspins), bse_lev_virt(nspins)) gw_corr_lev_occ(1) = mp2_env%ri_g0w0%corr_mos_occ gw_corr_lev_virt(1) = mp2_env%ri_g0w0%corr_mos_virt IF (nspins == 2) THEN @@ -350,20 +349,18 @@ CONTAINS END IF IF (do_bse) THEN - IF (nspins > 1) THEN - CPABORT("BSE not implemented for open shell calculations") - END IF !Keep default behavior for occupied ! We do not implement an explicit bse_lev_occ here, because the small number of occupied levels ! does not critically influence the memory - bse_lev_virt = gw_corr_lev_virt(1) + ! bse_lev_virt is per-spin (= the per-spin GW-corrected virtual count): the (ab|K) block is sized per spin + bse_lev_virt(:) = gw_corr_lev_virt(:) END IF ! After the components are inside of the routines, we can move this line insight the branch ALLOCATE (mo_coeff_o(nspins), mo_coeff_v(nspins), mo_coeff_all(nspins), mo_coeff_gw(nspins)) ! Always allocate for usage in call of replicate_mat_to_subgroup - ALLOCATE (mo_coeff_o_bse(1), mo_coeff_v_bse(1)) + ALLOCATE (mo_coeff_o_bse(nspins), mo_coeff_v_bse(nspins)) ! for imag. time, we do not need this IF (.NOT. do_im_time) THEN @@ -377,7 +374,7 @@ CONTAINS mo_coeff_o(ispin)%matrix, mo_coeff_v(ispin)%matrix, & mo_coeff_all(ispin)%matrix, mo_coeff_gw(ispin)%matrix, & my_do_gw, gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), do_bse, & - bse_lev_virt, mo_coeff_o_bse(1)%matrix, mo_coeff_v_bse(1)%matrix, & + bse_lev_virt(ispin), mo_coeff_o_bse(ispin)%matrix, mo_coeff_v_bse(ispin)%matrix, & mp2_env%mp2_gpw%eps_filter) END DO @@ -519,10 +516,12 @@ CONTAINS END IF IF (do_bse) THEN - CALL dbcsr_release(mo_coeff_o_bse(1)%matrix) - CALL dbcsr_release(mo_coeff_v_bse(1)%matrix) - DEALLOCATE (mo_coeff_o_bse(1)%matrix) - DEALLOCATE (mo_coeff_v_bse(1)%matrix) + DO ispin = 1, nspins + CALL dbcsr_release(mo_coeff_o_bse(ispin)%matrix) + CALL dbcsr_release(mo_coeff_v_bse(ispin)%matrix) + DEALLOCATE (mo_coeff_o_bse(ispin)%matrix) + DEALLOCATE (mo_coeff_v_bse(ispin)%matrix) + END DO END IF DEALLOCATE (mo_coeff_o_bse, mo_coeff_v_bse) diff --git a/src/mp2_grids.F b/src/mp2_grids.F index 85dd1350ba..39c9f1f5b6 100644 --- a/src/mp2_grids.F +++ b/src/mp2_grids.F @@ -108,6 +108,15 @@ CONTAINS CALL determine_energy_range(qs_env, para_env, homo, Eigenval, do_ri_sos_laplace_mp2, & do_kpoints_cubic_RPA, Emin, Emax, e_range, e_fermi) + ! Open-shell uses ONE minimax grid for the combined [min gap, max span] over both spins (the + ! superset covers each channel, so it is accurate; per-spin grids would only be more efficient). + IF (SIZE(homo) > 1) THEN + CALL cp_hint(__LOCATION__, & + "Open-shell RPA/GW uses one minimax grid spanning [min gap, max span] across "// & + "both spin channels; raise QUADRATURE_POINTS if QP convergence is marginal for "// & + "strongly spin-asymmetric systems.") + END IF + CALL greenx_get_minimax_grid(unit_nr, num_integ_points, emin, emax, & tau_tj, tau_wj, qs_env%mp2_env%ri_g0w0%regularization_minimax, & tj, wj, weights_cos_tf_t_to_w, & diff --git a/src/mp2_integrals.F b/src/mp2_integrals.F index f82734ab4f..f42d1a1a91 100644 --- a/src/mp2_integrals.F +++ b/src/mp2_integrals.F @@ -200,9 +200,8 @@ CONTAINS ri_metric, gd_B_occ_bse, gd_B_virt_bse) TYPE(three_dim_real_array), ALLOCATABLE, & - DIMENSION(:), INTENT(OUT) :: BIb_C, BIb_C_gw - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & - INTENT(OUT) :: BIb_C_bse_ij, BIb_C_bse_ab + DIMENSION(:), INTENT(OUT) :: BIb_C, BIb_C_gw, BIb_C_bse_ij, & + BIb_C_bse_ab TYPE(group_dist_d1_type), INTENT(OUT) :: gd_array TYPE(group_dist_d1_type), ALLOCATABLE, & DIMENSION(:), INTENT(OUT) :: gd_B_virtual @@ -237,8 +236,8 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: starts_array_mc, ends_array_mc, & starts_array_mc_block, & ends_array_mc_block - INTEGER, INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, & - bse_lev_virt + INTEGER, INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt + INTEGER, DIMENSION(:), INTENT(IN) :: bse_lev_virt LOGICAL, INTENT(IN) :: do_im_time, do_kpoints_cubic_RPA TYPE(kpoint_type), POINTER :: kpoints TYPE(dbt_type), INTENT(OUT) :: t_3c_M @@ -249,21 +248,22 @@ CONTAINS TYPE(block_ind_type), ALLOCATABLE, & DIMENSION(:, :, :) :: t_3c_O_ind TYPE(libint_potential_type), INTENT(IN) :: ri_metric - TYPE(group_dist_d1_type), INTENT(OUT) :: gd_B_occ_bse, gd_B_virt_bse + TYPE(group_dist_d1_type), ALLOCATABLE, & + DIMENSION(:), INTENT(OUT) :: gd_B_occ_bse, gd_B_virt_bse CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_ri_gpw_compute_in' INTEGER :: cm, cut_memory, cut_memory_int, eri_method, gw_corr_lev_total, handle, handle2, & handle4, i, i_counter, i_mem, ibasis, ispin, itmp(2), j, jcell, kcell, LLL, min_bsize, & - my_B_all_end, my_B_all_size, my_B_all_start, my_B_occ_bse_end, my_B_occ_bse_size, & - my_B_occ_bse_start, my_B_virt_bse_end, my_B_virt_bse_size, my_B_virt_bse_start, & - my_group_L_end, my_group_L_size, my_group_L_start, n_rep, natom, ngroup, nimg, nkind, & - nspins, potential_type, ri_metric_type + my_B_all_end, my_B_all_size, my_B_all_start, my_group_L_end, my_group_L_size, & + my_group_L_start, n_rep, natom, ngroup, nimg, nkind, nspins, potential_type, & + ri_metric_type INTEGER(int_8) :: nze INTEGER, ALLOCATABLE, DIMENSION(:) :: dist_AO_1, dist_AO_2, dist_RI, & - ends_array_mc_block_int, ends_array_mc_int, my_B_size, my_B_virtual_end, & - my_B_virtual_start, sizes_AO, sizes_AO_split, sizes_RI, sizes_RI_split, & - starts_array_mc_block_int, starts_array_mc_int, virtual + ends_array_mc_block_int, ends_array_mc_int, my_B_occ_bse_end, my_B_occ_bse_size, & + my_B_occ_bse_start, my_B_size, my_B_virt_bse_end, my_B_virt_bse_size, & + my_B_virt_bse_start, my_B_virtual_end, my_B_virtual_start, sizes_AO, sizes_AO_split, & + sizes_RI, sizes_RI_split, starts_array_mc_block_int, starts_array_mc_int, virtual INTEGER, DIMENSION(2, 3) :: bounds INTEGER, DIMENSION(3) :: bounds_3c, pcoord, pdims, pdims_t3c, & periodic @@ -283,9 +283,9 @@ CONTAINS TYPE(distribution_3d_type) :: dist_3d TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER :: basis_set_ao, basis_set_ri_aux TYPE(gto_basis_set_type), POINTER :: orb_basis, ri_basis - TYPE(intermediate_matrix_type) :: intermed_mat_bse_ab, intermed_mat_bse_ij TYPE(intermediate_matrix_type), ALLOCATABLE, & - DIMENSION(:) :: intermed_mat, intermed_mat_gw + DIMENSION(:) :: intermed_mat, intermed_mat_bse_ab, & + intermed_mat_bse_ij, intermed_mat_gw TYPE(mp_cart_type) :: mp_comm_t3c_2 TYPE(neighbor_list_3c_type) :: nl_3c TYPE(pw_c1d_gs_type) :: pot_g, rho_g @@ -434,8 +434,8 @@ CONTAINS END IF mem_for_iaK = dimen_RI*REAL(SUM(homo*virtual), KIND=dp)*8.0_dp/(1024_dp**2) - mem_for_ijK = dimen_RI*REAL(SUM([homo(1)]**2), KIND=dp)*8.0_dp/(1024_dp**2) - mem_for_abK = dimen_RI*REAL(SUM([bse_lev_virt]**2), KIND=dp)*8.0_dp/(1024_dp**2) + mem_for_ijK = dimen_RI*REAL(SUM(homo(1:nspins)**2), KIND=dp)*8.0_dp/(1024_dp**2) + mem_for_abK = dimen_RI*REAL(SUM(bse_lev_virt(1:nspins)**2), KIND=dp)*8.0_dp/(1024_dp**2) IF (.NOT. do_im_time) THEN WRITE (unit_nr, '(T3,A,T66,F11.2,A4)') 'RI_INFO| Total memory for (ia|K) integrals:', & @@ -490,21 +490,31 @@ CONTAINS CALL get_group_dist(gd_B_all, para_env_sub%mepos, my_B_all_start, my_B_all_end, my_B_all_size) IF (do_bse) THEN - ! virt x virt matrices - CALL create_intermediate_matrices(intermed_mat_bse_ab, mo_coeff_v_bse(1)%matrix, bse_lev_virt, bse_lev_virt, & - "bse_ab", blacs_env_sub, para_env_sub) + ! virt x virt slab size bse_lev_virt(ispin) is per-spin, so gd_B_virt_bse is an array; + ! the occupied count homo(ispin) is per-spin, so gd_B_occ_bse and the bse intermediates are arrays + ALLOCATE (intermed_mat_bse_ab(nspins), intermed_mat_bse_ij(nspins), gd_B_occ_bse(nspins), gd_B_virt_bse(nspins)) + ALLOCATE (my_B_occ_bse_start(nspins), my_B_occ_bse_end(nspins), my_B_occ_bse_size(nspins)) + ALLOCATE (my_B_virt_bse_start(nspins), my_B_virt_bse_end(nspins), my_B_virt_bse_size(nspins)) + DO ispin = 1, nspins + CALL create_group_dist(gd_B_virt_bse(ispin), para_env_sub%num_pe, bse_lev_virt(ispin)) + CALL get_group_dist(gd_B_virt_bse(ispin), para_env_sub%mepos, my_B_virt_bse_start(ispin), & + my_B_virt_bse_end(ispin), my_B_virt_bse_size(ispin)) + ! virt x virt matrices + CALL create_intermediate_matrices(intermed_mat_bse_ab(ispin), mo_coeff_v_bse(ispin)%matrix, & + bse_lev_virt(ispin), bse_lev_virt(ispin), & + "bse_ab_"//TRIM(ADJUSTL(cp_to_string(ispin))), blacs_env_sub, para_env_sub) - CALL create_group_dist(gd_B_virt_bse, para_env_sub%num_pe, bse_lev_virt) - CALL get_group_dist(gd_B_virt_bse, para_env_sub%mepos, my_B_virt_bse_start, my_B_virt_bse_end, my_B_virt_bse_size) + ! occ x occ matrices + ! We do not implement bse_lev_occ here, because the small number of occupied levels + ! does not critically influence the memory + CALL create_intermediate_matrices(intermed_mat_bse_ij(ispin), mo_coeff_o_bse(ispin)%matrix, & + homo(ispin), homo(ispin), & + "bse_ij_"//TRIM(ADJUSTL(cp_to_string(ispin))), blacs_env_sub, para_env_sub) - ! occ x occ matrices - ! We do not implement bse_lev_occ here, because the small number of occupied levels - ! does not critically influence the memory - CALL create_intermediate_matrices(intermed_mat_bse_ij, mo_coeff_o_bse(1)%matrix, homo(1), homo(1), & - "bse_ij", blacs_env_sub, para_env_sub) - - CALL create_group_dist(gd_B_occ_bse, para_env_sub%num_pe, homo(1)) - CALL get_group_dist(gd_B_occ_bse, para_env_sub%mepos, my_B_occ_bse_start, my_B_occ_bse_end, my_B_occ_bse_size) + CALL create_group_dist(gd_B_occ_bse(ispin), para_env_sub%num_pe, homo(ispin)) + CALL get_group_dist(gd_B_occ_bse(ispin), para_env_sub%mepos, my_B_occ_bse_start(ispin), & + my_B_occ_bse_end(ispin), my_B_occ_bse_size(ispin)) + END DO END IF END IF @@ -529,11 +539,14 @@ CONTAINS IF (do_bse) THEN - ALLOCATE (BIb_C_bse_ij(my_group_L_size, my_B_occ_bse_size, homo(1))) - BIb_C_bse_ij = 0.0_dp + ALLOCATE (BIb_C_bse_ij(nspins), BIb_C_bse_ab(nspins)) + DO ispin = 1, nspins + ALLOCATE (BIb_C_bse_ij(ispin)%array(my_group_L_size, my_B_occ_bse_size(ispin), homo(ispin))) + BIb_C_bse_ij(ispin)%array = 0.0_dp - ALLOCATE (BIb_C_bse_ab(my_group_L_size, my_B_virt_bse_size, bse_lev_virt)) - BIb_C_bse_ab = 0.0_dp + ALLOCATE (BIb_C_bse_ab(ispin)%array(my_group_L_size, my_B_virt_bse_size(ispin), bse_lev_virt(ispin))) + BIb_C_bse_ab(ispin)%array = 0.0_dp + END DO END IF @@ -596,25 +609,27 @@ CONTAINS IF (do_bse) THEN - ! B^ab_P matrix elements for BSE - DO LLL = 1, my_group_L_size - CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ab, & - BIb_C_bse_ab(LLL, :, :), & - mo_coeff_v_bse(1)%matrix, mo_coeff_v_bse(1)%matrix, eps_filter, & - my_B_all_end, my_B_all_start) - END DO - CALL contract_B_L(BIb_C_bse_ab, my_Lrows, gd_B_virt_bse%sizes, gd_array%sizes, qs_env%mp2_env%eri_blksize, & - ngroup, color_sub, para_env, para_env_sub) + DO ispin = 1, nspins + ! B^ab_P matrix elements for BSE + DO LLL = 1, my_group_L_size + CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ab(ispin), & + BIb_C_bse_ab(ispin)%array(LLL, :, :), & + mo_coeff_v_bse(ispin)%matrix, mo_coeff_v_bse(ispin)%matrix, eps_filter, & + my_B_all_end, my_B_all_start) + END DO + CALL contract_B_L(BIb_C_bse_ab(ispin)%array, my_Lrows, gd_B_virt_bse(ispin)%sizes, gd_array%sizes, & + qs_env%mp2_env%eri_blksize, ngroup, color_sub, para_env, para_env_sub) - ! B^ij_P matrix elements for BSE - DO LLL = 1, my_group_L_size - CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ij, & - BIb_C_bse_ij(LLL, :, :), & - mo_coeff_o(1)%matrix, mo_coeff_o(1)%matrix, eps_filter, & - my_B_occ_bse_end, my_B_occ_bse_start) + ! B^ij_P matrix elements for BSE + DO LLL = 1, my_group_L_size + CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ij(ispin), & + BIb_C_bse_ij(ispin)%array(LLL, :, :), & + mo_coeff_o(ispin)%matrix, mo_coeff_o(ispin)%matrix, eps_filter, & + my_B_occ_bse_end(ispin), my_B_occ_bse_start(ispin)) + END DO + CALL contract_B_L(BIb_C_bse_ij(ispin)%array, my_Lrows, gd_B_occ_bse(ispin)%sizes, gd_array%sizes, & + qs_env%mp2_env%eri_blksize, ngroup, color_sub, para_env, para_env_sub) END DO - CALL contract_B_L(BIb_C_bse_ij, my_Lrows, gd_B_occ_bse%sizes, gd_array%sizes, qs_env%mp2_env%eri_blksize, & - ngroup, color_sub, para_env, para_env_sub) END IF @@ -678,8 +693,11 @@ CONTAINS END IF IF (do_bse) THEN - CALL release_intermediate_matrices(intermed_mat_bse_ab) - CALL release_intermediate_matrices(intermed_mat_bse_ij) + DO ispin = 1, nspins + CALL release_intermediate_matrices(intermed_mat_bse_ab(ispin)) + CALL release_intermediate_matrices(intermed_mat_bse_ij(ispin)) + END DO + DEALLOCATE (intermed_mat_bse_ab, intermed_mat_bse_ij) END IF ! imag. time = low-scaling SOS-MP2, RPA, GW diff --git a/src/post_scf_bandstructure_types.F b/src/post_scf_bandstructure_types.F index 30c859bc2d..234c9af02f 100644 --- a/src/post_scf_bandstructure_types.F +++ b/src/post_scf_bandstructure_types.F @@ -23,6 +23,7 @@ MODULE post_scf_bandstructure_types USE dbt_api, ONLY: dbt_destroy,& dbt_type USE input_constants, ONLY: rtp_method_bse,& + rtp_method_bse_linearized,& small_cell_full_kp USE kinds, ONLY: default_path_length,& default_string_length,& @@ -44,6 +45,14 @@ MODULE post_scf_bandstructure_types PUBLIC :: post_scf_bandstructure_type, band_edges_type, data_3_type, bs_env_release + ! Sanity bounds on a fundamental quasiparticle gap, in Hartree: below -eps_qp_gap the spectrum is + ! inverted, above max_qp_gap the quasiparticle solve has diverged. eps_qp_gap is a noise tolerance, + ! low enough that a metal or a near-degenerate system does not trip the inversion test; max_qp_gap + ! sits far above any real valence gap (a few tens of eV) but is not derived from the all-electron + ! KS spread (~1000 eV), which would defeat the test. + REAL(KIND=dp), PARAMETER, PUBLIC :: eps_qp_gap = 0.01_dp/evolt, & + max_qp_gap = 200.0_dp/evolt + ! valence band maximum (VBM), conduction band minimum (CBM), direct band gap (DBG), ! indirect band gap (IDBG) TYPE band_edges_type @@ -76,6 +85,7 @@ MODULE post_scf_bandstructure_types LOGICAL :: keep_sparsity_rirs = .TRUE. REAL(KIND=dp) :: cutoff_radius_v_w = -1.0_dp REAL(KIND=dp) :: cutoff_radius_g_w = -1.0_dp + CHARACTER(LEN=default_string_length) :: grid_file_suffix = "" ! Data types for cutoffs based DBCSR matrices REAL(KIND=dp), ALLOCATABLE :: chunk_centroids(:, :) @@ -96,6 +106,20 @@ MODULE post_scf_bandstructure_types REAL(KIND=dp), ALLOCATABLE :: radius_ao_per_atom(:) REAL(KIND=dp), ALLOCATABLE :: radius_ri_per_atom(:) + ! Precomputed grid-basis kernels for RT-BSE + ! mat_V_aux_rtbse(P, Q) = truncated-Coulomb V_PQ with M^-1 sandwich (RI x RI); + ! the Hartree grid kernel Z V Z^T is applied factorized, never materialized + ! mat_W0_grid_rtbse(l, l') = sum_PQ Z_lP W^{w=0}_PQ Z_l'Q + TYPE(dbcsr_type) :: mat_V_aux_rtbse + TYPE(dbcsr_type) :: mat_W0_grid_rtbse + LOGICAL :: rtbse_kernels_ready = .FALSE. + ! Set TRUE once mat_phi_mu_l and mat_Z_lP have been populated in memory (by GW RI-RS + ! or on-demand by the RT-BSE RI-RS kernel path). + LOGICAL :: grid_built = .FALSE. + ! Independent toggles for V_grid / W0_grid availability + LOGICAL :: V_grid_built = .FALSE. + LOGICAL :: W0_grid_built = .FALSE. + END TYPE ri_rs_env TYPE post_scf_bandstructure_type @@ -280,7 +304,7 @@ MODULE post_scf_bandstructure_types skip_Sigma_vir, & skip_chi ! Marek : rtbse_method - INTEGER :: rtp_method = rtp_method_bse + INTEGER :: rtp_method = -1 ! check-arrays and names for restarting LOGICAL, DIMENSION(:), ALLOCATABLE :: read_chi, & @@ -475,7 +499,9 @@ CONTAINS CALL cp_fm_release(bs_env%fm_RI_RI) CALL cp_fm_release(bs_env%fm_chi_Gamma_freq) CALL cp_fm_release(bs_env%fm_W_MIC_freq) - IF (bs_env%rtp_method == rtp_method_bse) CALL cp_fm_release(bs_env%fm_W_MIC_freq_zero) + IF (bs_env%rtp_method == rtp_method_bse .OR. bs_env%rtp_method == rtp_method_bse_linearized) THEN + CALL cp_fm_release(bs_env%fm_W_MIC_freq_zero) + END IF CALL cp_fm_release(bs_env%fm_W_MIC_freq_1_extra) CALL cp_fm_release(bs_env%fm_W_MIC_freq_1_no_extra) CALL cp_cfm_release(bs_env%cfm_work_mo) @@ -522,8 +548,10 @@ CONTAINS CALL safe_cfm_destroy_1d(bs_env%cfm_SOC_spinor_ao) ! Deallocate RI-RS matrices - IF (bs_env%do_gw_ri_rs) CALL dbcsr_release(bs_env%ri_rs%mat_phi_mu_l) - IF (bs_env%do_gw_ri_rs) CALL dbcsr_release(bs_env%ri_rs%mat_Z_lP) + IF (bs_env%ri_rs%grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_phi_mu_l) + IF (bs_env%ri_rs%grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_Z_lP) + IF (bs_env%ri_rs%V_grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_V_aux_rtbse) + IF (bs_env%ri_rs%W0_grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_W0_grid_rtbse) IF (ALLOCATED(bs_env%ri_rs%grid_points)) DEALLOCATE (bs_env%ri_rs%grid_points) IF (ALLOCATED(bs_env%ri_rs%grid_cache)) DEALLOCATE (bs_env%ri_rs%grid_cache) IF (ALLOCATED(bs_env%ri_rs%radius_ao_per_atom)) DEALLOCATE (bs_env%ri_rs%radius_ao_per_atom) diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index 09ae1f3d75..770484b407 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -53,7 +53,8 @@ MODULE post_scf_bandstructure_utils cp_fm_set_all,& cp_fm_to_fm,& cp_fm_type - USE cp_log_handling, ONLY: cp_logger_get_default_io_unit + USE cp_log_handling, ONLY: cp_logger_get_default_io_unit,& + cp_to_string USE cp_parser_methods, ONLY: read_float_object USE input_constants, ONLY: int_ldos_z,& large_cell_Gamma,& @@ -83,6 +84,8 @@ MODULE post_scf_bandstructure_utils USE physcon, ONLY: angstrom,& evolt USE post_scf_bandstructure_types, ONLY: band_edges_type,& + eps_qp_gap,& + max_qp_gap,& post_scf_bandstructure_type USE pw_env_types, ONLY: pw_env_get,& pw_env_type @@ -2970,10 +2973,41 @@ CONTAINS CALL get_VBM_CBM_bandgaps(bs_env%band_edges_G0W0, bs_env%eigenval_G0W0, bs_env) CALL get_VBM_CBM_bandgaps(bs_env%band_edges_HF, bs_env%eigenval_HF, bs_env) + CALL check_qp_gap_sanity(bs_env) + CALL timestop(handle) END SUBROUTINE get_all_VBM_CBM_bandgaps +! ************************************************************************************************** +!> \brief Warn if the G0W0 fundamental band gap is inverted or implausibly large, i.e. if the +!> quasiparticle solve has produced a spectrum that cannot be physical. +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE check_qp_gap_sanity(bs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + REAL(KIND=dp) :: gap, gap_scf + + gap = bs_env%band_edges_G0W0%IDBG + gap_scf = bs_env%band_edges_scf%IDBG + + ! requiring a healthy SCF gap keeps the inversion test from firing on a genuine metal + IF (gap < -eps_qp_gap .AND. gap_scf > eps_qp_gap) THEN + CALL cp_warn(__LOCATION__, & + "G0W0 band gap is negative ("// & + TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))//" eV): the quasiparticle "// & + "spectrum is inverted. Check numerical parameters.") + ELSE IF (ABS(gap) > max_qp_gap) THEN + CALL cp_warn(__LOCATION__, & + "G0W0 band gap is implausibly large ("// & + TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))//" eV): the quasiparticle "// & + "solve has likely diverged. Check numerical parameters.") + END IF + + END SUBROUTINE check_qp_gap_sanity + ! ************************************************************************************************** !> \brief ... !> \param band_edges ... diff --git a/src/rpa_gw_sigma_x.F b/src/rpa_gw_sigma_x.F index d0051d92aa..0998afb0ef 100644 --- a/src/rpa_gw_sigma_x.F +++ b/src/rpa_gw_sigma_x.F @@ -591,7 +591,7 @@ CONTAINS homo, max_corr_lev_virt, & homo_reduced_bse, virtual_reduced_bse, & homo_startindex_bse, virtual_startindex_bse, & - mp2_env) + mp2_env%bse%bse_cutoff_occ, mp2_env%bse%bse_cutoff_empty) IF (gw_corr_lev_occ == -2) THEN CPWARN("BSE cutoff overwrites user input for CORR_MOS_OCC") gw_corr_lev_occ = homo_reduced_bse diff --git a/src/rpa_main.F b/src/rpa_main.F index c005965d59..0c4e4bd14b 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -192,15 +192,16 @@ CONTAINS REAL(KIND=dp), INTENT(OUT) :: Erpa TYPE(mp2_type), INTENT(INOUT) :: mp2_env TYPE(three_dim_real_array), DIMENSION(:), & - INTENT(INOUT) :: BIb_C, BIb_C_gw - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & - INTENT(INOUT) :: BIb_C_bse_ij, BIb_C_bse_ab + INTENT(INOUT) :: BIb_C, BIb_C_gw, BIb_C_bse_ij, & + BIb_C_bse_ab TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub INTEGER, INTENT(INOUT) :: color_sub TYPE(group_dist_d1_type), INTENT(INOUT) :: gd_array TYPE(group_dist_d1_type), DIMENSION(:), & INTENT(INOUT) :: gd_B_virtual - TYPE(group_dist_d1_type), INTENT(INOUT) :: gd_B_all, gd_B_occ_bse, gd_B_virt_bse + TYPE(group_dist_d1_type), INTENT(INOUT) :: gd_B_all + TYPE(group_dist_d1_type), DIMENSION(:), & + INTENT(INOUT) :: gd_B_occ_bse, gd_B_virt_bse TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: mo_coeff TYPE(cp_fm_type), INTENT(IN) :: fm_matrix_PQ TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_matrix_L_kpoints, & @@ -213,8 +214,9 @@ CONTAINS INTEGER, INTENT(IN) :: nmo INTEGER, DIMENSION(:), INTENT(IN) :: homo INTEGER, INTENT(IN) :: dimen_RI, dimen_RI_red - INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt - INTEGER, INTENT(IN) :: bse_lev_virt, unit_nr + INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, & + bse_lev_virt + INTEGER, INTENT(IN) :: unit_nr LOGICAL, INTENT(IN) :: do_ri_sos_laplace_mp2, my_do_gw, & do_im_time, do_bse TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s @@ -233,29 +235,28 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'rpa_ri_compute_en' - INTEGER :: best_integ_group_size, best_num_integ_point, color_rpa_group, dimen_homo_square, & - dimen_nm_gw, dimen_virt_square, handle, handle2, handle3, ierr, iiB, & - input_num_integ_groups, integ_group_size, ispin, jjB, min_integ_group_size, & - my_ab_comb_bse_end, my_ab_comb_bse_size, my_ab_comb_bse_start, my_group_L_end, & - my_group_L_size, my_group_L_start, my_ij_comb_bse_end, my_ij_comb_bse_size, & - my_ij_comb_bse_start, my_nm_gw_end, my_nm_gw_size, my_nm_gw_start, ncol_block_mat, & - ngroup, nrow_block_mat, nspins, num_integ_group, num_integ_points, pos_integ_group + INTEGER :: best_integ_group_size, best_num_integ_point, color_rpa_group, dimen_nm_gw, & + dimen_virt_square, handle, handle2, handle3, ierr, iiB, input_num_integ_groups, & + integ_group_size, ispin, jjB, min_integ_group_size, my_group_L_end, my_group_L_size, & + my_group_L_start, my_nm_gw_end, my_nm_gw_size, my_nm_gw_start, ncol_block_mat, ngroup, & + nrow_block_mat, nspins, num_integ_group, num_integ_points, pos_integ_group INTEGER(KIND=int_8) :: mem - INTEGER, ALLOCATABLE, DIMENSION(:) :: dimen_ia, my_ia_end, my_ia_size, & - my_ia_start, virtual + INTEGER, ALLOCATABLE, DIMENSION(:) :: dimen_homo_square, dimen_ia, my_ab_comb_bse_end, & + my_ab_comb_bse_size, my_ab_comb_bse_start, my_ia_end, my_ia_size, my_ia_start, & + my_ij_comb_bse_end, my_ij_comb_bse_size, my_ij_comb_bse_start, virtual LOGICAL :: do_kpoints_from_Gamma, do_minimax_quad, & my_open_shell, skip_integ_group_opt REAL(KIND=dp) :: allowed_memory, avail_mem, E_Range, Emax, Emin, mem_for_iaK, mem_for_QK, & mem_min, mem_per_group, mem_per_rank, mem_per_repl, mem_real REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Eigenval_kp TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_Q, fm_mat_Q_gemm, fm_mat_S, & - fm_mat_S_gw - TYPE(cp_fm_type), DIMENSION(1) :: fm_mat_R_gw, fm_mat_S_ab_bse, & + fm_mat_S_ab_bse, fm_mat_S_gw, & fm_mat_S_ij_bse + TYPE(cp_fm_type), DIMENSION(1) :: fm_mat_R_gw TYPE(mp_para_env_type), POINTER :: para_env_RPA TYPE(two_dim_real_array), ALLOCATABLE, & - DIMENSION(:) :: BIb_C_2D, BIb_C_2D_gw - TYPE(two_dim_real_array), DIMENSION(1) :: BIb_C_2D_bse_ab, BIb_C_2D_bse_ij + DIMENSION(:) :: BIb_C_2D, BIb_C_2D_bse_ab, & + BIb_C_2D_bse_ij, BIb_C_2D_gw CALL timeset(routineN, handle) @@ -525,28 +526,37 @@ CONTAINS CALL timeset(routineN//"_reorder_bse1", handle3) - dimen_homo_square = homo(1)**2 + ALLOCATE (BIb_C_2D_bse_ij(nspins), BIb_C_2D_bse_ab(nspins)) + ALLOCATE (dimen_homo_square(nspins)) + ALLOCATE (my_ij_comb_bse_size(nspins), my_ij_comb_bse_start(nspins), my_ij_comb_bse_end(nspins)) + ALLOCATE (my_ab_comb_bse_size(nspins), my_ab_comb_bse_start(nspins), my_ab_comb_bse_end(nspins)) + ! We do not implement an explicit bse_lev_occ different to homo here, because the small number of occupied levels ! does not critically influence the memory - CALL calculate_BIb_C_2D(BIb_C_2D_bse_ij(1)%array, BIb_C_bse_ij, para_env_sub, dimen_homo_square, & - homo(1), homo(1), gd_B_occ_bse, & - my_ij_comb_bse_size, my_ij_comb_bse_start, my_ij_comb_bse_end, my_group_L_size) - - DEALLOCATE (BIb_C_bse_ij) - CALL release_group_dist(gd_B_occ_bse) + DO ispin = 1, nspins + dimen_homo_square(ispin) = homo(ispin)**2 + CALL calculate_BIb_C_2D(BIb_C_2D_bse_ij(ispin)%array, BIb_C_bse_ij(ispin)%array, para_env_sub, & + dimen_homo_square(ispin), homo(ispin), homo(ispin), gd_B_occ_bse(ispin), & + my_ij_comb_bse_size(ispin), my_ij_comb_bse_start(ispin), & + my_ij_comb_bse_end(ispin), my_group_L_size) + DEALLOCATE (BIb_C_bse_ij(ispin)%array) + CALL release_group_dist(gd_B_occ_bse(ispin)) + END DO CALL timestop(handle3) CALL timeset(routineN//"_reorder_bse2", handle3) - dimen_virt_square = bse_lev_virt**2 - - CALL calculate_BIb_C_2D(BIb_C_2D_bse_ab(1)%array, BIb_C_bse_ab, para_env_sub, dimen_virt_square, & - bse_lev_virt, bse_lev_virt, gd_B_virt_bse, & - my_ab_comb_bse_size, my_ab_comb_bse_start, my_ab_comb_bse_end, my_group_L_size) - - DEALLOCATE (BIb_C_bse_ab) - CALL release_group_dist(gd_B_virt_bse) + ! bse_lev_virt(ispin) (hence dimen_virt_square) and gd_B_virt_bse(ispin) are per-spin + DO ispin = 1, nspins + dimen_virt_square = bse_lev_virt(ispin)**2 + CALL calculate_BIb_C_2D(BIb_C_2D_bse_ab(ispin)%array, BIb_C_bse_ab(ispin)%array, para_env_sub, & + dimen_virt_square, bse_lev_virt(ispin), bse_lev_virt(ispin), gd_B_virt_bse(ispin), & + my_ab_comb_bse_size(ispin), my_ab_comb_bse_start(ispin), & + my_ab_comb_bse_end(ispin), my_group_L_size) + DEALLOCATE (BIb_C_bse_ab(ispin)%array) + CALL release_group_dist(gd_B_virt_bse(ispin)) + END DO CALL timestop(handle3) @@ -597,20 +607,21 @@ CONTAINS END IF - ! for Bethe-Salpeter, we need other matrix fm_mat_S + ! for Bethe-Salpeter, we need other matrix fm_mat_S (per spin; the ab slab dimension is spin-independent) IF (do_bse) THEN + ALLOCATE (fm_mat_S_ij_bse(nspins), fm_mat_S_ab_bse(nspins)) CALL create_integ_mat(BIb_C_2D_bse_ij, para_env, para_env_sub, color_sub, ngroup, integ_group_size, & - dimen_RI_red, [dimen_homo_square], color_rpa_group, & + dimen_RI_red, dimen_homo_square, color_rpa_group, & mp2_env%block_size_row, mp2_env%block_size_col, unit_nr, & - [my_ij_comb_bse_size], [my_ij_comb_bse_start], [my_ij_comb_bse_end], & + my_ij_comb_bse_size, my_ij_comb_bse_start, my_ij_comb_bse_end, & my_group_L_size, my_group_L_start, my_group_L_end, & para_env_RPA, fm_mat_S_ij_bse, nrow_block_mat, ncol_block_mat, & fm_mat_Q(1)%matrix_struct%context, fm_mat_Q(1)%matrix_struct%context) CALL create_integ_mat(BIb_C_2D_bse_ab, para_env, para_env_sub, color_sub, ngroup, integ_group_size, & - dimen_RI_red, [dimen_virt_square], color_rpa_group, & + dimen_RI_red, [(bse_lev_virt(ispin)**2, ispin=1, nspins)], color_rpa_group, & mp2_env%block_size_row, mp2_env%block_size_col, unit_nr, & - [my_ab_comb_bse_size], [my_ab_comb_bse_start], [my_ab_comb_bse_end], & + my_ab_comb_bse_size, my_ab_comb_bse_start, my_ab_comb_bse_end, & my_group_L_size, my_group_L_start, my_group_L_end, & para_env_RPA, fm_mat_S_ab_bse, nrow_block_mat, ncol_block_mat, & fm_mat_Q(1)%matrix_struct%context, fm_mat_Q(1)%matrix_struct%context) @@ -628,7 +639,7 @@ CONTAINS homo, virtual, dimen_RI, dimen_RI_red, dimen_ia, dimen_nm_gw, & Eigenval_kp, num_integ_points, num_integ_group, color_rpa_group, & fm_matrix_PQ, fm_mat_S, fm_mat_Q_gemm, fm_mat_Q, fm_mat_S_gw, fm_mat_R_gw(1), & - fm_mat_S_ij_bse(1), fm_mat_S_ab_bse(1), & + fm_mat_S_ij_bse, fm_mat_S_ab_bse, & my_do_gw, do_bse, gw_corr_lev_occ, gw_corr_lev_virt, & bse_lev_virt, & do_minimax_quad, & @@ -657,8 +668,11 @@ CONTAINS END IF IF (do_bse) THEN - CALL cp_fm_release(fm_mat_S_ij_bse(1)) - CALL cp_fm_release(fm_mat_S_ab_bse(1)) + DO ispin = 1, nspins + CALL cp_fm_release(fm_mat_S_ij_bse(ispin)) + CALL cp_fm_release(fm_mat_S_ab_bse(ispin)) + END DO + DEALLOCATE (fm_mat_S_ij_bse, fm_mat_S_ab_bse) END IF CALL timestop(handle) @@ -1080,11 +1094,11 @@ CONTAINS TYPE(cp_fm_type), INTENT(IN) :: fm_matrix_PQ TYPE(cp_fm_type), DIMENSION(:), INTENT(INOUT) :: fm_mat_S TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_Q_gemm, fm_mat_Q, fm_mat_S_gw - TYPE(cp_fm_type), INTENT(IN) :: fm_mat_R_gw, fm_mat_S_ij_bse, & - fm_mat_S_ab_bse + TYPE(cp_fm_type), INTENT(IN) :: fm_mat_R_gw + TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_ij_bse, fm_mat_S_ab_bse LOGICAL, INTENT(IN) :: my_do_gw, do_bse - INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt - INTEGER, INTENT(IN) :: bse_lev_virt + INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, & + bse_lev_virt LOGICAL, INTENT(IN) :: do_minimax_quad, do_im_time TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: mo_coeff TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_matrix_L_kpoints, & @@ -1139,11 +1153,12 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Eigenval_last, Eigenval_scf, & vec_Sigma_x_gw TYPE(cp_cfm_type) :: cfm_mat_Q - TYPE(cp_fm_type) :: fm_mat_Q_static_bse_gemm, fm_mat_RI_global_work, fm_mat_S_ia_bse, & - fm_mat_work, fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, & + TYPE(cp_fm_type) :: fm_mat_Q_static_bse_gemm, fm_mat_RI_global_work, fm_mat_work, & + fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, & fm_scaled_dm_virt_tau - TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_S_gw_work, fm_mat_W, & - fm_mo_coeff_occ, fm_mo_coeff_virt + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_S_gw_work, fm_mat_S_ia_bse, & + fm_mat_W, fm_mo_coeff_occ, & + fm_mo_coeff_virt TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_mat_L_kpoints, fm_mat_Minv_L_kpoints TYPE(dbcsr_p_type) :: mat_dm, mat_L, mat_M_P_munu_occ, & mat_M_P_munu_virt, mat_MinvVMinv @@ -1505,6 +1520,17 @@ CONTAINS fm_mat_Q_gemm(ispin), do_bse, fm_mat_Q_static_bse_gemm, dgemm_counter, & num_integ_points, count_ev_sc_GW) END DO + ! For open-shell BSE: the static screened-Coulomb polarizability is the + ! sum over both spin channels. calc_mat_Q overwrites fm_mat_Q_static_bse_gemm + ! per spin, so rebuild it here as the explicit spin sum at omega=0. + IF (do_bse .AND. nspins > 1 .AND. jquad == num_integ_points .AND. & + count_ev_sc_GW == 1) THEN + CALL cp_fm_set_all(fm_mat_Q_static_bse_gemm, 0.0_dp) + DO ispin = 1, nspins + CALL cp_fm_scale_and_add(1.0_dp, fm_mat_Q_static_bse_gemm, & + 1.0_dp, fm_mat_Q_gemm(ispin)) + END DO + END IF ! For SOS-MP2 we need both matrices separately IF (.NOT. do_ri_sos_laplace_mp2) THEN @@ -1755,25 +1781,31 @@ CONTAINS "BSE@evGW applies W0, i.e. screening with DFT energies to the BSE!") END IF END IF - ! Create a copy of fm_mat_S for usage in BSE - CALL cp_fm_create(fm_mat_S_ia_bse, fm_mat_S(1)%matrix_struct) - CALL cp_fm_to_fm(fm_mat_S(1), fm_mat_S_ia_bse) - ! Remove energy/frequency factor from 3c-Integral for BSE - IF (iter_sc_gw0 == 1) THEN - CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse, virtual(1), & - Eigenval_last(:, 1, 1), homo(1), omega) - ELSE - CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse, virtual(1), & - Eigenval_scf(:, 1, 1), homo(1), omega) - END IF + ! Create a per-spin copy of fm_mat_S for usage in BSE + ALLOCATE (fm_mat_S_ia_bse(nspins)) + DO ispin = 1, nspins + CALL cp_fm_create(fm_mat_S_ia_bse(ispin), fm_mat_S(ispin)%matrix_struct) + CALL cp_fm_to_fm(fm_mat_S(ispin), fm_mat_S_ia_bse(ispin)) + ! Remove energy/frequency factor from 3c-Integral for BSE + IF (iter_sc_gw0 == 1) THEN + CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse(ispin), virtual(ispin), & + Eigenval_last(:, 1, ispin), homo(ispin), omega) + ELSE + CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse(ispin), virtual(ispin), & + Eigenval_scf(:, 1, ispin), homo(ispin), omega) + END IF + END DO ! Main routine for all BSE postprocessing CALL start_bse_calculation(fm_mat_S_ia_bse, fm_mat_S_ij_bse, fm_mat_S_ab_bse, & fm_mat_Q_static_bse_gemm, & Eigenval, Eigenval_scf, & homo, virtual, dimen_RI, dimen_RI_red, bse_lev_virt, & gd_array, color_sub, mp2_env, qs_env, mo_coeff, unit_nr) - ! Release BSE-copy of fm_mat_S - CALL cp_fm_release(fm_mat_S_ia_bse) + ! Release per-spin BSE-copy of fm_mat_S + DO ispin = 1, nspins + CALL cp_fm_release(fm_mat_S_ia_bse(ispin)) + END DO + DEALLOCATE (fm_mat_S_ia_bse) END IF IF (my_do_gw) THEN diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index c1d18cf537..9e066384a0 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -78,7 +78,7 @@ MODULE cp2k_runs do_sirius, do_swarm, do_tamc, do_test, do_tree_mc, do_tree_mc_ana, driver_run, ehrenfest, & energy_force_run, energy_run, geo_opt_run, linear_response_run, mimic_run, mol_dyn_run, & mon_car_run, negf_run, none_run, pint_run, real_time_propagation, rtp_method_bse, & - tree_mc_run, vib_anal + rtp_method_bse_linearized, tree_mc_run, vib_anal USE input_cp2k, ONLY: create_cp2k_root_section USE input_cp2k_check, ONLY: check_cp2k_input USE input_cp2k_global, ONLY: create_global_section @@ -123,6 +123,7 @@ MODULE cp2k_runs USE qs_linres_module, ONLY: linres_calculation USE reference_manager, ONLY: export_references_as_xml USE rt_bse, ONLY: run_propagation_bse + USE rt_bse_linearized, ONLY: run_propagation_linearized_bse USE rt_propagation, ONLY: rt_prop_setup USE swarm, ONLY: run_swarm USE tamc_run, ONLY: qs_tamc @@ -355,9 +356,12 @@ CONTAINS CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .TRUE. SELECT CASE (dft_control%rtp_control%rtp_method) + CASE (rtp_method_bse_linearized) + ! Run the linearized TD-BSE method + CALL run_propagation_linearized_bse(force_env) CASE (rtp_method_bse) ! Run the TD-BSE method - CALL run_propagation_bse(force_env%qs_env, force_env) + CALL run_propagation_bse(force_env) CASE default ! Run the TDDFT method CALL rt_prop_setup(force_env) diff --git a/tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp b/tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp new file mode 100644 index 0000000000..d39718e9dd --- /dev/null +++ b/tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp @@ -0,0 +1,78 @@ +&GLOBAL + PRINT_LEVEL MEDIUM + PROJECT ABBA_H2_PBE_UKS_G0W0 + RUN_TYPE ENERGY + &TIMINGS + THRESHOLD 0.01 + &END TIMINGS +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_DIFFUSE + LSD + MULTIPLICITY 1 + POTENTIAL_FILE_NAME POTENTIAL + &MGRID + CUTOFF 300 + REL_CUTOFF 30 + &END MGRID + &POISSON + PERIODIC NONE + PSOLVER MULTIPOLE + &END POISSON + &PRINT + &MO + ENERGIES T + &END MO + &END PRINT + &QS + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &END SCF + &XC + &WF_CORRELATION + &RI_RPA + &GW + SELF_CONSISTENCY G0W0 + &BSE + ENERGY_CUTOFF_EMPTY 60 + NUM_PRINT_EXC -1 + TDA OFF + &END BSE + &END GW + &END RI_RPA + &END WF_CORRELATION + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + ABC 6 6 6 + PERIODIC NONE + &END CELL + &COORD + H 0 0.0 0.0 + H 0 0.0 0.74144 + &END COORD + &KIND H + BASIS_SET def2-SVP-custom-diffuse + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &PRINT + &ATOMIC_COORDINATES ON + &END ATOMIC_COORDINATES + &END PRINT + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp b/tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp new file mode 100644 index 0000000000..a8f647a6cd --- /dev/null +++ b/tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp @@ -0,0 +1,83 @@ +&GLOBAL + PRINT_LEVEL MEDIUM + PROJECT ABBA_O2_PBE_UKS_G0W0 + RUN_TYPE ENERGY + &TIMINGS + THRESHOLD 0.01 + &END TIMINGS +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_def2_TZVP_orb + BASIS_SET_FILE_NAME BASIS_def2_TZVP_rifit + ! Asymmetric open-shell BSE regtest candidate: O2 triplet (9a/7b), def2-TZVP all-electron GAPW, + ! no cutoff so beta's extra virtuals exercise the per-spin (ab|K) Q9 path (ABBA). Not converged physics + ! (def2-TZVP-RIFIT auxiliary) - this is a code-reproducibility regtest, not a benchmark. + LSD + MULTIPLICITY 3 + POTENTIAL_FILE_NAME POTENTIAL + &MGRID + CUTOFF 600 + REL_CUTOFF 50 + &END MGRID + &POISSON + PERIODIC NONE + PSOLVER MULTIPOLE + &END POISSON + &PRINT + &MO + ENERGIES T + &END MO + &END PRINT + &QS + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &END SCF + &XC + &WF_CORRELATION + &RI_RPA + &GW + CORR_MOS_OCC -1 + CORR_MOS_VIRT -1 + SELF_CONSISTENCY G0W0 + &BSE + NUM_PRINT_EXC 8 + TDA OFF + &END BSE + &END GW + &END RI_RPA + &END WF_CORRELATION + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + ABC 8 8 8 + PERIODIC NONE + &END CELL + &COORD + O 0.0 0.0 0.0 + O 0.0 0.0 1.2075 + &END COORD + &KIND O + BASIS_SET def2-TZVP + BASIS_SET RI_AUX def2-TZVP-RIFIT + POTENTIAL ALL + &END KIND + &PRINT + &ATOMIC_COORDINATES ON + &END ATOMIC_COORDINATES + &END PRINT + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/BASIS_def2_TZVP_orb b/tests/QS/regtest-bse/BASIS_def2_TZVP_orb new file mode 100644 index 0000000000..b3f400467f --- /dev/null +++ b/tests/QS/regtest-bse/BASIS_def2_TZVP_orb @@ -0,0 +1,47 @@ +#---------------------------------------------------------------------- +# Basis Set Exchange +# Version 0.12 +# https://www.basissetexchange.org +#---------------------------------------------------------------------- +# Basis set: def2-TZVP +# Description: def2-TZVP +# Role: orbital +# Version: 1 (Data from Turbomole 7.3) +#---------------------------------------------------------------------- + + +# Oxygen def2-TZVP (11s,6p,2d,1f) -> [5s,3p,2d,1f] +O def2-TZVP + 11 +1 0 0 6 1 + 27032.3826310 0.21726302465E-03 + 4052.3871392 0.16838662199E-02 + 922.32722710 0.87395616265E-02 + 261.24070989 0.35239968808E-01 + 85.354641351 0.11153519115 + 31.035035245 0.25588953961 +1 0 0 2 1 + 12.260860728 0.39768730901 + 4.9987076005 0.24627849430 +1 0 0 1 1 + 1.1703108158 1.0000000 +1 0 0 1 1 + 0.46474740994 1.0000000 +1 0 0 1 1 + 0.18504536357 1.0000000 +1 1 1 4 1 + 63.274954801 0.60685103418E-02 + 14.627049379 0.41912575824E-01 + 4.4501223456 0.16153841088 + 1.5275799647 0.35706951311 +1 1 1 1 1 + 0.52935117943 .44794207502 +1 1 1 1 1 + 0.17478421270 .24446069663 +1 2 2 1 1 + 2.31400000 1.0000000 +1 2 2 1 1 + 0.64500000 1.0000000 +1 3 3 1 1 + 1.42800000 1.0000000 + diff --git a/tests/QS/regtest-bse/BASIS_def2_TZVP_rifit b/tests/QS/regtest-bse/BASIS_def2_TZVP_rifit new file mode 100644 index 0000000000..9d71bf729b --- /dev/null +++ b/tests/QS/regtest-bse/BASIS_def2_TZVP_rifit @@ -0,0 +1,61 @@ +#---------------------------------------------------------------------- +# Basis Set Exchange +# Version 0.12 +# https://www.basissetexchange.org +#---------------------------------------------------------------------- +# Basis set: def2-TZVP-RIFIT +# Description: RIMP2 auxiliary basis for def2-TZVP +# Role: rifit +# Version: 1 (Data from Turbomole 7.3) +#---------------------------------------------------------------------- + + +# Oxygen def2-TZVP-RIFIT (8s,6p,5d,3f,1g) -> [8s,6p,4d,3f,1g] +O def2-TZVP-RIFIT + 22 +1 0 0 1 1 + 364.91291000 .58060340 +1 0 0 1 1 + 77.38709400 1.40179846 +1 0 0 1 1 + 24.30170600 .34994600 +1 0 0 1 1 + 8.43695450 1.0000000 +1 0 0 1 1 + 3.15279410 1.0000000 +1 0 0 1 1 + 1.57754300 1.0000000 +1 0 0 1 1 + .78178244 1.0000000 +1 0 0 1 1 + .31652679 1.0000000 +1 1 1 1 1 + 56.73594800 1.04911649 +1 1 1 1 1 + 14.99721700 1.13960439 +1 1 1 1 1 + 5.64281160 1.0000000 +1 1 1 1 1 + 2.40692198 1.0000000 +1 1 1 1 1 + 1.02640596 1.0000000 +1 1 1 1 1 + .43769977 1.0000000 +1 2 2 2 1 + 12.44682100 1.14971821 + 6.12169170 .95355196 +1 2 2 1 1 + 2.71029490 1.0000000 +1 2 2 1 1 + 1.15240610 1.0000000 +1 2 2 1 1 + .41386174 1.0000000 +1 3 3 1 1 + 4.77935390 .36170900 +1 3 3 1 1 + 2.32046420 1.78111990 +1 3 3 1 1 + 1.09128040 .45330353 +1 4 4 1 1 + 2.33831070 1.0000000 + diff --git a/tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp b/tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp new file mode 100644 index 0000000000..64d1662fa0 --- /dev/null +++ b/tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp @@ -0,0 +1,79 @@ +&GLOBAL + PRINT_LEVEL MEDIUM + PROJECT TDA_H2_PBE_UKS_KS + RUN_TYPE ENERGY + &TIMINGS + THRESHOLD 0.01 + &END TIMINGS +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_DIFFUSE + LSD + MULTIPLICITY 1 + POTENTIAL_FILE_NAME POTENTIAL + &MGRID + CUTOFF 300 + REL_CUTOFF 30 + &END MGRID + &POISSON + PERIODIC NONE + PSOLVER MULTIPOLE + &END POISSON + &PRINT + &MO + ENERGIES T + &END MO + &END PRINT + &QS + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &END SCF + &XC + &WF_CORRELATION + &RI_RPA + &GW + SELF_CONSISTENCY G0W0 + &BSE + ENERGY_CUTOFF_EMPTY 60 + NUM_PRINT_EXC -1 + TDA ON + USE_KS_ENERGIES + &END BSE + &END GW + &END RI_RPA + &END WF_CORRELATION + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + ABC 6 6 6 + PERIODIC NONE + &END CELL + &COORD + H 0 0.0 0.0 + H 0 0.0 0.74144 + &END COORD + &KIND H + BASIS_SET def2-SVP-custom-diffuse + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &PRINT + &ATOMIC_COORDINATES ON + &END ATOMIC_COORDINATES + &END PRINT + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp b/tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp new file mode 100644 index 0000000000..63022849d4 --- /dev/null +++ b/tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp @@ -0,0 +1,83 @@ +&GLOBAL + PRINT_LEVEL MEDIUM + PROJECT TDA_O2_PBE_UKS_G0W0 + RUN_TYPE ENERGY + &TIMINGS + THRESHOLD 0.01 + &END TIMINGS +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_def2_TZVP_orb + BASIS_SET_FILE_NAME BASIS_def2_TZVP_rifit + ! Asymmetric open-shell BSE regtest candidate: O2 triplet (9a/7b), def2-TZVP all-electron GAPW, + ! no cutoff so beta's extra virtuals exercise the per-spin (ab|K) Q9 path. Not converged physics + ! (def2-TZVP-RIFIT auxiliary) - this is a code-reproducibility regtest, not a benchmark. + LSD + MULTIPLICITY 3 + POTENTIAL_FILE_NAME POTENTIAL + &MGRID + CUTOFF 600 + REL_CUTOFF 50 + &END MGRID + &POISSON + PERIODIC NONE + PSOLVER MULTIPOLE + &END POISSON + &PRINT + &MO + ENERGIES T + &END MO + &END PRINT + &QS + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &END SCF + &XC + &WF_CORRELATION + &RI_RPA + &GW + CORR_MOS_OCC -1 + CORR_MOS_VIRT -1 + SELF_CONSISTENCY G0W0 + &BSE + NUM_PRINT_EXC 8 + TDA ON + &END BSE + &END GW + &END RI_RPA + &END WF_CORRELATION + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + ABC 8 8 8 + PERIODIC NONE + &END CELL + &COORD + O 0.0 0.0 0.0 + O 0.0 0.0 1.2075 + &END COORD + &KIND O + BASIS_SET def2-TZVP + BASIS_SET RI_AUX def2-TZVP-RIFIT + POTENTIAL ALL + &END KIND + &PRINT + &ATOMIC_COORDINATES ON + &END ATOMIC_COORDINATES + &END PRINT + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/TEST_FILES.toml b/tests/QS/regtest-bse/TEST_FILES.toml index b9cb20d92c..88785e6eed 100644 --- a/tests/QS/regtest-bse/TEST_FILES.toml +++ b/tests/QS/regtest-bse/TEST_FILES.toml @@ -20,6 +20,17 @@ "BSE_H2O_PBE_evGW0_spectra.inp" = [{matcher="M124", tol=2e-02, ref=25.3518}, {matcher="M125", tol=2e-02, ref=0.7006}] "TDA_H2_PBE_G0W0_CHOLESKY_OFF.inp" = [{matcher="BSE_1st_excit_ener_TDA", tol=2e-05 , ref=16.9750}] +"TDA_H2_PBE_UKS_KS.inp" = [{matcher="BSE_1st_excit_ener_UKS", tol=2e-05, ref=0.5127}, + {matcher="BSE_2nd_excit_ener_UKS", tol=2e-05, ref=6.2622}, + {matcher="BSE_osc_str_n2_UKS", tol=7e-02, ref=0.295}] +"ABBA_H2_PBE_UKS_G0W0.inp" = [{matcher="BSE_1st_excit_ener_UKS_ABBA", tol=2e-05, ref=10.5924}, + {matcher="BSE_2nd_excit_ener_UKS_ABBA", tol=2e-05, ref=15.8565}, + {matcher="BSE_osc_str_n2_UKS_ABBA", tol=7e-02, ref=0.589}, + {matcher="BSE_ampl_n2_UKS_ABBA", tol=7e-02, ref=0.7132}] +"TDA_O2_PBE_UKS_G0W0.inp" = [{matcher="BSE_1st_excit_ener_UKS", tol=1e-03, ref=5.7853}, + {matcher="BSE_2nd_excit_ener_UKS", tol=1e-03, ref=5.8093}] +"ABBA_O2_PBE_UKS_G0W0.inp" = [{matcher="BSE_1st_excit_ener_UKS_ABBA", tol=1e-03, ref=5.7210}, + {matcher="BSE_2nd_excit_ener_UKS_ABBA", tol=1e-03, ref=5.7210}] #EOF #Low convergence criteria for evGW make a higher threshold necessary for these tests #Logic: Absolute errors (for G0W0/evGW0) should be within 1e-4, i.e. relative errors are diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL new file mode 100644 index 0000000000..a6fcdbb64b --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL @@ -0,0 +1,31 @@ +# Hydrogen def2-SVP (4s,1p) -> [2s,1p] +H def2-SVP-custom + 4 +1 0 0 1 1 + 1.9622572 0.13796524 +1 0 0 1 1 + 0.44453796 0.47831935 +1 0 0 1 1 + 0.3 1.0000000 +1 1 1 1 1 + 0.8000000 1.0000000 +H def2-SVP-RIFIT-custom + 9 +1 0 0 1 1 + 9.33521609 .64609379 +1 0 0 1 1 + 1.86110704 1.37005241 +1 0 0 1 1 + .59512466 1.0000000 +1 0 0 1 1 + .26448099 1.0000000 +1 1 1 1 1 + 2.45249821 .13284956 +1 1 1 1 1 + 1.35403830 1.45276215 +1 1 1 1 1 + .59522394 1.0000000 +1 2 2 1 1 + 1.58163766 1.49367397 +1 2 2 1 1 + .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml new file mode 100644 index 0000000000..c6a97429a4 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml @@ -0,0 +1,18 @@ +"h2_linrtbse_tda_open_shell_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=12.1081}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=25.0470}] +"h2_linrtbse_tda_open_shell_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=12.1081}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=25.0470}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=4.3728481438E-001}, + {matcher="LinRTBSE_static_pol_xx_total", tol=1e-03, ref=8.7456962872E-001}] +"h2_linrtbse_abba_rirs_open_shell.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=11.9499}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=17.4347}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=24.9629}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=3.2821735047E-001}, + {matcher="LinRTBSE_static_pol_xx_total", tol=1e-03, ref=6.5643470094E-001}] +"h2_linrtbse_tda_full_rirs_open_shell.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=12.1081}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=25.0470}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=4.3729997326E-001}, + {matcher="LinRTBSE_static_pol_xx_total", tol=1e-03, ref=8.7459994651E-001}] diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp new file mode 100644 index 0000000000..fd94980402 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp @@ -0,0 +1,106 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_RIRS_OPEN_SHELL + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Open-shell (LSD) ABBA with RI-RS Hartree+SEX: joint Liouvillian peaks + propagated alpha(0). +! STATIC_POL| TOT must equal the closed-shell RIRS ABBA alpha(0) at matched grid (forced-LSD +! identity), and equals 2 x the per-spin STATIC_POL| xx by spin symmetry. GRID_SELECT 2 per P-C12. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + LSD .TRUE. + MULTIPLICITY 1 + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + GRID_SELECT 2 + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp new file mode 100644 index 0000000000..d27dc72249 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp @@ -0,0 +1,108 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_FULL_RIRS_OPEN_SHELL + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Open-shell (LSD) TDA, full RI-RS: GW step (RI_RS T) AND Hartree+SEX kernels (KERNEL_RI RS) +! both in real-space. STATIC_POL| TOT must equal the closed-shell full-RIRS TDA alpha(0) at +! matched grid (forced-LSD identity), and equals 2 x the per-spin STATIC_POL| xx by spin +! symmetry. GRID_SELECT 2 per P-C12. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + LSD .TRUE. + MULTIPLICITY 1 + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + GRID_SELECT 2 + NUM_TIME_FREQ_POINTS 20 + RI_RS T + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp new file mode 100644 index 0000000000..54841d1d7a --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp @@ -0,0 +1,107 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_OPEN_SHELL_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Open-shell (LSD) TDA: Liouvillian peaks + propagated alpha(0) + spin-total identity. +&MOTION + &MD + ENSEMBLE NVE + STEPS 10 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + ! Forced open shell: spin-polarized singlet H2 (n_alpha = n_beta = 1). + ! Must reproduce the closed-shell result -> spin-factor identity test. + LSD .TRUE. + MULTIPLICITY 1 + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp new file mode 100644 index 0000000000..bd8312c849 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp @@ -0,0 +1,107 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_OPEN_SHELL_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Open-shell (LSD) TDA: Liouvillian peaks + propagated alpha(0) + spin-total identity. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + ! Forced open shell: spin-polarized singlet H2 (n_alpha = n_beta = 1). + ! Must reproduce the closed-shell result -> spin-factor identity test. + LSD .TRUE. + MULTIPLICITY 1 + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL new file mode 100644 index 0000000000..a6fcdbb64b --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL @@ -0,0 +1,31 @@ +# Hydrogen def2-SVP (4s,1p) -> [2s,1p] +H def2-SVP-custom + 4 +1 0 0 1 1 + 1.9622572 0.13796524 +1 0 0 1 1 + 0.44453796 0.47831935 +1 0 0 1 1 + 0.3 1.0000000 +1 1 1 1 1 + 0.8000000 1.0000000 +H def2-SVP-RIFIT-custom + 9 +1 0 0 1 1 + 9.33521609 .64609379 +1 0 0 1 1 + 1.86110704 1.37005241 +1 0 0 1 1 + .59512466 1.0000000 +1 0 0 1 1 + .26448099 1.0000000 +1 1 1 1 1 + 2.45249821 .13284956 +1 1 1 1 1 + 1.35403830 1.45276215 +1 1 1 1 1 + .59522394 1.0000000 +1 2 2 1 1 + 1.58163766 1.49367397 +1 2 2 1 1 + .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml new file mode 100644 index 0000000000..18222ca413 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml @@ -0,0 +1,44 @@ +"h2_linrtbse_tda_static_pol_shift_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=2.3524245107E-001}] +"h2_linrtbse_tda_static_pol_shift_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7460749367E-001}] +"h2_linrtbse_abba_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4346}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2290}] +"h2_linrtbse_abba_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4346}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2290}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5643997853E-001}] +"h2_linrtbse_tda_rirs_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5563}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=2.3524254536E-001}] +"h2_linrtbse_tda_rirs_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5563}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7460778986E-001}] +"h2_linrtbse_tda_restart_chain.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=2.3524244706E-001}] +"h2_linrtbse_tda_restart_chain_cont1.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7460748716E-001}] +"h2_linrtbse_tda_restart_chain_cont2.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.8576219499E+000}] +"h2_linrtbse_tda_enforce_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.0586781424E+001}] +"h2_linrtbse_tda_enforce_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.0430371851E+000}] +#EOF diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp new file mode 100644 index 0000000000..7e7bbbcd82 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ABBA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 10 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp new file mode 100644 index 0000000000..b62d9e39f0 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ABBA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp new file mode 100644 index 0000000000..3fa883dc97 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp @@ -0,0 +1,104 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_ENF_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ENFORCE_MAX_DT + restart (dump): rewrites TIMESTEP/STEPS to the max-stable dt, dumps the trace. +&MOTION + &MD + ENSEMBLE NVE + STEPS 100 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + ENFORCE_MAX_DT T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp new file mode 100644 index 0000000000..652a49e243 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp @@ -0,0 +1,104 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_ENF_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ENFORCE_MAX_DT + restart (cont): 3x window; ENFORCE inherits the trace dt and only rescales STEPS. +&MOTION + &MD + ENSEMBLE NVE + STEPS 300 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + ENFORCE_MAX_DT T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp new file mode 100644 index 0000000000..0c68845a9d --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_CHAIN + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 10 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp new file mode 100644 index 0000000000..f97e89590a --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_CHAIN + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp new file mode 100644 index 0000000000..a3569c8eee --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_CHAIN + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 30 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp new file mode 100644 index 0000000000..17dc778011 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp @@ -0,0 +1,104 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_RIRS_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA with RI-RS: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 10 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp new file mode 100644 index 0000000000..ed0351aa03 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp @@ -0,0 +1,104 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_RIRS_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA with RI-RS: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp new file mode 100644 index 0000000000..8fef5913b5 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp @@ -0,0 +1,109 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_SHIFT_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA + TDA_SHIFT_TO_FIRST_PEAK at fixed dt = h2_linrtbse_tda_static_pol.inp +! dt. Validates the rotating-frame round-trip identity at the alpha(0) +! layer: ref equals the unshifted baseline ref to ~1e-8. ENFORCE_MAX_DT +! deliberately not set here so the propagation accuracy matches the +! baseline; the auto-rescale code path is covered by the companion +! h2_linrtbse_tda_static_pol_shift_enforce_dt.inp. +&MOTION + &MD + ENSEMBLE NVE + STEPS 10 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + TDA_SHIFT_TO_FIRST_PEAK T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp new file mode 100644 index 0000000000..83d8f9ff3e --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp @@ -0,0 +1,109 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_SHIFT_RST + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA + TDA_SHIFT_TO_FIRST_PEAK at fixed dt = h2_linrtbse_tda_static_pol.inp +! dt. Validates the rotating-frame round-trip identity at the alpha(0) +! layer: ref equals the unshifted baseline ref to ~1e-8. ENFORCE_MAX_DT +! deliberately not set here so the propagation accuracy matches the +! baseline; the auto-rescale code path is covered by the companion +! h2_linrtbse_tda_static_pol_shift_enforce_dt.inp. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN RT_RESTART + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART + &EACH + MD 1 + &END EACH + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + TDA_SHIFT_TO_FIRST_PEAK T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS RESTART + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL new file mode 100644 index 0000000000..a6fcdbb64b --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL @@ -0,0 +1,31 @@ +# Hydrogen def2-SVP (4s,1p) -> [2s,1p] +H def2-SVP-custom + 4 +1 0 0 1 1 + 1.9622572 0.13796524 +1 0 0 1 1 + 0.44453796 0.47831935 +1 0 0 1 1 + 0.3 1.0000000 +1 1 1 1 1 + 0.8000000 1.0000000 +H def2-SVP-RIFIT-custom + 9 +1 0 0 1 1 + 9.33521609 .64609379 +1 0 0 1 1 + 1.86110704 1.37005241 +1 0 0 1 1 + .59512466 1.0000000 +1 0 0 1 1 + .26448099 1.0000000 +1 1 1 1 1 + 2.45249821 .13284956 +1 1 1 1 1 + 1.35403830 1.45276215 +1 1 1 1 1 + .59522394 1.0000000 +1 2 2 1 1 + 1.58163766 1.49367397 +1 2 2 1 1 + .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml new file mode 100644 index 0000000000..a76f855074 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml @@ -0,0 +1,17 @@ +"h2_linrtbse_abba_rirs.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4347}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2291}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5643377772E-001}] +"h2_linrtbse_tda_full_rirs.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0144}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2591}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5588}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7462404927E-001}] +"h2_linrtbse_tda_full_rirs_gridsel3.inp" = [{matcher="RIRS_Grid", tol=1e-03, ref=272}, + {matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0144}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2591}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5588}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7462404928E-001}] +"h2_linrtbse_abba_full_rirs.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.435}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0499}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2316}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5646779778E-001}] diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp new file mode 100644 index 0000000000..89005502e7 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_FULL_RIRS + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Full RI-RS: GW step (RI_RS T) AND linRTBSE kernels (KERNEL_RI RS) both in real-space. +! ABBA: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + RI_RS T + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp new file mode 100644 index 0000000000..2607e91c5e --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp @@ -0,0 +1,101 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_RIRS + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ABBA with RI-RS: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp new file mode 100644 index 0000000000..03999b1ade --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_FULL_RIRS + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Full RI-RS: GW step (RI_RS T) AND linRTBSE kernels (KERNEL_RI RS) both in real-space. +! TDA: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + RI_RS T + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp new file mode 100644 index 0000000000..8a70f86104 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp @@ -0,0 +1,107 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_FULL_RIRS_GRIDSEL3 + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! Full RI-RS: GW step (RI_RS T) AND linRTBSE kernels (KERNEL_RI RS) both in real-space. +! TDA: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +! GRID_SELECT 3: reads user-provided grid ri_rs_grid/H_rirs.ion (a copy of the built-in +! H def2-TZVPP grid), so results match h2_linrtbse_tda_full_rirs.inp exactly. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + KERNEL_RI RS + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + GRID_FILE_SUFFIX _rirs.ion + GRID_SELECT 3 + NUM_TIME_FREQ_POINTS 20 + RI_RS T + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion b/tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion new file mode 100644 index 0000000000..5594c318cf --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion @@ -0,0 +1,178 @@ +R"( + +beDeft - a general framework for molecular all electron calculation. + +Copyright (C) 2018 Ivan Duchemin. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see + + +Please consider citing the following works upon use of these data: + +1) "Separable resolution-of-the-identity with all-electron Gaussian bases: Application to cubic-scaling RPA", + J. Chem. Phys. 150, 174120 (2019); https://doi.org/10.1063/1.5090605; + +2) "Cubic-scaling all-electron GW calculations with a separable density-fitting space-time approach", + J. Chem. Theory Comput. 2021, 17, 2383−2393; https://doi.org/10.1021/acs.jctc.1c00101 + + + + Def2-TZVP realspace grid (Bohr) for species H + sqr error : 6.239134422007024e-07 + penalty : 9.830708520256151e-23 + n points : 136 + + + -0.2954148854501534 -0.1335642491691153 0.05068066035374287 + 0.1816380973401107 0.1859817433782612 -0.1386401349055483 + -0.01597099546061177 0.1287618520530735 -0.07001358047206471 + -0.02613587467036126 0.08932538392091835 -0.002838074440176907 + -0.06842058257872188 -0.08566817521093061 0.08522166521479257 + -0.08225046126705603 -0.169501604718487 0.2549724944661679 + 0.2566196514993097 0.02211931854806932 0.142291062832903 + -0.07432372098974464 0.3223691064275651 0.06297929572928379 + 0.5074128993367629 -0.1791359313809102 -0.0781260060975192 + 0.06377427096181078 -0.07385931271461051 -0.08061937700991234 + -0.2969263564043537 0.1835711887428562 0.2067556007423259 + -0.06453055224680186 -0.1031342172240359 -0.317980395159791 + 0.2576605683435805 -0.3838479590546792 0.2673057038155396 + 0.09375518435061178 -0.2976176406243511 -0.01906421437674757 + 0.4771926409809089 0.2922163830521363 0.02153261927022125 + -0.4636605785871395 0.08499757183189958 -0.299276732604827 + -0.2595208082744394 0.3547958371317465 -0.2665160678781763 + -0.2749286409788823 -0.7369205695678908 -0.1188292257217835 + 0.2549566965223938 0.2120087894499723 0.4875937267111851 + 0.01263024634950976 -0.1496465158019567 -0.5863211366757152 + 0.6092984024971327 0.3363041511085897 0.2956918277854952 + 0.3077528660372704 0.5702771675995133 -0.2667627149719398 + 0.5706572867358498 -0.4028291070114693 0.472261566923234 + -0.08732410746681919 -0.4695925942855174 -0.3312453981989941 + -0.3194955737060983 0.388255706300542 0.3606322363101925 + -0.3882238756537889 0.6148729513757498 -0.4588421906704931 + -0.3721076445655269 -0.3664319169266803 0.3063240634272202 + -0.6578182898786117 -0.3587293855625903 -0.7454097305649954 + 0.2676857645955618 0.4058854962776672 0.7737880094680426 + 0.07786322505044226 0.1290359974109117 -0.9514045020997184 + -0.171803174335231 -0.3514768864368197 0.9180878015565798 + -0.1216269833072627 -0.663968496194337 -0.437608991253138 + 1.012027349643134 0.04280907557983676 0.2504232797717886 + 0.6772643299868553 -0.05966251142429058 -0.5493110674680531 + -0.7879285661487034 0.04593973450695941 0.4364578161879538 + -0.8810944194566616 -0.0586058830290971 0.02493812429096716 + 0.5525404551554352 0.8899610424197217 0.1927159540384068 + 0.1973548327951684 -0.8948327022491742 -0.06779905589808827 + -0.2428330945547142 0.9520180594383421 0.1505703767119264 + -0.4300348963260354 -1.145077902046179 -0.0398244407094291 + 1.493438328940796 0.2234522049017941 0.1586963181828461 + -1.420009391972234 0.04880012290290694 -0.01272030194773821 + 0.370336777038307 1.393696713926728 0.3563309933622616 + 0.03596820161388265 -1.620511020943682 -0.04600475745536303 + -0.246857987452724 -0.254489864657869 1.447543723337624 + 0.1515831369116101 0.2103434357956588 -1.425970826722582 + 0.5884837125283602 0.4569762186942013 1.197638705723065 + 0.7261001342742653 0.8048720160671126 -0.645947568921209 + 0.780454043312149 -0.8455753384329407 0.6924299536886032 + 0.8454815993828603 -0.6930452376567066 -0.6702792306271542 + -0.7367507994895405 0.7132600395780444 0.8222503783520255 + -0.7061861646621481 0.8709347860404515 -0.6603936233806971 + -0.8405660361591353 -0.891974044265645 0.5812665168699227 + -0.5406958934351653 -0.7741565343905341 -0.879371590600466 + -0.04548167809185187 1.328634312426442 1.444513633533263 + 0.1267532093088906 1.536874286263144 -0.8919445946021033 + -0.08177892219767004 -1.208436585686179 1.363775012098787 + 0.1437908993059976 -1.162347310971533 -1.291252673238762 + 1.43168773682342 -0.3485929236252875 1.240293116262541 + 1.434079597048868 0.1767576291709002 -1.137212145662909 + -0.8906442592741174 0.06769573466985666 1.616646445018519 + -1.138118774959164 -0.03600675055748099 -1.185744552241386 + 1.306639353413664 1.316794577063328 0.224362958316805 + 1.520294807606466 -1.151999919916459 -0.1434617308954618 + -1.135535335000177 1.429764541411139 0.149348319835903 + -1.379588940939161 -1.287164087706267 -0.3638664692790708 + 1.135901397318623 0.1164378869420764 1.799986052433409 + -0.06092809947094797 0.5389792920119644 -2.052407126379629 + 0.8659069822457162 -0.5287669302210813 2.414973249952283 + 0.3238969383288228 -1.044403158358488 -2.027041699385781 + -0.7037365637682088 0.8007355576793537 2.401823446659314 + -0.7616261348246457 0.6822675550175186 -2.179171422197027 + -0.1613395649287358 -0.9544031371217349 2.332941541520295 + -0.9849325312503632 -0.4611837408212853 -1.698183184336927 + 0.8834930082403905 2.30834534846518 0.5072986264034914 + 0.7063601403425823 -1.8308093618429 0.791920808794972 + 0.02660907542483082 2.84206894177436 -0.3816015304498044 + 0.4146911264218839 -2.325133341064756 0.02467211535352986 + -0.823973467966634 2.122340559500701 1.235262821894633 + -0.9941744716000603 -2.305186376110722 0.5349649701821696 + -0.1469993861343339 2.393974399194733 -0.5076019482686613 + -1.75385290980192 -1.693186218488545 -1.177983394672746 + 1.777130165290716 1.243627909267864 0.4352899633443738 + -2.20543349423593 0.1720157402311745 1.646799368363265 + 1.890217127261714 0.8626024039832499 -1.451653838111088 + -1.806305643277792 0.8447557607714012 -0.8733043427285732 + 2.461476664832692 -0.977192553258759 0.5771483890078972 + -1.755389316642568 -0.298415913288883 0.9493476710191535 + 2.511342716444165 -0.7826761918361477 -0.443419672763977 + -2.613500382250666 0.4571764429841054 0.3654228625968752 + 3.842093941989271 -0.5596712038126999 -0.0830152301203563 + -3.303808201144906 1.186546058824115 0.1729525823189399 + 0.1019292209756146 3.870289021315343 -0.4844977826791424 + 0.9993214038771049 -3.210427913736408 0.1050620773165616 + -0.2710547188512861 0.2947295399751631 3.504255324959454 + -0.3212853050950602 0.4715566184738518 -3.124664646376012 + 2.240578993085218 1.539951611266878 1.712946236910111 + 1.954624736966228 1.532501952028746 -2.33502122460108 + 1.162348391446048 -2.189889361989135 2.287333621015383 + 0.9791446568748993 -1.35083126368944 -2.776056099800358 + -1.032916704381661 2.018895928939019 2.748827790004297 + -1.886613895569877 1.141411050846112 -2.3239627239242 + -2.276817534392566 -2.256243245291318 1.519695792432714 + -2.296605293421468 -2.279528689561137 -2.407061522713857 + -0.5378515610262312 2.995190087826248 3.727450480799551 + 0.2788971834667044 3.062743170796157 -3.300175415509675 + 1.044201127141902 -3.245015083631762 3.07482403498685 + 0.8221329095371132 -2.533798671359024 -3.830096168310633 + 2.85074581995006 0.9766206224297082 3.363494378292772 + 2.679732587825186 1.31493423638742 -3.419274916029694 + -2.714504415966226 -1.069699222760358 3.465556406006018 + -3.019087366940264 0.9393774611356079 -3.154465162712406 + 3.242058878301219 2.758076700812236 1.674383894974962 + 3.120878533637019 -3.117430400439883 -0.09370439952600086 + -4.024724316009742 2.201322471341542 0.4236906588617514 + -3.26725678044431 -3.223955401278664 1.908196283114998 + 5.24849087715614 -0.7868672527375579 -0.06904248353174197 + -5.067328822546462 1.461410994380679 0.009568493557033262 + 0.1462143140361931 5.193500216986119 -0.8478591823519535 + 0.923645755665048 -4.869913641848457 0.6379341843324277 + -0.4358916800240319 0.6259140461626954 4.852631981153478 + 0.6322734786742126 -0.447993089774717 -4.889202076375438 + 3.073392322443376 3.449251893752574 4.264280316578882 + 3.367702599071051 3.549969446242695 -4.017012277611613 + 3.978591646756478 -3.745470275474244 3.854364927815283 + 3.5027874861621 -2.382325362877358 -5.15555162474973 + -3.107356934525352 3.285834949451149 5.178688546831546 + -4.418757220935039 2.870176264845758 -4.004471425971643 + -3.159785277198654 -4.027783912332535 3.91687587720759 + -2.973196995468781 -3.6629085247764 -3.677276218708017 + 7.023557063449501 -1.268441622108083 0.7327315371929585 + -7.276487313381022 1.505075264128465 0.1725678662932084 + 0.03872733113535301 6.604561443953888 -0.8430874770179861 + 1.165180385948926 -6.725095131329835 0.32860753596807 + -0.9198921590452458 0.6273748722982888 6.746196815020086 + 0.5074704985894842 -0.1886430394326983 -7.11743012671049 + +)" + + + + diff --git a/tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL new file mode 100644 index 0000000000..a6fcdbb64b --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL @@ -0,0 +1,31 @@ +# Hydrogen def2-SVP (4s,1p) -> [2s,1p] +H def2-SVP-custom + 4 +1 0 0 1 1 + 1.9622572 0.13796524 +1 0 0 1 1 + 0.44453796 0.47831935 +1 0 0 1 1 + 0.3 1.0000000 +1 1 1 1 1 + 0.8000000 1.0000000 +H def2-SVP-RIFIT-custom + 9 +1 0 0 1 1 + 9.33521609 .64609379 +1 0 0 1 1 + 1.86110704 1.37005241 +1 0 0 1 1 + .59512466 1.0000000 +1 0 0 1 1 + .26448099 1.0000000 +1 1 1 1 1 + 2.45249821 .13284956 +1 1 1 1 1 + 1.35403830 1.45276215 +1 1 1 1 1 + .59522394 1.0000000 +1 2 2 1 1 + 1.58163766 1.49367397 +1 2 2 1 1 + .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized/TEST_FILES.toml new file mode 100644 index 0000000000..b80dc416ac --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/TEST_FILES.toml @@ -0,0 +1,28 @@ +"h2_linrtbse_tda.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7459921259E-001}] +"h2_linrtbse_abba.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4346}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2290}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5643331047E-001}] +"h2_linrtbse_tda_kernels_off.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=25.4441}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=38.2217}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=51.6650}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.1831301628E+000}] +"h2_linrtbse_abba_kernels_off.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=25.4441}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=38.2217}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=51.6650}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.1831301629E+000}] +"h2_linrtbse_abba_cutoff.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4514}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0919}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2515}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5525719890E-001}] +"h2_linrtbse_tda_static_pol_enforce_dt.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.2304185308E+000}] +"h2_linrtbse_tda_static_pol_shift_enforce_dt.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, + {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, + {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, + {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.2305942151E+000}] diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp new file mode 100644 index 0000000000..57595ce016 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp @@ -0,0 +1,100 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ABBA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp new file mode 100644 index 0000000000..400f81c1be --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp @@ -0,0 +1,102 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_CUTOFF + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ABBA under ENERGY_CUTOFF truncation: Liouvillian peaks + propagated alpha(0). +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + ENERGY_CUTOFF_EMPTY 40 + ENERGY_CUTOFF_OCC 20 + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp new file mode 100644 index 0000000000..14456d377e --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_ABBA_KERNELS_OFF + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! ABBA, all kernels disabled: B=0 reduces ABBA to TDA-bare-diag; peaks + +! alpha(0) must match the TDA kernels-off counterpart. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DEBUG_DISABLE_HARTREE T + DEBUG_DISABLE_SEX T + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA F + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp new file mode 100644 index 0000000000..e68102e6b8 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp @@ -0,0 +1,100 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp new file mode 100644 index 0000000000..24e2c0bd9c --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp @@ -0,0 +1,103 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_KERNELS_OFF + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA, all kernels disabled: Liouvillian collapses to diag(eps_ai); peaks + +! alpha(0) must match the ABBA kernels-off counterpart (B=0 -> ABBA = TDA-bare). +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DEBUG_DISABLE_HARTREE T + DEBUG_DISABLE_SEX T + DIAGNOSE_LIOUVILLIAN_EIG T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp new file mode 100644 index 0000000000..5200cc2732 --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp @@ -0,0 +1,105 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_ENFORCE_DT + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA without rotating-frame shift + ENFORCE_MAX_DT. Counterpart to the +! _shift_enforce_dt test: covers the lab-frame branch of the ENFORCE_MAX_DT +! auto-rescale (omega_max set from lab-frame Liouvillian spectral extent, +! not the shifted-frame width). Locks alpha(0) for this code path; does +! not cross-check against the baseline. +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + ENFORCE_MAX_DT T + LRRTBSE T + TDA T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp new file mode 100644 index 0000000000..112e198cdc --- /dev/null +++ b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp @@ -0,0 +1,108 @@ +&GLOBAL + PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_SHIFT_ENFORCE_DT + RUN_TYPE RT_PROPAGATION +&END GLOBAL + +! TDA + TDA_SHIFT_TO_FIRST_PEAK + ENFORCE_MAX_DT static-pol regression gate. +! Covers the auto-rescale code path: ENFORCE_MAX_DT recomputes dt under the +! rotating frame (here: 1 as -> 16.67 as, STEPS 100 -> 6, same total time). +! Resulting alpha(0) drifts from the unshifted baseline by ~2.7% due to RK4 +! phase error at the larger dt; the value is locked as a "this hasn't +! drifted" gate, NOT as a round-trip identity check (see the companion +! h2_linrtbse_tda_static_pol_shift.inp for the identity check at fixed dt). +&MOTION + &MD + ENSEMBLE NVE + STEPS 20 + TEMPERATURE [K] 0.0 + TIMESTEP [fs] 1e-3 + &END MD +&END MOTION + +&FORCE_EVAL + METHOD QS + &DFT + BASIS_SET_FILE_NAME BASIS_MINIMAL + POTENTIAL_FILE_NAME ALL_POTENTIALS + &MGRID + CUTOFF 150 + REL_CUTOFF 40 + &END MGRID + &POISSON + PERIODIC NONE + POISSON_SOLVER WAVELET + &END POISSON + &QS + EPS_DEFAULT 1.0E-10 + METHOD GAPW + &END QS + &REAL_TIME_PROPAGATION + APPLY_DELTA_PULSE + DELTA_PULSE_DIRECTION 1 0 0 + DELTA_PULSE_SCALE 1.0E-5 + INITIAL_WFN SCF_WFN + &FT + DAMPING 5.0 + &END FT + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &RTBSE + DIAGNOSE_LIOUVILLIAN_EIG T + ENFORCE_MAX_DT T + LRRTBSE T + TDA T + TDA_SHIFT_TO_FIRST_PEAK T + &END RTBSE + &END REAL_TIME_PROPAGATION + &SCF + ADDED_MOS -1 + EPS_SCF 1.0E-6 + MAX_SCF 200 + SCF_GUESS ATOMIC + &DIAGONALIZATION ON + ALGORITHM STANDARD + &END DIAGONALIZATION + &MIXING + ALPHA 0.4 + METHOD BROYDEN_MIXING + NBROYDEN 4 + &END MIXING + &END SCF + &XC + &XC_FUNCTIONAL PBE0 + &END XC_FUNCTIONAL + &END XC + &END DFT + &PROPERTIES + &BANDSTRUCTURE + &GW + NUM_TIME_FREQ_POINTS 20 + &PRINT + &RESTART OFF + &END RESTART + &END PRINT + &END GW + &END BANDSTRUCTURE + &END PROPERTIES + &SUBSYS + &CELL + ABC 10.0 10.0 10.0 + PERIODIC NONE + &END CELL + &COORD + H 0.0 0.0 0.0 + H 0.74 0.0 0.0 + &END COORD + &KIND H + BASIS_SET ORB def2-SVP-custom + BASIS_SET RI_AUX def2-SVP-RIFIT-custom + POTENTIAL ALL + &END KIND + &TOPOLOGY + &CENTER_COORDINATES + &END CENTER_COORDINATES + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse/h2_delta_cont.inp b/tests/QS/regtest-rtbse/h2_delta_cont.inp index c4d4841740..511db23599 100644 --- a/tests/QS/regtest-rtbse/h2_delta_cont.inp +++ b/tests/QS/regtest-rtbse/h2_delta_cont.inp @@ -49,6 +49,10 @@ &PRINT &MOMENTS &END MOMENTS + &MOMENTS_FT OFF + &END MOMENTS_FT + &POLARIZABILITY OFF + &END POLARIZABILITY &END PRINT &RTBSE &END RTBSE diff --git a/tests/SLOW_TESTS_SUPPRESSIONS b/tests/SLOW_TESTS_SUPPRESSIONS index f14fa41996..41f70b7b64 100644 --- a/tests/SLOW_TESTS_SUPPRESSIONS +++ b/tests/SLOW_TESTS_SUPPRESSIONS @@ -99,4 +99,11 @@ QS/regtest-gauxc-gpw-mech/H2P_NATIVE_SKALA_GPW_UKS_PBC_FORCE_DEBUG.inp QS/regtest-gauxc-gapw-gth/H2_NATIVE_SKALA_GAPW_GTH_STRESS_DEBUG.inp QS/regtest-gauxc-gapw-ecp/H2_NATIVE_SKALA_GAPW_ECP_STRESS_DEBUG.inp +# Open-shell BSE on O2: an all-electron G0W0 step followed by the full BSE +# diagonalisation for both spin channels. O2 is the only open-shell reference +# system in the suite that is not H2, so the cost cannot be reduced further +# without losing that coverage. +QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp +QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp + #EOF diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index 29c61adf90..a989dfad6b 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -301,6 +301,10 @@ QS/regtest-as-3 libint mpiranks%2==0 QS/regtest-gpw-7 mpiranks<4 QS/regtest-bse libint !ifx QS/regtest-rtbse libint !ifx +QS/regtest-rtbse-linearized libint !ifx +QS/regtest-rtbse-linearized-rirs libint !ifx +QS/regtest-rtbse-linearized-open-shell libint !ifx +QS/regtest-rtbse-linearized-restart libint !ifx QS/regtest-smeagol-1 QS/regtest-smeagol-2 libsmeagol QS/regtest-mp2-admm-stress libint !ifx diff --git a/tests/matchers.py b/tests/matchers.py index f91c1f3f69..f38024004b 100644 --- a/tests/matchers.py +++ b/tests/matchers.py @@ -256,6 +256,27 @@ registry["E_evGW_gap"] = GenericMatcher( registry["M113"] = GenericMatcher(r"BSE| 1 -TDA-", col=7) registry["M114"] = GenericMatcher(r"BSE| 1 -ABBA-", col=7) + +# Open-shell (UKS) BSE matchers: joint-spectrum energies and oscillator strength +registry["BSE_1st_excit_ener_UKS"] = GenericMatcher( + r"BSE| 1 UKS -TDA-", col=5 +) +registry["BSE_2nd_excit_ener_UKS"] = GenericMatcher( + r"BSE| 2 UKS -TDA-", col=5 +) +registry["BSE_osc_str_n2_UKS"] = GenericMatcher(r"BSE| 2 -TDA-", col=7) +registry["BSE_1st_excit_ener_UKS_ABBA"] = GenericMatcher( + r"BSE| 1 UKS -ABBA-", col=5 +) +registry["BSE_2nd_excit_ener_UKS_ABBA"] = GenericMatcher( + r"BSE| 2 UKS -ABBA-", col=5 +) +registry["BSE_osc_str_n2_UKS_ABBA"] = GenericMatcher( + r"BSE| 2 -ABBA-", col=7 +) +registry["BSE_ampl_n2_UKS_ABBA"] = GenericMatcher( + r"BSE| 2 α 1 => 2 -ABBA-", col=8 +) registry["M115"] = GenericMatcher(r"MOMENTS_TRACE_RE| 0.10000000E+000", col=3) registry["M116"] = GenericMatcher(r"MOMENTS_TRACE_IM| 0.10000000E+000", col=3) registry["M117"] = GenericMatcher(r"MOMENTS_TRACE_RE| 0.20000000E+000", col=3) @@ -280,6 +301,31 @@ registry["RTBSE_GXAC_H2_pol"] = GenericMatcher( r"POLARIZABILITY_PADE| 0.30450000E+002", col=4 ) +# Lowest excitation energy from the linRTBSE Liouvillian diagnostic. +# Tied to the F12.4 eV column of the n=1 row. +registry["LinRTBSE_1st_excit_ener"] = GenericMatcher( + r" RTBSE\|\s+1\s+\d+\.\d+\s*$", col=3, regex=True +) + +# 2nd and 3rd excitation energy on the same table; the "\s+N\s+" boundary +# uniquely selects each row (e.g. "12" / "20" / "22" never matches "\s+2\s+"). +registry["LinRTBSE_2nd_excit_ener"] = GenericMatcher( + r" RTBSE\|\s+2\s+\d+\.\d+\s*$", col=3, regex=True +) +registry["LinRTBSE_3rd_excit_ener"] = GenericMatcher( + r" RTBSE\|\s+3\s+\d+\.\d+\s*$", col=3, regex=True +) + +# Static polarizability alpha(0), Re part, spin=1, xx element. +registry["LinRTBSE_static_pol_xx"] = GenericMatcher( + r" STATIC_POL\|\s+1\s+1,\s*1\s+", col=5, regex=True +) + +# Spin-summed total static polarizability alpha(0), Re part, xx element (open shell). +registry["LinRTBSE_static_pol_xx_total"] = GenericMatcher( + r" STATIC_POL\|\s+TOT\s+1,\s*1\s+", col=5, regex=True +) + registry["M126"] = GenericMatcher(r" # Total charge ", col=5) registry["M127"] = GenericMatcher(r"Checksum (Acoustic Sum Rule):", col=5) From be00458b03dc2d35d54da950aec54e14467491ff Mon Sep 17 00:00:00 2001 From: SY Wang Date: Wed, 29 Jul 2026 16:18:12 +0800 Subject: [PATCH 30/30] Sync the dftd4 workaround to package exporting (#5629) --- cmake/cp2kConfig.cmake.in | 1 + 1 file changed, 1 insertion(+) diff --git a/cmake/cp2kConfig.cmake.in b/cmake/cp2kConfig.cmake.in index e6ded96722..dff9eae329 100644 --- a/cmake/cp2kConfig.cmake.in +++ b/cmake/cp2kConfig.cmake.in @@ -144,6 +144,7 @@ if(NOT TARGET cp2k::cp2k) set(CP2K_USE_DFTD4 @CP2K_USE_DFTD4@) if(CP2K_USE_DFTD4) + find_dependency(mctc-lib REQUIRED) # workaround: find mctc-lib first find_dependency(dftd4 REQUIRED) endif()