Sync the dftd4 workaround to package exporting (#5629)

Co-authored-by: Copilot <copilot@github.com>
Co-authored-by: Claude Opus 4.7 <noreply@anthropic.com>

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)
@@ -26,20 +35,11 @@ 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")
 
-# 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
@@ -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)
@@ -226,18 +222,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"
+cmake_dependent_option(CP2K_USE_NVHPC "Enable Nvidia NVHPC kit" OFF
-                       "(NOT CP2K_USE_ACCEL MATCHES \"CUDA\")" OFF)
+                       "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF)
 
 cmake_dependent_option(
-  CP2K_USE_SPLA_GEMM_OFFLOADING ON
+  CP2K_USE_SPLA_GEMM_OFFLOADING
-  "Enable SpLA dgemm offloading (only valid with GPU support on)"
+  "Enable SpLA dgemm offloading (only valid with GPU support on)" ON
-  "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_SPLA)" OFF)
+  "CP2K_USE_ACCEL MATCHES \"HIP|CUDA\" AND CP2K_USE_SPLA" OFF)
 
 cmake_dependent_option(
-  CP2K_USE_CRAY_PM_ACCEL_ENERGY ON
+  CP2K_USE_CRAY_PM_ACCEL_ENERGY
-  "Enable CRAY power management framework with gpu support"
+  "Enable CRAY power management framework with gpu support" ON
-  "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_CRAY_PM_ENERGY)" OFF)
+  "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}
@@ -884,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()
@@ -909,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
@@ -1076,11 +1076,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)

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()
 

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}")

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

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   

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**
 
 ______________________________________________________________________
 

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:])
+        aliases = ", ".join(keyword_names[1:])
-        output += [f"**Aliases:** {escape_markdown(aliases)}", ""]
+        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.

docs/methods/machine_learning/index.md

@@ -6,6 +6,7 @@ titlesonly:
 maxdepth: 2
 ---
 nequip
+mace
 nnp
 pao-ml
 deepmd

docs/methods/machine_learning/mace.md

@@ -0,0 +1,60 @@
+# MACE
+
+MACE is a framework for building interatomic potentials using higher-order equivariant
+message-passing neural networks. The methodology is described in detail in the literature by Batatia
+et al. (2022).
+
+**Note:** Running MACE requires a CP2K build with LibTorch support
+
+Like the [NequIP/Allegro](https://manual.cp2k.org/trunk/methods/machine_learning/nequip.html)
+interface, CP2K runs MACE models through the generic LibTorch interface: a trained MACE model is
+exported once to a self-contained TorchScript file (`.pth`), which CP2K then loads and evaluates at
+runtime. No Python interpreter is involved during the simulation.
+
+## Exporting a MACE model for CP2K
+
+Wraps a trained MACE model (`.model`) and compiles it to CP2K-loadable TorchScrip file with the
+helper script `cp2k/tools/mace/create_cp2k_model.py`:
+
+```shell
+python create_cp2k_model.py my_mace.model --dtype float64
+# -> 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).

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
+usage of spGFN2-xTB for calculations as described in [Neugebauer2023](#Neugebauer2023). An example
-[Neugebauer2023](https://onlinelibrary.wiley.com/doi/full/10.1002/jcc.27185). An example for triplet
+for triplet oxygen is shown here.
-oxygen is shown here.
 
 ```
 &FORCE_EVAL

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
 

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
+LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP and MACE interfaces and for
-Skala models.
+GauXC Skala models.
 
 - LibTorch can be downloaded from the
   [PyTorch installation page](https://pytorch.org/get-started/locally/).

docs/versions.md

@@ -5,6 +5,7 @@
 maxdepth: 1
 titlesonly:
 ---
+2026.2 <https://manual.cp2k.org/cp2k-2026_2-branch/index.html>
 2026.1 <https://manual.cp2k.org/cp2k-2026_1-branch/index.html>
 2025.2 <https://manual.cp2k.org/cp2k-2025_2-branch/index.html>
 2025.1 <https://manual.cp2k.org/cp2k-2025_1-branch/index.html>

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}" \

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
@@ -354,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
@@ -883,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
@@ -1051,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(
@@ -1378,6 +1382,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

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)

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)

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)

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

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)

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), &

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)
 

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

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

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

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)

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

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) - &

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

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

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

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

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")

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)

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)
@@ -144,7 +162,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

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)

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

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)") ""

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

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
       !

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

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

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")

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

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

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)

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")

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(:)

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) == "</PP_SEMILOCAL>") THEN
+         ELSE IF (string(1:15) == "</PP_SEMILOCAL>") THEN
             EXIT
          ELSE
             !

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)

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))

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))

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
 

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 = "<unknown>"
+      END IF
 
    END SUBROUTINE m_getlog
 

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
+      REAL(KIND=dp), DIMENSION(:), INTENT(IN)            :: Eigenval
-      INTEGER, INTENT(IN)                                :: unit_nr, homo, virtual, dimen_RI
+      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, &
+      INTEGER :: a_virt_row, handle, i_occ_row, i_row_global, ii, isp, j_col_global, jj, k_isp, &
-                                                            i_row_global, ii, j_col_global, jj, &
+         k_ov, n_ov_joint, ncol_local_A, nrow_local_A, nspins, sizeeigen
-                                                            ncol_local_A, nrow_local_A, 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_struct_type), POINTER                   :: fm_struct_A, fm_struct_S_joint, &
-      TYPE(cp_fm_type)                                   :: fm_A_copy, fm_W
+                                                            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, &
+      CALL cp_fm_struct_create(fm_struct_A, context=fm_mat_S_ia_bse(1)%matrix_struct%context, &
-                               ncol_global=homo*virtual, para_env=fm_mat_S_ia_bse%matrix_struct%para_env)
+                               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, &
+      ! Create A matrix from GW Energies, v_ia,jb and W_ij,ab
-                               ncol_global=virtual**2, para_env=fm_mat_S_ab_bse%matrix_struct%para_env)
+      ! v_ia,jb = \sum_P B^P_ia B^P_jb  (Coulomb)
-      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
       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, &
+         IF (nspins > 1) THEN
-                            matrix_a=fm_mat_S_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, &
+            ! Assemble joint ia-slab for a single Coulomb gemm across all spin blocks
-                            matrix_c=fm_A)
+            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
+      ! W term on sigma-diagonal blocks only: W^sigma_ij,ab = sum_P barB^P_ij B^P_ab
-      IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN
+      ! offsets(isp) places each block at the correct position in joint A.
-         !W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab
+      ! For nspins=1: offsets(1)=0, equivalent to the original code.
-         CALL parallel_gemm(transa="T", transb="N", m=homo**2, n=virtual**2, k=dimen_RI, alpha=alpha_screening, &
+      DO isp = 1, nspins
-                            matrix_a=fm_mat_S_bar_ij_bse, matrix_b=fm_mat_S_ab_bse, beta=0.0_dp, &
+         IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN
-                            matrix_c=fm_W)
+            CALL cp_fm_struct_create(fm_struct_W, context=fm_mat_S_ab_bse(isp)%matrix_struct%context, &
-      END IF
+                                     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
+      ! Get local row/col indices for direct diagonal access
-      CALL cp_fm_get_info(matrix=fm_A, &
+      CALL cp_fm_get_info(matrix=fm_A, nrow_local=nrow_local_A, ncol_local=ncol_local_A, &
-                          nrow_local=nrow_local_A, &
+                          row_indices=row_indices_A, col_indices=col_indices_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
 
-      ! If infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals
+      !Add (ε_a-ε_i) on the diagonal of each sigma-block; cross-spin blocks have no ε contribution.
-      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
       IF (.NOT. tddfpt_control%do_bse) THEN
-      DO ii = 1, nrow_local_A
+         DO ii = 1, nrow_local_A
-
+            i_row_global = row_indices_A(ii)
-         i_row_global = row_indices_A(ii)
+            DO jj = 1, ncol_local_A
-
+               j_col_global = col_indices_A(jj)
-         DO jj = 1, ncol_local_A
+               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)]
-            j_col_global = col_indices_A(jj)
+                  isp = nspins
-
+                  DO k_isp = 1, nspins - 1
-            IF (i_row_global == j_col_global) THEN
+                     IF (i_row_global <= offsets(k_isp) + n_ov(k_isp)) THEN
-               i_occ_row = (i_row_global - 1)/virtual + 1
+                        isp = k_isp
-               a_virt_row = MOD(i_row_global - 1, virtual) + 1
+                        EXIT
-               eigen_diff = Eigenval(a_virt_row + homo) - Eigenval(i_occ_row)
+                     END IF
-               fm_A%local_data(ii, jj) = fm_A%local_data(ii, jj) + eigen_diff
+                  END DO
-
+                  k_ov = i_row_global - offsets(isp)
-            END IF
+                  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
+      ! GW eigenvalue stash for TDDFPT path (closed-shell only)
-         sizeeigen = SIZE(Eigenval)
+      IF (nspins == 1) THEN
-         ALLOCATE (ex_env%gw_eigen(sizeeigen)) ! for now only closed-shell
+         IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. &
-         ex_env%gw_eigen(:) = Eigenval(:)
+             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_struct_type), POINTER                   :: fm_struct_B, fm_struct_S_joint, &
-      TYPE(cp_fm_type)                                   :: fm_W
+                                                            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, &
+      ! Joint B over all spin blocks: B_ia,jb = alpha*(ia|bj) - W^sigma_ib,aj (W spin-diagonal)
-                               ncol_global=homo*virtual, para_env=fm_mat_S_ia_bse%matrix_struct%para_env)
+      NULLIFY (fm_struct_B)
-      CALL cp_fm_create(fm_B, fm_struct_v, name="fm_B_iajb")
+      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")
+      ! Coulomb v_ia,jb = sum_P B^P_ia B^P_jb (= (ia|bj)); cross-spin blocks filled automatically.
-      CALL cp_fm_set_all(fm_W, 0.0_dp)
+      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
+         DO isp = 1, nspins
-         CALL parallel_gemm(transa="T", transb="N", m=homo*virtual, n=homo*virtual, k=dimen_RI, alpha=alpha_screening, &
+            NULLIFY (fm_struct_W)
-                            matrix_a=fm_mat_S_bar_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, &
+            CALL cp_fm_struct_create(fm_struct_W, &
-                            matrix_c=fm_W)
+                                     context=fm_mat_S_ia_bse(isp)%matrix_struct%context, &
-
+                                     nrow_global=homo(isp)*virtual(isp), &
-         ! from W_ib,ja to A_ia,jb (formally: W_ib,aj, but our internal indexorder is different)
+                                     ncol_global=homo(isp)*virtual(isp), &
-         ! Writing -1.0_dp * W_ib,ja to A_ia,jb, i.e. beta = -1.0_dp,
+                                     para_env=fm_mat_S_ia_bse(isp)%matrix_struct%para_env)
-         ! W_ib,ja: nrow_secidx_in  = virtual,    ncol_secidx_in  = virtual
+            CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ibaj")
-         ! A_ia,jb: nrow_secidx_out = virtual, ncol_secidx_out = virtual
+            CALL cp_fm_set_all(fm_W, 0.0_dp)
-         reordering = [1, 4, 3, 2]
+            CALL parallel_gemm(transa="T", transb="N", m=homo(isp)*virtual(isp), &
-         CALL fm_general_add_bse(fm_B, fm_W, -1.0_dp, virtual, virtual, &
+                               n=homo(isp)*virtual(isp), k=dimen_RI, alpha=alpha_screening, &
-                                 virtual, virtual, unit_nr, reordering, mp2_env)
+                               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_B)
-      CALL cp_fm_struct_release(fm_struct_v)
+      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, &
+      IF (nspins == 1) THEN
-                           homo, virtual, homo_irred, unit_nr, &
+         CALL postprocess_bse(Exc_ens, fm_eigvec_X, mp2_env, qs_env, mo_coeff, &
-                           .FALSE., fm_eigvec_Y)
+                              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, &
+      IF (nspins == 1) THEN
-                           homo, virtual, homo_irred, unit_nr, .TRUE.)
+         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

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, &
+      TYPE(cp_fm_type)                                   :: fm_A_BSE, fm_B_BSE, fm_C_BSE, &
-         fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, &
+                                                            fm_inv_sqrt_A_minus_B, fm_Q_copy, &
-         fm_sqrt_A_minus_B
+                                                            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()
+      CALL fm_mat_S_ia_bse(1)%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)
 
-      IF (my_do_iterat_diag) THEN
+      ALLOCATE (homo_red_arr(nspins), virt_red_arr(nspins))
-         CALL fill_local_3c_arrays(fm_mat_S_ab_trunc, fm_mat_S_ia_trunc, &
+      ALLOCATE (fm_mat_S_ia_trunc_arr(nspins), fm_mat_S_ij_trunc_arr(nspins), fm_mat_S_ab_trunc_arr(nspins))
-                                   fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, &
+      ALLOCATE (fm_mat_S_bar_ia_bse_arr(nspins), fm_mat_S_bar_ij_bse_arr(nspins))
-                                   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
 
-      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
+         ALLOCATE (n_ov_arr(nspins), offsets_arr(nspins))
-         ! Quick estimate of memory consumption and runtime of diagonalizations
+         CALL get_bse_spin_block_layout(homo_red_arr, virt_red_arr, n_ov_arr, offsets_arr, n_ov_joint)
-         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)
 
-         ! For unscreened W matrix, we need fm_mat_S_ij_trunc
+         CALL adapt_BSE_input_params(n_ov_joint, 1, unit_nr, mp2_env, qs_env)
-         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)
 
-            ! 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, &
+               CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr, &
-                             homo_red, virtual_red, dimen_RI, unit_nr, mp2_env)
+                             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, &
+               CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ab_trunc_arr, &
-                             homo_red, virtual_red, dimen_RI, unit_nr, mp2_env)
+                             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)
+         DO ispin = 1, nspins
-         CALL get_qs_env(qs_env, dft_control=dft_control)
+            CALL cp_fm_release(fm_mat_S_bar_ia_bse_arr(ispin))
-         tddfpt_control => dft_control%tddfpt2_control
+            CALL cp_fm_release(fm_mat_S_bar_ij_bse_arr(ispin))
-         IF ((my_do_tda) .AND. (.NOT. tddfpt_control%do_bse)) THEN
+            CALL cp_fm_release(fm_mat_S_ia_trunc_arr(ispin))
-            ! Solving the hermitian eigenvalue equation A X^n = Ω^n X^n
+            CALL cp_fm_release(fm_mat_S_ij_trunc_arr(ispin))
-            CALL diagonalize_A(fm_A_BSE, homo_red, virtual_red, homo(1), &
+            CALL cp_fm_release(fm_mat_S_ab_trunc_arr(ispin))
-                               unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff)
+         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)
+         CALL adapt_BSE_input_params(homo_red_arr(1), virt_red_arr(1), unit_nr, mp2_env, qs_env)
-         IF (my_do_abba) THEN
+
-            ! Solving eigenvalue equation C Z^n = (Ω^n)^2 Z^n .
+         IF (my_do_fulldiag) THEN
-            ! Here, the eigenvectors Z^n relate to X^n via
+            n_ov_joint = homo_red_arr(1)*virt_red_arr(1)
-            ! Eq. (A10) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001).
+            CALL estimate_BSE_resources(n_ov_joint, unit_nr, my_do_abba, para_env, diag_runtime_est)
-            CALL diagonalize_C(fm_C_BSE, homo_red, virtual_red, homo(1), &
+            IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. &
-                               fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, &
+                mp2_env%bse%screening_method == bse_screening_alpha) THEN
-                               unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff)
+               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, &
+      DEALLOCATE (homo_red_arr, virt_red_arr)
-                                   fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, &
+      DEALLOCATE (fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr)
-                                   fm_mat_Q_static_bse_gemm, mp2_env)
+      DEALLOCATE (fm_mat_S_bar_ia_bse_arr, fm_mat_S_bar_ij_bse_arr)
-      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
 
       IF (unit_nr > 0) THEN
          WRITE (unit_nr, '(T2,A4,T7,A53)') 'BSE|', 'The BSE was successfully calculated. Have a nice day!'

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|', &
+         WRITE (unit_nr, '(T2,A4,T11,A12,T30,A7,T44,A8,T55,A27)') 'BSE|', &
-            'Excitation n', "Spin Config", 'TDA/ABBA', 'Excitation energy Ω^n (eV)'
+            '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 =', &
+         IF (nspins == 1) THEN
-            homo_irred, ' and LUMO a =', homo_irred + 1, " --"
+            WRITE (unit_nr, '(T2,A4,T15,A27,I5,A13,I5,A3)') 'BSE|', '-- Quick reminder: HOMO i =', &
-         WRITE (unit_nr, '(T2,A4)') 'BSE|'
+               homo_irred(1), ' and LUMO a =', homo_irred(1) + 1, " --"
-         WRITE (unit_nr, '(T2,A4,T7,A12,T30,A1,T32,A5,T42,A1,T49,A8,T64,A17)') &
+            WRITE (unit_nr, '(T2,A4)') 'BSE|'
-            "BSE|", "Excitation n", "i", "=>/<=", "a", 'TDA/ABBA', "|X_ia^n|/|Y_ia^n|"
+            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
+            IF (my_open_shell) THEN
-               WRITE (unit_nr, '(T2,A4,T10,A)') &
+               IF (flag_TDA) THEN
-                  'BSE|', "d_r^n = sqrt(2) sum_ia < ψ_i | r | ψ_a >  X_ia^n"
+                  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)') &
+               IF (flag_TDA) THEN
-                  'BSE|', "d_r^n = sum_ia sqrt(2) < ψ_i | r | ψ_a > ( X_ia^n + Y_ia^n )"
+                  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                                            :: handle, isp, k, num_entries
-      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: idx_homo, idx_virt
+      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
+      IF (SIZE(homo) == 1) THEN
-         DO k = 1, num_entries
+         CALL filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, &
-            WRITE (unit_nr, '(T2,A4,T14,I5,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') &
+                                    i_exc, virtual(1), num_entries, mp2_env)
-               "BSE|", i_exc, homo_irred - homo + idx_homo(k), direction_excitation, &
+         IF (unit_nr > 0) THEN
-               homo_irred + idx_virt(k), info_approximation, ABS(eigvec_entries(k))
+            DO k = 1, num_entries
-         END DO
+               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

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, &
+         iproc, jj, my_col_offset, my_row_offset, ncol_block_in, ncol_block_out, ncol_local_in, &
-         nrow_block_in, nrow_block_out, nrow_local_in, nrow_local_out, proc_send, row_idx_loc, &
+         ncol_local_out, nprocs, nrow_block_in, nrow_block_out, nrow_local_in, nrow_local_out, &
-         send_pcol, send_prow
+         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_row_out = my_row_offset + 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_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_row_out = my_row_offset + 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_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 ...
+!> \brief Sorts excitation entries by ascending primary index, reordering the secondary index,
-!> \param idx_prim ...
+!>        the eigenvector coefficients and - open shell - the spin index alongside
-!> \param idx_sec ...
+!> \param idx_prim Primary index of each entry; sorted in place and used as the sort key
-!> \param eigvec_entries ...
+!> \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 n_ov_joint ...
-!> \param virtual_red ...
 !> \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, &
+      INTEGER                                            :: eigvec_idx, handle, ii, iproc, isp, jj, &
-                                                            ncol_local, nrow_local, &
+                                                            kk, ksp, ncol_local, nrow_local, &
-                                                            num_entries_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
+               ! Decode spin block from the joint row index (blocks are contiguous; sigma is the
-               buffer_entries(para_env%mepos)%indx(kk, 2) = MOD(eigvec_idx - 1, virtual) + 1
+               ! 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)
+      ! (homo first, then virtual). idx_spin is payload, permuted alongside the entries.
-      CALL sort_excitations(idx_homo, idx_virt, eigvec_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)
+      ! Uses indices of outermost orbitals within energy range (-cutoff_occ,cutoff_empty)
-      IF (mp2_env%bse%bse_cutoff_occ > 0 .OR. mp2_env%bse%bse_cutoff_empty > 0) THEN
+      IF (cutoff_occ > 0 .OR. cutoff_empty > 0) THEN
-         IF (-mp2_env%bse%bse_cutoff_occ < Eigenval(1) - Eigenval(homo) &
+         ! The scans below EXIT at the first orbital beyond the cutoff, which only yields the correct
-             .OR. mp2_env%bse%bse_cutoff_occ < 0) THEN
+         ! 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) &
+         IF (cutoff_empty > Eigenval(homo + virtual) - Eigenval(homo + 1) &
-             .OR. mp2_env%bse%bse_cutoff_empty < 0) THEN
+             .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
+      ! 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)
+      ! 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, &
+         IF (unit_nr > 0) THEN
-                                    homo, virtual, &
+            IF (mp2_env%bse%bse_cutoff_occ > 0) THEN
-                                    homo_red, virt_red, &
+               WRITE (unit_nr, '(T2,A4,T7,A29,T71,F10.3)') 'BSE|', 'Cutoff occupied orbitals [eV]', &
-                                    homo_incl, virt_incl, &
+                  mp2_env%bse%bse_cutoff_occ*evolt
-                                    mp2_env)
+            ELSE
-
+               WRITE (unit_nr, '(T2,A4,T7,A37)') 'BSE|', 'No cutoff given for occupied orbitals'
-      IF (unit_nr > 0) THEN
+            END IF
-         IF (mp2_env%bse%bse_cutoff_occ > 0) THEN
+            IF (mp2_env%bse%bse_cutoff_empty > 0) THEN
-            WRITE (unit_nr, '(T2,A4,T7,A29,T71,F10.3)') 'BSE|', 'Cutoff occupied orbitals [eV]', &
+               WRITE (unit_nr, '(T2,A4,T7,A26,T71,F10.3)') 'BSE|', 'Cutoff empty orbitals [eV]', &
-               mp2_env%bse%bse_cutoff_occ*evolt
+                  mp2_env%bse%bse_cutoff_empty*evolt
-         ELSE
+            ELSE
-            WRITE (unit_nr, '(T2,A4,T7,A37)') 'BSE|', 'No cutoff given for occupied orbitals'
+               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
@@ -1481,7 +1651,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 +1663,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)
@@ -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, &
+      INTEGER                                            :: handle, idir, my_ispin, n_multipole, &
-                                                            n_virt, nao, nmo_mp2
+                                                            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

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)

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 <CRYST1> was not found in PDB file! ")
+      END IF
 
       periodic = 1
       READ (parser%input_line, *, IOSTAT=ios) cryst, cell_lengths(:), cell_angles(:)

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))
+      a = NORM2(xij)
-      b = SQRT(DOT_PRODUCT(xkj, xkj))
+      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))
+      a = NORM2(xij)
-      b = SQRT(DOT_PRODUCT(xkj, xkj))
+      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))
+                           rij = NORM2(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
                            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
+         OPTIONAL, POINTER                     :: particles
-      TYPE(qs_environment_type), POINTER, OPTIONAL       :: qs_env ! optional just because I am lazy... but I should get rid of it...
+      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

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
+            i = 1 ! number of elements consumed from 1st sublist
-            j = 1; ! number of elemens consumed from 2nd sublist
+            j = 1 ! number of elements consumed from 2nd sublist
-            k = 1; ! number of elemens already merged
+            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

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, &
@@ -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
 
@@ -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", &
@@ -789,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"), &

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) &
+      FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) result(res)
-         result(res)
          ${type1}$, intent(in) :: array(:)
          ${type1}$, intent(in) :: el
          INTEGER, INTENT(in), OPTIONAL :: l_index, u_index

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) &
+      IF (unit_nr <= 0) THEN
-         unit_nr = default_output_unit ! fall back to stdout
+         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) &
+      IF (unit_nr <= 0) THEN
-         wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second.
+         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

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'// &

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

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

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))
 

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 ?
+         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
+                  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

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

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

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)) &
+         END IF
-            call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1)
+         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)
+            DEALLOCATE (old_arr(i)%p)
-         end do
+         END DO
-         deallocate (old_arr)
+         DEALLOCATE (old_arr)
 
       END SUBROUTINE change_capacity_${valuetype}$
    #:enddef

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_a = NORM2(a)
-      length_of_b = SQRT(DOT_PRODUCT(b, b))
+      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)
 

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)
 

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)//">:"

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 [<int:nsamples>]"
+   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 [<int:nsamples>]"
+      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)") &

src/common/reference_manager.F

@@ -332,14 +332,18 @@ CONTAINS
          WRITE (unit, '(T3,A)') '<SOURCE>'//thebib(i)%ref%source//'</SOURCE>'
 
          ! DOI, volume, pages, year, month.
-         IF (ALLOCATED(thebib(i)%ref%doi)) &
+         IF (ALLOCATED(thebib(i)%ref%doi)) THEN
             WRITE (unit, '(T3,A)') '<DOI>'//TRIM(substitute_special_xml_tokens(thebib(i)%ref%doi))//'</DOI>'
-         IF (ALLOCATED(thebib(i)%ref%volume)) &
+         END IF
+         IF (ALLOCATED(thebib(i)%ref%volume)) THEN
             WRITE (unit, '(T3,A)') '<VOLUME>'//thebib(i)%ref%volume//'</VOLUME>'
-         IF (ALLOCATED(thebib(i)%ref%pages)) &
+         END IF
+         IF (ALLOCATED(thebib(i)%ref%pages)) THEN
             WRITE (unit, '(T3,A)') '<PAGES>'//thebib(i)%ref%pages//'</PAGES>'
-         IF (thebib(i)%ref%year > 0) &
+         END IF
+         IF (thebib(i)%ref%year > 0) THEN
             WRITE (unit, '(T3,A,I4.4,A)') '<YEAR>', thebib(i)%ref%year, '</YEAR>'
+         END IF
          WRITE (unit, '(T2,A)') '</REFERENCE>'
       END DO
 

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 \
+!>        ( j1 j2 j3 )
-!>        \ m1 m2 m3 /
+!>        ( 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 >

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)

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 ===== "

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)

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

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

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
 
 ! **************************************************************************************************

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

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. &
+         ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. &
-                 PRESENT(vector_r)) THEN
+                  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

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

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), &

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) + &

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")
@@ -612,7 +624,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

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/"
 

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
@@ -891,8 +897,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 +934,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 +1216,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 +1256,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
@@ -1296,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
 
@@ -1322,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

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, &
+        numerical, ramp_env, real_time_propagation, rtp_method_bse, rtp_method_bse_linearized, &
-        sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, sccs_derivative_fft, &
+        sccs_andreussi, sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, &
-        sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, sic_list_all, sic_list_unpaired, &
+        sccs_derivative_fft, sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, &
-        sic_mauri_spz, sic_mauri_us, sic_none, slater, tblite_cli_born_kernel_auto, &
+        sic_list_all, sic_list_unpaired, sic_mauri_spz, sic_mauri_us, sic_none, slater, &
-        tblite_cli_solution_state_gsolv, tblite_cli_solvation_alpb, tblite_cli_solvation_cpcm, &
+        tblite_cli_born_kernel_auto, tblite_cli_solution_state_gsolv, tblite_cli_solvation_alpb, &
-        tblite_cli_solvation_gb, tblite_cli_solvation_gbe, tblite_cli_solvation_gbsa, &
+        tblite_cli_solvation_cpcm, tblite_cli_solvation_gb, tblite_cli_solvation_gbe, &
-        tblite_guess_ceh, tblite_mixer_memory_inherit, tblite_scc_mixer_auto, &
+        tblite_cli_solvation_gbsa, tblite_guess_ceh, tblite_mixer_memory_inherit, &
-        tblite_scc_mixer_cp2k, tblite_scc_mixer_none, tblite_scc_mixer_tblite, tblite_solver_gvd, &
+        tblite_scc_mixer_auto, tblite_scc_mixer_cp2k, tblite_scc_mixer_none, &
-        tblite_solver_gvr, tddfpt_dipole_length, tddfpt_kernel_stda, use_mom_ref_user, &
+        tblite_scc_mixer_tblite, tblite_solver_gvd, tblite_solver_gvr, tddfpt_dipole_length, &
-        xtb_vdw_type_d3, xtb_vdw_type_d4, xtb_vdw_type_none
+        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,&
@@ -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)
@@ -242,7 +245,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 <X> 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")
@@ -405,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
@@ -429,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
@@ -550,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")
@@ -567,8 +584,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)
@@ -648,7 +666,12 @@ CONTAINS
          END IF
 
          ! periodic fields don't work with RTP
-         CPASSERT(.NOT. 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
@@ -963,11 +986,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, &
@@ -1217,8 +1241,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
@@ -1266,10 +1291,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
@@ -1334,21 +1360,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
@@ -1412,18 +1440,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)
@@ -1483,8 +1514,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
@@ -1505,37 +1537,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", &
@@ -1543,6 +1581,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
@@ -1594,6 +1635,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)
@@ -1817,6 +1861,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)
@@ -1855,14 +1919,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.
@@ -1926,8 +1993,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
@@ -1976,11 +2044,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)
@@ -1992,18 +2062,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
@@ -2034,10 +2107,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)
@@ -2045,10 +2120,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)
@@ -2122,7 +2199,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 <X> 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")
@@ -2148,8 +2236,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")
@@ -2191,9 +2280,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
@@ -2227,8 +2317,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
@@ -2243,8 +2334,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")
@@ -2464,8 +2556,7 @@ CONTAINS
                   dft_control%period_efield%strength
             END IF
 
-            IF (SQRT(DOT_PRODUCT(dft_control%period_efield%polarisation, &
+            IF (NORM2(dft_control%period_efield%polarisation) < EPSILON(0.0_dp)) THEN
-                                 dft_control%period_efield%polarisation)) < EPSILON(0.0_dp)) THEN
                CPABORT("Invalid (too small) polarisation vector specified for PERIODIC_EFIELD")
             END IF
          END IF
@@ -2874,8 +2965,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)") &
@@ -3005,9 +3097,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)") &
@@ -3078,8 +3171,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))
@@ -3118,8 +3212,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
@@ -3131,8 +3226,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
 
@@ -3144,13 +3240,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)
@@ -3285,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)
@@ -3301,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", &
@@ -3339,18 +3452,20 @@ 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.
       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")
@@ -3429,8 +3544,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
@@ -3553,8 +3669,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

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)

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

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

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