diff --git a/CMakeLists.txt b/CMakeLists.txt index f88fe00408..075f91973c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -10,15 +10,6 @@ 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) @@ -40,6 +31,15 @@ project( list(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/cmake/modules") +# Require out-of-source builds +file(TO_CMAKE_PATH "${PROJECT_BINARY_DIR}/CMakeLists.txt" LOC_PATH) +if(EXISTS "${LOC_PATH}") + message( + FATAL_ERROR + "You cannot build in a source directory (or any directory with a CMakeLists.txt file). Please make a build subdirectory." + ) +endif() + # set language and standard. # # cmake does not provide any mechanism to set the fortran standard. Adding the @@ -106,6 +106,10 @@ 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) @@ -222,18 +226,18 @@ cmake_dependent_option( CP2K_USE_CUSOLVER_MP "Enable cuSOLVERMp. Only active when CUDA is ON" OFF "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) -cmake_dependent_option(CP2K_USE_NVHPC "Enable Nvidia NVHPC kit" OFF - "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) +cmake_dependent_option(CP2K_USE_NVHPC OFF "Enable Nvidia NVHPC kit" + "(NOT CP2K_USE_ACCEL MATCHES \"CUDA\")" OFF) cmake_dependent_option( - CP2K_USE_SPLA_GEMM_OFFLOADING - "Enable SpLA dgemm offloading (only valid with GPU support on)" ON - "CP2K_USE_ACCEL MATCHES \"HIP|CUDA\" AND CP2K_USE_SPLA" OFF) + CP2K_USE_SPLA_GEMM_OFFLOADING ON + "Enable SpLA dgemm offloading (only valid with GPU support on)" + "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_SPLA)" OFF) cmake_dependent_option( - CP2K_USE_CRAY_PM_ACCEL_ENERGY - "Enable CRAY power management framework with gpu support" ON - "CP2K_USE_ACCEL MATCHES \"OPENCL|HIP|CUDA\" AND CP2K_USE_CRAY_PM_ENERGY" OFF) + CP2K_USE_CRAY_PM_ACCEL_ENERGY ON + "Enable CRAY power management framework with gpu support" + "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_CRAY_PM_ENERGY)" OFF) cmake_dependent_option( CP2K_USE_LIBGINT "Enable LibGint support" ${CP2K_USE_EVERYTHING} @@ -880,7 +884,6 @@ 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() @@ -906,10 +909,7 @@ if(CP2K_USE_ACE) endif() if(CP2K_USE_TBLITE) - 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() + find_package(tblite REQUIRED) add_library(cp2k::tblite INTERFACE IMPORTED) target_link_libraries( cp2k::tblite INTERFACE tblite::tblite mctc-lib::mctc-lib dftd4::dftd4 @@ -1076,10 +1076,11 @@ if(CP2K_USE_CUSOLVER_MP) else() message(" - CAL Include directories: ${CP2K_CAL_INCLUDE_DIRS}\n" " - CAL Libraries: ${CP2K_CAL_LINK_LIBRARIES}") - message(" - UCC Include directories: ${CP2K_UCC_INCLUDE_DIRS}\n" - " - UCC Libraries: ${CP2K_UCC_LINK_LIBRARIES}\n" - " - UCX Libraries: ${CP2K_UCX_LINK_LIBRARIES}\n") endif() + + message(" - UCC Include directories: ${CP2K_UCC_INCLUDE_DIRS}\n" + " - UCC Libraries: ${CP2K_UCC_LINK_LIBRARIES}\n" + " - UCX Libraries: ${CP2K_UCX_LINK_LIBRARIES}\n") endif() if(CP2K_USE_LIBXC) diff --git a/REVISION b/REVISION new file mode 100644 index 0000000000..1b83965aea --- /dev/null +++ b/REVISION @@ -0,0 +1 @@ +git:c92cc08 diff --git a/cmake/modules/FindCuSolverMP.cmake b/cmake/modules/FindCuSolverMP.cmake index 86d171f3c6..4090c34311 100644 --- a/cmake/modules/FindCuSolverMP.cmake +++ b/cmake/modules/FindCuSolverMP.cmake @@ -12,6 +12,8 @@ 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") @@ -39,13 +41,12 @@ if(CP2K_CUSOLVER_MP_INCLUDE_DIRS) find_package(Nccl REQUIRED) set(CP2K_CUSOLVERMP_USE_NCCL ON - CACHE BOOL "CuSolverMP uses NCCL for communication" FORCE) + CACHE BOOL "CuSolverMP uses NCCL for communication") else() find_package(Cal REQUIRED) - find_package(ucc REQUIRED) set(CP2K_CUSOLVERMP_USE_NCCL OFF - CACHE BOOL "CuSolverMP uses Cal for communication" FORCE) + CACHE BOOL "CuSolverMP uses Cal for communication") endif() endif() @@ -63,13 +64,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;cp2k::UCC::ucc") + set(_comm_lib "cp2k::CAL::cal") endif() set_target_properties( cp2k::CUSOLVER_MP::cusolver_mp PROPERTIES INTERFACE_LINK_LIBRARIES - "${CP2K_CUSOLVER_MP_LINK_LIBRARIES};${_comm_lib}") + "${CP2K_CUSOLVER_MP_LINK_LIBRARIES};${_comm_lib};cp2k::UCC::ucc") set_target_properties( cp2k::CUSOLVER_MP::cusolver_mp PROPERTIES INTERFACE_INCLUDE_DIRECTORIES "${CP2K_CUSOLVER_MP_INCLUDE_DIRS}") diff --git a/data/MACE/MACE_scratch_run-3.model-cp2k.pth b/data/MACE/MACE_scratch_run-3.model-cp2k.pth deleted file mode 100644 index f0ff697cb9..0000000000 Binary files a/data/MACE/MACE_scratch_run-3.model-cp2k.pth and /dev/null differ diff --git a/data/xTB_sp_param_030 b/data/xTB_sp_param_030 deleted file mode 100644 index cdb39466f7..0000000000 --- a/data/xTB_sp_param_030 +++ /dev/null @@ -1,82 +0,0 @@ -# Spin paramters for gfn1-xTB (units Eh) -# -#High-throughput screening of spin states for transition metal -#complexes with spin-polarized extended tight-binding methods -#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme -#J Comput Chem. 44:2120-2129 (2023) -# -# Sign change from suppl material needed! -# -# element Wss Wsp Wpp Wsd Wpd Wdd -1 -0.071550 -0.000000 -0.000000 -0.000000 -0.000000 -0.000000 -2 -0.614675 -0.033587 -0.125800 -0.000000 -0.000000 -0.000000 -3 -0.017775 -0.013937 -0.018050 -0.000000 -0.000000 -0.000000 -4 -0.022850 -0.018612 -0.017575 -0.000000 -0.000000 -0.000000 -5 -0.027325 -0.022037 -0.019600 -0.000000 -0.000000 -0.000000 -6 -0.030200 -0.025025 -0.022725 -0.000000 -0.000000 -0.000000 -7 -0.033000 -0.027475 -0.025475 -0.000000 -0.000000 -0.000000 -8 -0.035100 -0.029500 -0.027825 -0.000000 -0.000000 -0.000000 -9 -0.036900 -0.031200 -0.029900 -0.000000 -0.000000 -0.000000 -10 -0.055008 -0.012830 -0.022600 -0.011925 -0.016737 -0.080725 -11 -0.015100 -0.013337 -0.023025 -0.000000 -0.000000 -0.000000 -12 -0.016500 -0.013175 -0.017400 -0.000000 -0.000000 -0.000000 -13 -0.018250 -0.013837 -0.014000 -0.008175 -0.011637 -0.012875 -14 -0.019525 -0.015000 -0.014350 -0.008437 -0.011637 -0.014075 -15 -0.020550 -0.016112 -0.014900 -0.009300 -0.011975 -0.014825 -16 -0.021325 -0.017012 -0.015500 -0.009987 -0.012137 -0.014950 -17 -0.021825 -0.017712 -0.016075 -0.010987 -0.012612 -0.015075 -18 -0.342475 -0.077825 -0.120675 -0.015500 -0.023075 -0.051925 -19 -0.010650 -0.010900 -0.016375 -0.000000 -0.000000 -0.000000 -20 -0.011800 -0.010387 -0.013350 -0.005562 -0.003512 -0.010200 -21 -0.012725 -0.010912 -0.013850 -0.004787 -0.002412 -0.012525 -22 -0.013525 -0.011225 -0.014675 -0.004350 -0.001975 -0.013900 -23 -0.014075 -0.011512 -0.015275 -0.004037 -0.001725 -0.014900 -24 -0.015175 -0.012450 -0.021225 -0.004150 -0.001662 -0.013875 -25 -0.015000 -0.011787 -0.016725 -0.003550 -0.001325 -0.016525 -26 -0.015400 -0.011925 -0.017850 -0.003300 -0.001162 -0.017125 -27 -0.015825 -0.012037 -0.018700 -0.003137 -0.001050 -0.017750 -28 -0.016150 -0.012175 -0.019700 -0.002987 -0.000950 -0.018300 -29 -0.017150 -0.013175 -0.030375 -0.002775 -0.000650 -0.017475 -30 -0.016850 -0.012312 -0.021450 -0.000000 -0.000000 -0.000000 -31 -0.017225 -0.012787 -0.013400 -0.008525 -0.013000 -0.015775 -32 -0.017550 -0.013375 -0.013575 -0.008112 -0.012825 -0.017525 -33 -0.017750 -0.013762 -0.013600 -0.007987 -0.012387 -0.017550 -34 -0.017975 -0.014087 -0.013625 -0.008162 -0.011962 -0.017200 -35 -0.018100 -0.014375 -0.013725 -0.008275 -0.011762 -0.016675 -36 -0.299025 -0.066587 -0.101875 -0.012575 -0.021287 -0.048300 -37 -0.009550 -0.009600 -0.016725 -0.000000 -0.000000 -0.000000 -38 -0.010650 -0.009237 -0.012525 -0.000000 -0.000000 -0.000000 -39 -0.011425 -0.009487 -0.012300 -0.006725 -0.003987 -0.009725 -40 -0.011950 -0.009612 -0.013525 -0.006150 -0.003075 -0.010725 -41 -0.012575 -0.010262 -0.019075 -0.006062 -0.002887 -0.010475 -42 -0.012925 -0.010500 -0.022225 -0.005562 -0.002362 -0.010925 -43 -0.013150 -0.010662 -0.024725 -0.005112 -0.002025 -0.011300 -44 -0.013375 -0.010750 -0.027500 -0.004750 -0.001662 -0.011625 -45 -0.013525 -0.010912 -0.032025 -0.004400 -0.001425 -0.011875 -46 -0.018975 -0.023937 -0.180200 -0.002087 -0.001487 -0.011325 -47 -0.013925 -0.011100 -0.039800 -0.003887 -0.001012 -0.012400 -48 -0.013850 -0.010500 -0.019650 -0.000000 -0.000000 -0.000000 -49 -0.014125 -0.010550 -0.011575 -0.005062 -0.009375 -0.010100 -50 -0.014300 -0.010912 -0.011675 -0.004600 -0.009125 -0.011875 -51 -0.014525 -0.011125 -0.011650 -0.004375 -0.008725 -0.012525 -52 -0.014525 -0.011237 -0.011550 -0.004137 -0.008162 -0.012250 -53 -0.014575 -0.011337 -0.011450 -0.004450 -0.008312 -0.012825 -54 -0.255850 -0.055587 -0.085625 -0.004662 -0.013337 -0.037350 -55 -0.008200 -0.008575 -0.015300 -0.000000 -0.000000 -0.000000 -56 -0.009275 -0.008200 -0.011250 -0.000000 -0.000000 -0.000000 -57 -0.009925 -0.008412 -0.011400 -0.005925 -0.003312 -0.009025 -72 -0.012175 -0.009625 -0.012600 -0.007637 -0.004187 -0.010425 -73 -0.012325 -0.009575 -0.013375 -0.007137 -0.003475 -0.010925 -74 -0.012500 -0.009562 -0.014450 -0.006725 -0.002950 -0.011225 -75 -0.012600 -0.009662 -0.014800 -0.006275 -0.002600 -0.011450 -76 -0.012600 -0.009200 -0.020600 -0.005950 -0.002075 -0.011550 -77 -0.012725 -0.009275 -0.021000 -0.005700 -0.001912 -0.011650 -78 -0.013075 -0.010212 -0.033575 -0.005550 -0.001812 -0.011150 -79 -0.013150 -0.009962 -0.053000 -0.005287 -0.001462 -0.011175 -80 -0.013025 -0.009187 -0.029250 -0.000000 -0.000000 -0.000000 -81 -0.013275 -0.009112 -0.010725 -0.000000 -0.000000 -0.000000 -82 -0.013475 -0.009350 -0.010975 -0.000000 -0.000000 -0.000000 -83 -0.013625 -0.009537 -0.010975 -0.000000 -0.000000 -0.000000 -84 -0.013725 -0.009625 -0.010850 -0.000000 -0.000000 -0.000000 -85 -0.013775 -0.009737 -0.010725 -0.002612 -0.007362 -0.011925 -86 -0.254400 -0.050400 -0.080625 -0.001087 -0.011050 -0.035175 diff --git a/data/xTB_sp_param_060 b/data/xTB_sp_param_060 deleted file mode 100644 index 7356b7b75f..0000000000 --- a/data/xTB_sp_param_060 +++ /dev/null @@ -1,96 +0,0 @@ -# Spin paramters for gfn1-xTB (units Eh) -# -#High-throughput screening of spin states for transition metal -#complexes with spin-polarized extended tight-binding methods -#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme -#J Comput Chem. 44:2120-2129 (2023) -# -# Sign change from suppl material needed! -# -# element Wss Wsp Wpp Wsd Wpd Wdd - 1 -0.0716250 0.0000000 0.0000000 0.0000000 0.0000000 0.0000000 - 2 -0.0865500 -0.0386630 -0.0674250 0.0000000 0.0000000 0.0000000 - 3 -0.0178000 -0.0139500 -0.0180500 0.0000000 0.0000000 0.0000000 - 4 -0.0229750 -0.0186250 -0.0175750 0.0000000 0.0000000 0.0000000 - 5 -0.0272500 -0.0219370 -0.0195750 0.0000000 0.0000000 0.0000000 - 6 -0.0305000 -0.0250250 -0.0226750 0.0000000 0.0000000 0.0000000 - 7 -0.0330750 -0.0275000 -0.0254500 0.0000000 0.0000000 0.0000000 - 8 -0.0350750 -0.0295380 -0.0278500 0.0000000 0.0000000 0.0000000 - 9 -0.0369000 -0.0311870 -0.0299250 0.0000000 0.0000000 0.0000000 - 10 -0.0383000 -0.0326250 -0.0317250 -0.0141250 -0.0152500 -0.0413500 - 11 -0.0150750 -0.0133370 -0.0229250 0.0000000 0.0000000 0.0000000 - 12 -0.0165000 -0.0130750 -0.0175000 -0.0093750 -0.0179630 -0.0223500 - 13 -0.0182500 -0.0138380 -0.0139750 -0.0082250 -0.0117000 -0.0129000 - 14 -0.0195250 -0.0150000 -0.0143750 -0.0084500 -0.0116120 -0.0140000 - 15 -0.0205750 -0.0161250 -0.0149000 -0.0093000 -0.0119870 -0.0148250 - 16 -0.0213250 -0.0170130 -0.0155000 -0.0100370 -0.0121750 -0.0149500 - 17 -0.0217500 -0.0177130 -0.0160500 -0.0109750 -0.0126620 -0.0150750 - 18 -0.0221500 -0.0183630 -0.0165500 -0.0118870 -0.0131130 -0.0153000 - 19 -0.0106500 -0.0109000 -0.0164750 0.0000000 0.0000000 0.0000000 - 20 -0.0118000 -0.0104500 -0.0134500 -0.0055000 -0.0035130 -0.0101750 - 21 -0.0127250 -0.0108620 -0.0138500 -0.0047880 -0.0024130 -0.0125250 - 22 -0.0134250 -0.0112380 -0.0146500 -0.0043380 -0.0019750 -0.0138750 - 23 -0.0140750 -0.0114630 -0.0152750 -0.0040500 -0.0017250 -0.0149250 - 24 -0.0144750 -0.0116120 -0.0160000 -0.0037250 -0.0014630 -0.0157750 - 25 -0.0149000 -0.0118000 -0.0167250 -0.0034870 -0.0013120 -0.0165000 - 26 -0.0154000 -0.0120250 -0.0177500 -0.0032880 -0.0011630 -0.0171250 - 27 -0.0157000 -0.0120250 -0.0187000 -0.0031500 -0.0010250 -0.0177500 - 28 -0.0161500 -0.0122000 -0.0197000 -0.0030370 -0.0009130 -0.0183000 - 29 -0.0166500 -0.0123500 -0.0203000 -0.0028250 -0.0008620 -0.0188250 - 30 -0.0168500 -0.0123250 -0.0214500 0.0000000 0.0000000 0.0000000 - 31 -0.0172250 -0.0128120 -0.0134000 -0.0085250 -0.0130000 -0.0157750 - 32 -0.0174500 -0.0133500 -0.0135500 -0.0081120 -0.0128130 -0.0175250 - 33 -0.0178750 -0.0137630 -0.0135750 -0.0080500 -0.0123250 -0.0176500 - 34 -0.0180000 -0.0141250 -0.0136250 -0.0081500 -0.0120130 -0.0172000 - 35 -0.0181000 -0.0143750 -0.0136750 -0.0082750 -0.0117500 -0.0167750 - 36 -0.0181250 -0.0145500 -0.0137000 -0.0086880 -0.0118000 -0.0164250 - 37 -0.0095500 -0.0096000 -0.0167250 0.0000000 0.0000000 0.0000000 - 38 -0.0105750 -0.0092870 -0.0125500 -0.0074000 -0.0059000 -0.0079500 - 39 -0.0115000 -0.0098250 -0.0136000 -0.0072880 -0.0046250 -0.0090000 - 40 -0.0121500 -0.0099880 -0.0162250 -0.0066250 -0.0036250 -0.0098750 - 41 -0.0125750 -0.0102620 -0.0191750 -0.0060630 -0.0029250 -0.0104750 - 42 -0.0129000 -0.0105000 -0.0222250 -0.0055750 -0.0024250 -0.0109000 - 43 -0.0131250 -0.0106250 -0.0247250 -0.0051250 -0.0020120 -0.0113000 - 44 -0.0133500 -0.0107620 -0.0276000 -0.0047370 -0.0016750 -0.0116000 - 45 -0.0135500 -0.0108380 -0.0320500 -0.0043750 -0.0014250 -0.0118750 - 46 -0.0136500 -0.0109440 -0.0287000 -0.0041250 -0.0012880 -0.0121250 - 47 -0.0139250 -0.0110500 -0.0241750 -0.0038870 -0.0009630 -0.0124000 - 48 -0.0138500 -0.0105000 -0.0196500 0.0000000 0.0000000 0.0000000 - 49 -0.0142250 -0.0105500 -0.0115750 -0.0050370 -0.0093750 -0.0100000 - 50 -0.0143000 -0.0108750 -0.0116750 -0.0046880 -0.0090750 -0.0118750 - 51 -0.0145250 -0.0111250 -0.0116250 -0.0043750 -0.0087130 -0.0124250 - 52 -0.0145250 -0.0112500 -0.0115750 -0.0041870 -0.0081750 -0.0121750 - 53 -0.0146500 -0.0113870 -0.0114750 -0.0044620 -0.0083620 -0.0128250 - 54 -0.0146500 -0.0114250 -0.0114500 -0.0048750 -0.0085750 -0.0132000 - 55 -0.0082000 -0.0085880 -0.0153000 0.0000000 0.0000000 0.0000000 - 56 -0.0092500 -0.0083000 -0.0113750 -0.0063870 -0.0042250 -0.0079250 - 57 -0.0099000 -0.0084250 -0.0114000 -0.0059370 -0.0033750 -0.0090250 - 58 -0.0881750 -0.0066380 -0.0019250 -0.0017000 -0.0017000 -0.0234250 - 59 -0.0890750 -0.0065000 -0.0009500 -0.0015370 -0.0017370 -0.0237000 - 60 -0.0901000 -0.0063750 -0.0000750 -0.0014630 -0.0016250 -0.0230250 - 61 -0.0908000 -0.0064880 0.0004500 -0.0013000 -0.0016500 -0.0226250 - 62 -0.0918250 -0.0065380 0.0014000 -0.0012750 -0.0017250 -0.0222250 - 63 -0.0922250 -0.0065380 0.0017250 -0.0012000 -0.0018000 -0.0218250 - 64 -0.0928812 -0.0065798 0.0024101 -0.0011021 -0.0016846 -0.0209135 - 65 -0.0936096 -0.0066189 0.0030779 -0.0010125 -0.0016808 -0.0201625 - 66 -0.0943380 -0.0066581 0.0037457 -0.0009229 -0.0016769 -0.0194115 - 67 -0.0951750 -0.0067500 0.0042250 -0.0008380 -0.0016250 -0.0190000 - 68 -0.0956500 -0.0067250 0.0040000 -0.0007370 -0.0007630 -0.0176000 - 69 -0.0963500 -0.0067370 0.0044000 -0.0006750 -0.0007065 -0.0160000 - 70 -0.0958500 -0.0066500 0.0024000 -0.0007500 -0.0008000 -0.0175500 - 71 -0.1086250 -0.0079000 0.0063250 -0.0047000 -0.0007120 -0.0269000 - 72 -0.0121750 -0.0096750 -0.0126250 -0.0076250 -0.0041130 -0.0104250 - 73 -0.0123000 -0.0095750 -0.0134000 -0.0071380 -0.0034630 -0.0109250 - 74 -0.0125000 -0.0094620 -0.0144500 -0.0066880 -0.0029130 -0.0112500 - 75 -0.0126000 -0.0093310 -0.0148000 -0.0063000 -0.0026130 -0.0114500 - 76 -0.0127000 -0.0092000 -0.0205750 -0.0059380 -0.0021120 -0.0115500 - 77 -0.0127500 -0.0092750 -0.0209250 -0.0056880 -0.0019120 -0.0116000 - 78 -0.0127500 -0.0092250 -0.0222500 -0.0054370 -0.0017870 -0.0117000 - 79 -0.0129000 -0.0089380 -0.0257625 -0.0052500 -0.0015000 -0.0117750 - 80 -0.0129250 -0.0091870 -0.0292750 0.0000000 0.0000000 0.0000000 - 81 -0.0133500 -0.0091120 -0.0107250 0.0000000 0.0000000 0.0000000 - 82 -0.0135750 -0.0094250 -0.0110000 0.0000000 0.0000000 0.0000000 - 83 -0.0136750 -0.0095380 -0.0109500 0.0000000 0.0000000 0.0000000 - 84 -0.0137500 -0.0096380 -0.0108500 0.0000000 0.0000000 0.0000000 - 85 -0.0137750 -0.0096750 -0.0107250 -0.0026000 -0.0073630 -0.0119000 - 86 -0.0139000 -0.0097380 -0.0106500 -0.0028750 -0.0078120 -0.0130000 diff --git a/docs/generate_input_reference.py b/docs/generate_input_reference.py index 7db6276aa0..9a51f77e42 100755 --- a/docs/generate_input_reference.py +++ b/docs/generate_input_reference.py @@ -342,28 +342,20 @@ def render_keyword( output += [f":module: {section_xref}"] else: output += [":noindex:"] - 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)}"] + output += [f":type: '{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())}"] + default_unit_bracketed = f"[{default_unit}]" if default_unit else "" + output += [f":value: '{default_value} {default_unit_bracketed}'"] + output += [""] if repeats: - metadata += ["**Repeatable:** yes"] + output += ["**Keyword can be repeated.**", ""] if len(keyword_names) > 1: - aliases = ", ".join(keyword_names[1:]) - metadata += [f"**Aliases:** {escape_markdown(aliases)}"] + aliases = " ,".join(keyword_names[1:]) + output += [f"**Aliases:** {escape_markdown(aliases)}", ""] if lone_keyword_value: - metadata += [f"**Lone keyword:** {escape_markdown(lone_keyword_value)}"] + output += [f"**Lone keyword:** `{escape_markdown(lone_keyword_value)}`", ""] if usage: - metadata += [f"**Usage:** _{escape_markdown(usage)}_"] - output += [" \n".join(metadata), ""] - if description: - output += [f"**Description:** {escape_markdown(description)}", ""] + output += [f"**Usage:** _{escape_markdown(usage)}_", ""] if data_type == "enum": output += ["**Valid values:**"] for item in keyword.findall("DATA_TYPE/ENUMERATION/ITEM"): @@ -377,6 +369,7 @@ 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. diff --git a/docs/methods/machine_learning/index.md b/docs/methods/machine_learning/index.md index f3ae029b1e..004f3c7a6e 100644 --- a/docs/methods/machine_learning/index.md +++ b/docs/methods/machine_learning/index.md @@ -6,7 +6,6 @@ titlesonly: maxdepth: 2 --- nequip -mace nnp pao-ml deepmd diff --git a/docs/methods/machine_learning/mace.md b/docs/methods/machine_learning/mace.md deleted file mode 100644 index 7e3bf66da5..0000000000 --- a/docs/methods/machine_learning/mace.md +++ /dev/null @@ -1,60 +0,0 @@ -# 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). diff --git a/docs/methods/semiempiricals/xtb.md b/docs/methods/semiempiricals/xtb.md index 1f2763f148..d70feed8b4 100644 --- a/docs/methods/semiempiricals/xtb.md +++ b/docs/methods/semiempiricals/xtb.md @@ -287,8 +287,9 @@ GFN2-xTB method. Please note that k-points are fully supported for tblite in CP2 In case of open-shell calculations, a spin-polarization term can be enabled with the [LSD](#CP2K_INPUT.FORCE_EVAL.DFT.UKS) keyword in CP2K. In this case, tblite automatically allows the -usage of spGFN2-xTB for calculations as described in [Neugebauer2023](#Neugebauer2023). An example -for triplet oxygen is shown here. +usage of spGFN2-xTB for calculations as described in +[Neugebauer2023](https://onlinelibrary.wiley.com/doi/full/10.1002/jcc.27185). An example for triplet +oxygen is shown here. ``` &FORCE_EVAL diff --git a/docs/technologies/eigensolvers/cusolvermp.md b/docs/technologies/eigensolvers/cusolvermp.md index 49861b5d94..ac59195bdd 100644 --- a/docs/technologies/eigensolvers/cusolvermp.md +++ b/docs/technologies/eigensolvers/cusolvermp.md @@ -13,6 +13,7 @@ tools for the solution of dense linear systems and eigenvalue problems. [cuSOLVERmp] >= 0.7 - [NCCL]: requires `libnccl.\*` in the `$PATH` +- [UCC]: requires `libucc.\*` and `libucs.\*` in the `$PATH` ## CMake diff --git a/docs/technologies/libraries.md b/docs/technologies/libraries.md index 86a2cb3451..2e5bf4ebbf 100644 --- a/docs/technologies/libraries.md +++ b/docs/technologies/libraries.md @@ -220,8 +220,8 @@ of each atom. ## Torch (PyTorch C++ library) -LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP and MACE interfaces and for -GauXC Skala models. +LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP interface and for GauXC +Skala models. - LibTorch can be downloaded from the [PyTorch installation page](https://pytorch.org/get-started/locally/). diff --git a/docs/versions.md b/docs/versions.md index 923bdbb73d..48f5f78b15 100644 --- a/docs/versions.md +++ b/docs/versions.md @@ -5,7 +5,6 @@ maxdepth: 1 titlesonly: --- -2026.2 2026.1 2025.2 2025.1 diff --git a/make_cp2k.sh b/make_cp2k.sh index db27114208..d6bb56006c 100755 --- a/make_cp2k.sh +++ b/make_cp2k.sh @@ -1363,7 +1363,6 @@ 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}" \ @@ -1381,7 +1380,6 @@ 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}" \ @@ -1403,7 +1401,6 @@ if [[ ! -d "${CMAKE_BUILD_PATH}" ]]; then -DCMAKE_EXE_LINKER_FLAGS="-static" \ -DCMAKE_FIND_LIBRARY_SUFFIXES=".a" \ -DCMAKE_INSTALL_PREFIX="${INSTALL_PREFIX}" \ - -DCMAKE_INSTALL_LIBDIR="lib" \ -DCMAKE_INSTALL_MESSAGE="${INSTALL_MESSAGE}" \ -DCMAKE_SKIP_RPATH="ON" \ -DCMAKE_VERBOSE_MAKEFILE="${VERBOSE_MAKEFILE}" \ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 92b24bfd04..21439a11e8 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -329,7 +329,6 @@ 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 @@ -355,7 +354,7 @@ list( manybody_deepmd.F manybody_gal21.F manybody_gal.F - manybody_e3nn.F + manybody_nequip.F manybody_potential.F manybody_siepmann.F manybody_tersoff.F @@ -884,7 +883,6 @@ list( xray_diffraction.F xtb_qresp.F xtb_coulomb.F - xtb_spinpol.F xtb_eeq.F xtb_ehess.F xtb_ehess_force.F @@ -1053,9 +1051,7 @@ 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( @@ -1382,7 +1378,6 @@ list( xc/xc.F xc/xc_functionals_utilities.F xc/xc_fxc_kernel.F - xc/xc_gauxc_cache.F xc/xc_gauxc_functional.F xc/xc_gauxc_interface.F xc/xc_hcth.F diff --git a/src/accint_weights_forces.F b/src/accint_weights_forces.F index f56be20318..b5d9376e9b 100644 --- a/src/accint_weights_forces.F +++ b/src/accint_weights_forces.F @@ -412,7 +412,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_g_base, rho_r, rho_g) - ELSE IF (ASSOCIATED(rho_r_base)) THEN + ELSEIF (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) - ELSE IF (ASSOCIATED(tau_r_base)) THEN + ELSEIF (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) - ELSE IF (ASSOCIATED(rho1_r_base)) THEN + ELSEIF (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) - ELSE IF (ASSOCIATED(tau1_r_base)) THEN + ELSEIF (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) - ELSE IF (ASSOCIATED(rho1_r_base)) THEN + ELSEIF (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) - ELSE IF (ASSOCIATED(tau1_r_base)) THEN + ELSEIF (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,9 +574,8 @@ CONTAINS DEALLOCATE (vxc_rho) END IF IF (ASSOCIATED(vxc_tau)) THEN - IF (.NOT. ASSOCIATED(tau1_r)) THEN + IF (.NOT. ASSOCIATED(tau1_r)) & CPABORT("Tau response density required for mGGA xc_density") - END IF DO ispin = 1, nspins CALL pw_multiply_with(vxc_tau(ispin), tau1_r(ispin)) CALL pw_axpy(vxc_tau(ispin), exc, 1.0_dp) diff --git a/src/admm_dm_methods.F b/src/admm_dm_methods.F index a2c56f3155..7d046cdca3 100644 --- a/src/admm_dm_methods.F +++ b/src/admm_dm_methods.F @@ -76,9 +76,8 @@ CONTAINS CPABORT("admm_dm_calc_rho_aux: unknown method") END SELECT - IF (admm_dm%purify) THEN + IF (admm_dm%purify) & CALL purify_mcweeny(qs_env) - END IF CALL update_rho_aux(qs_env) @@ -121,9 +120,8 @@ CONTAINS CPABORT("admm_dm_merge_ks_matrix: unknown method") END SELECT - IF (admm_dm%purify) THEN + IF (admm_dm%purify) & CALL dbcsr_deallocate_matrix_set(matrix_ks_merge) - END IF CALL timestop(handle) @@ -219,9 +217,8 @@ 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) THEN + IF (found) & sparse_block_aux = sparse_block - END IF END IF END DO CALL dbcsr_iterator_stop(iter) @@ -336,9 +333,8 @@ 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) THEN + IF (admm_dm%block_map(iatom, jatom) == 0) & sparse_block = 0.0_dp - END IF END DO CALL dbcsr_iterator_stop(iter) CALL dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_merge(ispin)%matrix, 1.0_dp, 1.0_dp) diff --git a/src/admm_dm_types.F b/src/admm_dm_types.F index 90183cb8a4..2ca1e1d4d7 100644 --- a/src/admm_dm_types.F +++ b/src/admm_dm_types.F @@ -105,9 +105,8 @@ CONTAINS DEALLOCATE (admm_dm%matrix_a) END IF - IF (ASSOCIATED(admm_dm%block_map)) THEN + IF (ASSOCIATED(admm_dm%block_map)) & DEALLOCATE (admm_dm%block_map) - END IF DEALLOCATE (admm_dm%mcweeny_history) DEALLOCATE (admm_dm) diff --git a/src/admm_methods.F b/src/admm_methods.F index 9715ce9516..42d3850230 100644 --- a/src/admm_methods.F +++ b/src/admm_methods.F @@ -226,13 +226,12 @@ CONTAINS END IF - IF (admm_env%purification_method == do_admm_purify_cauchy) THEN + IF (admm_env%purification_method == do_admm_purify_cauchy) & 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 @@ -2181,15 +2180,13 @@ 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) THEN + IF (.NOT. use_real_wfn) & 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) THEN + IF (.NOT. use_real_wfn) & 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 @@ -2987,14 +2984,12 @@ 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) THEN + IF (.NOT. use_real_wfn) & 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) THEN + IF (.NOT. use_real_wfn) & CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) - END IF END IF END DO END DO diff --git a/src/admm_types.F b/src/admm_types.F index e02e1ba93f..3aefcb365e 100644 --- a/src/admm_types.F +++ b/src/admm_types.F @@ -382,15 +382,12 @@ 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)) THEN + IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & admm_env%do_admmp = .TRUE. - END IF - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) THEN + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) & admm_env%do_admmq = .TRUE. - END IF - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & 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 @@ -486,16 +483,13 @@ CONTAINS DEALLOCATE (admm_env%eigvals_lambda) DEALLOCATE (admm_env%eigvals_P_to_be_purified) - IF (ASSOCIATED(admm_env%block_map)) THEN + IF (ASSOCIATED(admm_env%block_map)) & DEALLOCATE (admm_env%block_map) - END IF - IF (ASSOCIATED(admm_env%xc_section_primary)) THEN + IF (ASSOCIATED(admm_env%xc_section_primary)) & CALL section_vals_release(admm_env%xc_section_primary) - END IF - IF (ASSOCIATED(admm_env%xc_section_aux)) THEN + IF (ASSOCIATED(admm_env%xc_section_aux)) & CALL section_vals_release(admm_env%xc_section_aux) - END IF IF (ASSOCIATED(admm_env%admm_gapw_env)) CALL admm_gapw_env_release(admm_env%admm_gapw_env) IF (ASSOCIATED(admm_env%admm_dm)) CALL admm_dm_release(admm_env%admm_dm) diff --git a/src/almo_scf.F b/src/almo_scf.F index c01f6f1a07..b005bb02e6 100644 --- a/src/almo_scf.F +++ b/src/almo_scf.F @@ -1400,6 +1400,7 @@ 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 @@ -1461,6 +1462,25 @@ 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, & @@ -1565,6 +1585,18 @@ 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, & @@ -2590,9 +2622,8 @@ 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) THEN + IF (almo_scf_env%need_previous_ks) & ALLOCATE (almo_scf_env%matrix_ks_0deloc(nspins)) - END IF DO ispin = 1, nspins ! RZK-warning copy with symmery but remember that this might cause problems CALL dbcsr_create(almo_scf_env%matrix_p(ispin), & diff --git a/src/almo_scf_diis_types.F b/src/almo_scf_diis_types.F index 75341d7de5..d776ff9d8b 100644 --- a/src/almo_scf_diis_types.F +++ b/src/almo_scf_diis_types.F @@ -258,9 +258,8 @@ 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) THEN + IF (diis_env%buffer_length > diis_env%max_buffer_length) & diis_env%buffer_length = diis_env%max_buffer_length - END IF !!!! resize B matrix !!!IF (old_buffer_length.lt.diis_env%buffer_length) THEN @@ -403,12 +402,24 @@ 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 @@ -430,6 +441,7 @@ CONTAINS checksum = checksum + coeff(im + 1) END DO END IF + !WRITE(*,*) checksum DEALLOCATE (coeff) diff --git a/src/almo_scf_env_methods.F b/src/almo_scf_env_methods.F index adb25ed0f3..06a3d9f70f 100644 --- a/src/almo_scf_env_methods.F +++ b/src/almo_scf_env_methods.F @@ -364,6 +364,108 @@ CONTAINS almo_scf_env%activate = 0 END IF + !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_AOS",& + ! i_val=almo_scf_env%domain_layout_aos) + !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_MOS",& + ! i_val=almo_scf_env%domain_layout_mos) + !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_AOS",& + ! i_val=almo_scf_env%mat_distr_aos) + !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_MOS",& + ! i_val=almo_scf_env%mat_distr_mos) + !CALL section_vals_val_get(almo_scf_section,"CONSTRAINT_TYPE",& + ! i_val=almo_scf_env%constraint_type) + !CALL section_vals_val_get(almo_scf_section,"MU",& + ! r_val=almo_scf_env%mu) + !CALL section_vals_val_get(almo_scf_section,"FIXED_MU",& + ! l_val=almo_scf_env%fixed_mu) + !CALL section_vals_val_get(almo_scf_section,"EPS_USE_PREV_AS_GUESS",& + ! r_val=almo_scf_env%eps_prev_guess) + !CALL section_vals_val_get(almo_scf_section,"MIXING_FRACTION",& + ! r_val=almo_scf_env%mixing_fraction) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_TENSOR_TYPE",& + ! i_val=almo_scf_env%deloc_cayley_tensor_type) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_CONJUGATOR",& + ! i_val=almo_scf_env%deloc_cayley_conjugator) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_MAX_ITER",& + ! i_val=almo_scf_env%deloc_cayley_max_iter) + !CALL section_vals_val_get(almo_scf_section,"DELOC_USE_OCC_ORBS",& + ! l_val=almo_scf_env%deloc_use_occ_orbs) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_USE_VIRT_ORBS",& + ! l_val=almo_scf_env%deloc_cayley_use_virt_orbs) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_LINEAR",& + ! l_val=almo_scf_env%deloc_cayley_linear) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_EPS_CONVERGENCE",& + ! r_val=almo_scf_env%deloc_cayley_eps_convergence) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_OCC_PRECOND",& + ! l_val=almo_scf_env%deloc_cayley_occ_precond) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_VIR_PRECOND",& + ! l_val=almo_scf_env%deloc_cayley_vir_precond) + !CALL section_vals_val_get(almo_scf_section,"ALMO_UPDATE_ALGORITHM_BD",& + ! i_val=almo_scf_env%almo_update_algorithm) + !CALL section_vals_val_get(almo_scf_section,"DELOC_TRUNCATE_VIRTUALS",& + ! i_val=almo_scf_env%deloc_truncate_virt) + !CALL section_vals_val_get(almo_scf_section,"DELOC_VIRT_PER_DOMAIN",& + ! i_val=almo_scf_env%deloc_virt_per_domain) + ! + !CALL section_vals_val_get(almo_scf_section,"OPT_K_EPS_CONVERGENCE",& + ! r_val=almo_scf_env%opt_k_eps_convergence) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_MAX_ITER",& + ! i_val=almo_scf_env%opt_k_max_iter) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_OUTER_MAX_ITER",& + ! i_val=almo_scf_env%opt_k_outer_max_iter) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE",& + ! r_val=almo_scf_env%opt_k_trial_step_size) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJUGATOR",& + ! i_val=almo_scf_env%opt_k_conjugator) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE_MULTIPLIER",& + ! r_val=almo_scf_env%opt_k_trial_step_size_multiplier) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_START",& + ! i_val=almo_scf_env%opt_k_conj_iter_start) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_START",& + ! i_val=almo_scf_env%opt_k_prec_iter_start) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_FREQ_RESET",& + ! i_val=almo_scf_env%opt_k_conj_iter_freq) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_FREQ_UPDATE",& + ! i_val=almo_scf_env%opt_k_prec_iter_freq) + ! + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_RADIUS_TYPE",& + ! i_val=almo_scf_env%quencher_radius_type) + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_FACTOR",& + ! r_val=almo_scf_env%quencher_r0_factor) + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_FACTOR",& + ! r_val=almo_scf_env%quencher_r1_factor) + !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_SHIFT",& + !! r_val=almo_scf_env%quencher_r0_shift) + !! + !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_SHIFT",& + !! r_val=almo_scf_env%quencher_r1_shift) + !! + !!almo_scf_env%quencher_r0_shift = cp_unit_to_cp2k(& + !! almo_scf_env%quencher_r0_shift,"angstrom") + !!almo_scf_env%quencher_r1_shift = cp_unit_to_cp2k(& + !! almo_scf_env%quencher_r1_shift,"angstrom") + ! + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_0",& + ! r_val=almo_scf_env%quencher_s0) + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_1",& + ! r_val=almo_scf_env%quencher_s1) + + !CALL section_vals_val_get(almo_scf_section,"ENVELOPE_AMPLITUDE",& + ! r_val=almo_scf_env%envelope_amplitude) + + !! how to read lists + !CALL section_vals_val_get(almo_scf_section,"INT_LIST01", & + ! n_rep_val=n_rep) + !counter_i = 0 + !DO k = 1,n_rep + ! CALL section_vals_val_get(almo_scf_section,"INT_LIST01",& + ! i_rep_val=k,i_vals=tmplist) + ! DO jj = 1,SIZE(tmplist) + ! counter_i=counter_i+1 + ! almo_scf_env%charge_of_domain(counter_i)=tmplist(jj) + ! ENDDO + !ENDDO + almo_scf_env%domain_layout_aos = almo_domain_layout_molecular almo_scf_env%domain_layout_mos = almo_domain_layout_molecular almo_scf_env%mat_distr_aos = almo_mat_distr_molecular diff --git a/src/almo_scf_methods.F b/src/almo_scf_methods.F index 67c4a367cf..fdcc864590 100644 --- a/src/almo_scf_methods.F +++ b/src/almo_scf_methods.F @@ -1620,9 +1620,8 @@ CONTAINS my_algorithm = 0 IF (PRESENT(algorithm)) my_algorithm = algorithm - IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) THEN + IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) & CPABORT("PARA and BLACS env are necessary for cholesky algorithm") - END IF use_sigma_inv_guess = .FALSE. IF (PRESENT(use_guess)) THEN @@ -2093,6 +2092,7 @@ 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,6 +2100,11 @@ 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, & @@ -2252,10 +2257,16 @@ 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) @@ -2304,9 +2315,38 @@ 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, & @@ -2320,6 +2360,7 @@ 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)) @@ -2594,6 +2635,24 @@ 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 @@ -2630,6 +2689,21 @@ 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 @@ -2842,6 +2916,21 @@ CONTAINS END SELECT + !! compute the inversion error + !allocate(temp1(N,N)) + !temp1=MATMUL(Ainv,A) + !DO ii=1,N + ! temp1(ii,ii)=temp1(ii,ii)-1.0_dp + !ENDDO + !temp1_error=0.0_dp + !DO ii=1,N + ! DO jj=1,N + ! temp1_error=temp1_error+temp1(jj,ii)*temp1(jj,ii) + ! ENDDO + !ENDDO + !WRITE(*,*) "Inversion error: ", SQRT(temp1_error) + !deallocate(temp1) + CALL timestop(handle) END SUBROUTINE pseudo_invert_matrix diff --git a/src/almo_scf_optimizer.F b/src/almo_scf_optimizer.F index 8325511ab0..b516dcac0c 100644 --- a/src/almo_scf_optimizer.F +++ b/src/almo_scf_optimizer.F @@ -72,7 +72,8 @@ MODULE almo_scf_optimizer ct_step_env_init,& ct_step_env_set,& ct_step_env_type - USE domain_submatrix_methods, ONLY: construct_submatrices,& + USE domain_submatrix_methods, ONLY: add_submatrices,& + construct_submatrices,& copy_submatrices,& init_submatrices,& maxnorm_submatrices,& @@ -225,11 +226,11 @@ CONTAINS ! get error_norm: choose the largest of the two spins prev_error_norm = error_norm DO ispin = 1, nspin + !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm_ispin = dbcsr_maxabs(almo_scf_env%matrix_err_blk(ispin)) IF (ispin == 1) error_norm = error_norm_ispin - IF (ispin > 1 .AND. error_norm_ispin > error_norm) THEN + IF (ispin > 1 .AND. error_norm_ispin > error_norm) & error_norm = error_norm_ispin - END IF END DO IF (error_norm < almo_scf_env%eps_prev_guess) THEN @@ -252,9 +253,8 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) THEN + IF (optimizer%early_stopping_on .AND. iscf == 1) & prepare_to_exit = .FALSE. - END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix @@ -294,7 +294,21 @@ CONTAINS local_nocc_of_domain(:) = almo_scf_env%nocc_of_domain(:, ispin) local_mu(:) = almo_scf_env%mu_of_domain(:, ispin) + ! RZK UPDATE! the update algorithm is removed because + ! RZK UPDATE! it requires updating core LS_SCF routines + ! RZK UPDATE! (the code exists in the CVS version) CPABORT("Density_matrix_sign has not been tested yet") + ! RZK UPDATE! CALL density_matrix_sign(almo_scf_env%matrix_p_blk(ispin),& + ! RZK UPDATE! local_mu,& + ! RZK UPDATE! almo_scf_env%fixed_mu,& + ! RZK UPDATE! almo_scf_env%matrix_ks_blk(ispin),& + ! RZK UPDATE! !matrix_mixing_old_blk(ispin),& + ! RZK UPDATE! almo_scf_env%matrix_s_blk(1), & + ! RZK UPDATE! almo_scf_env%matrix_s_blk_inv(1), & + ! RZK UPDATE! local_nocc_of_domain,& + ! RZK UPDATE! almo_scf_env%eps_filter,& + ! RZK UPDATE! almo_scf_env%domain_index_of_ao) + ! RZK UPDATE! almo_scf_env%mu_of_domain(:, ispin) = local_mu(:) END DO @@ -483,6 +497,13 @@ CONTAINS dpattern=almo_scf_env%quench_t(ispin), & map=almo_scf_env%domain_map(ispin), & node_of_domain=almo_scf_env%cpu_of_domain) + ! TRY: construct s_inv + !CALL construct_domain_s_inv(& + ! matrix_s=almo_scf_env%matrix_s(1),& + ! subm_s_inv=almo_scf_env%domain_s_inv(:,ispin),& + ! dpattern=almo_scf_env%quench_t(ispin),& + ! map=almo_scf_env%domain_map(ispin),& + ! node_of_domain=almo_scf_env%cpu_of_domain) ! construct the domain template for the occupied orbitals DO ispin = 1, nspin @@ -503,6 +524,27 @@ CONTAINS CALL init_submatrices(submatrix_mixing_old_blk) ALLOCATE (almo_diis(nspin)) + ! TRY: construct block-projector + !ALLOCATE(submatrix_tmp(almo_scf_env%ndomains)) + !DO ispin=1,nspin + ! CALL init_submatrices(submatrix_tmp) + ! CALL construct_domain_r_down(& + ! matrix_t=almo_scf_env%matrix_t_blk(ispin),& + ! matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& + ! matrix_s=almo_scf_env%matrix_s(1),& + ! subm_r_down=submatrix_tmp(:),& + ! dpattern=almo_scf_env%quench_t(ispin),& + ! map=almo_scf_env%domain_map(ispin),& + ! node_of_domain=almo_scf_env%cpu_of_domain,& + ! filter_eps=almo_scf_env%eps_filter) + ! CALL multiply_submatrices('N','N',1.0_dp,& + ! submatrix_tmp(:),& + ! almo_scf_env%domain_s_inv(:,1),0.0_dp,& + ! almo_scf_env%domain_r_down_up(:,ispin)) + ! CALL release_submatrices(submatrix_tmp) + !ENDDO + !DEALLOCATE(submatrix_tmp) + DO ispin = 1, nspin ! use s_sqrt since they are already properly constructed ! and have the same distributions as domain_err and domain_ks_xx @@ -536,6 +578,7 @@ CONTAINS ! check convergence converged = .TRUE. DO ispin = 1, nspin + !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm = dbcsr_maxabs(almo_scf_env%matrix_err_xx(ispin)) CALL maxnorm_submatrices(almo_scf_env%domain_err(:, ispin), & norm=error_norm_0) @@ -553,18 +596,28 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) THEN + IF (optimizer%early_stopping_on .AND. iscf == 1) & prepare_to_exit = .FALSE. - END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix ! perform mixing of KS matrices IF (iscf /= 1) THEN - DO ispin = 1, nspin - CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & - d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) - END DO + IF (.FALSE.) THEN ! use diis instead of mixing + DO ispin = 1, nspin + CALL add_submatrices( & + almo_scf_env%mixing_fraction, & + almo_scf_env%domain_ks_xx(:, ispin), & + 1.0_dp - almo_scf_env%mixing_fraction, & + submatrix_mixing_old_blk(:, ispin), & + 'N') + END DO + ELSE + DO ispin = 1, nspin + CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & + d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) + END DO + END IF END IF ! save the new matrix for the future mixing DO ispin = 1, nspin @@ -641,6 +694,64 @@ CONTAINS denergy_tot = denergy_tot + denergy_spin(ispin) + ! RZK-warning Energy correction can be evaluated using matrix_x + ! as shown in the attempt below and in the PCG procedure. + ! Using matrix_x allows immediate decomposition of the energy + ! lowering into 2-body components for EDA. However, it does not + ! work here because the diagonalization routine does not necessarily + ! produce orbitals with the same sign as the block-diagonal ALMOs + ! Any fixes?! + + !CALL dbcsr_init(matrix_x) + !CALL dbcsr_create(matrix_x,& + ! template=almo_scf_env%matrix_t(ispin)) + ! + !CALL dbcsr_init(matrix_tmp_no) + !CALL dbcsr_create(matrix_tmp_no,& + ! template=almo_scf_env%matrix_t(ispin)) + ! + !CALL dbcsr_copy(matrix_x,& + ! almo_scf_env%matrix_t_blk(ispin)) + !CALL dbcsr_add(matrix_x,almo_scf_env%matrix_t(ispin),& + ! -1.0_dp,1.0_dp) + + !CALL dbcsr_dot(matrix_x, almo_scf_env%matrix_err_xx(ispin),denergy) + + !denergy=denergy*spin_factor + + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "_ENERGY-0: ", almo_scf_env%almo_scf_energy + ! WRITE(unit_nr,*) "_ENERGY-D: ", denergy + ! WRITE(unit_nr,*) "_ENERGY-F: ", almo_scf_env%almo_scf_energy+denergy + !ENDIF + !! RZK-warning update will not work since the energy is overwritten almost immediately + !!CALL almo_scf_update_ks_energy(qs_env,& + !! almo_scf_env%almo_scf_energy+denergy) + !! + + !! print out the results of the decomposition analysis + !CALL dbcsr_hadamard_product(matrix_x,& + ! almo_scf_env%matrix_err_xx(ispin),& + ! matrix_tmp_no) + !CALL dbcsr_scale(matrix_tmp_no,spin_factor) + !CALL dbcsr_filter(matrix_tmp_no,almo_scf_env%eps_filter) + ! + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) + ! WRITE(unit_nr,'(T2,A)') "DECOMPOSITION OF THE DELOCALIZATION ENERGY" + !ENDIF + + !mynode=dbcsr_mp_mynode(dbcsr_distribution_mp(& + ! dbcsr_distribution(matrix_tmp_no))) + !WRITE(mynodestr,'(I6.6)') mynode + !mylogfile='EDA.'//TRIM(ADJUSTL(mynodestr)) + !OPEN (iunit,file=mylogfile,status='REPLACE') + !CALL print_block_sum(matrix_tmp_no,iunit) + !CLOSE(iunit) + ! + !CALL dbcsr_release(matrix_tmp_no) + !CALL dbcsr_release(matrix_x) + END IF ! iscf.eq.1 END DO @@ -844,11 +955,13 @@ CONTAINS eps_skip_gradients = almo_scf_env%real01 ! penalty amplitude adjusts the strength of volume conservation - energy_coeff = 1.0_dp - localiz_coeff = 0.0_dp - penalty_amplitude = 0.0_dp - penalty_occ_vol = .FALSE. - penalty_occ_local = .FALSE. + energy_coeff = 1.0_dp !optimizer%opt_penalty%energy_coeff + localiz_coeff = 0.0_dp !optimizer%opt_penalty%occ_loc_coeff + penalty_amplitude = 0.0_dp !optimizer%opt_penalty%occ_vol_coeff + penalty_occ_vol = .FALSE. !( optimizer%opt_penalty%occ_vol_method & + !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) + penalty_occ_local = .FALSE. !( optimizer%opt_penalty%occ_loc_method & + !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) normalize_orbitals = penalty_occ_vol .OR. penalty_occ_local ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) ALLOCATE (penalty_occ_vol_h_prefactor(nspins)) @@ -1209,6 +1322,9 @@ CONTAINS DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im + !CALL matrix_qs_to_almo(op_sm_set_qs(reim, idim0)%matrix, + ! op_sm_set_almo(reim, idim0)%matrix, & + ! almo_scf_env%mat_distr_aos) CALL dbcsr_multiply("N", "N", 1.0_dp, & op_sm_set_almo(reim, idim0)%matrix, & matrix_t_out(ispin), & @@ -1263,9 +1379,8 @@ CONTAINS ! save the previous gradient to compute beta ! do it only if the previous grad was computed ! for .NOT.line_search - IF (line_search_iteration == 0 .AND. iteration /= 0) THEN + IF (line_search_iteration == 0 .AND. iteration /= 0) & CALL dbcsr_copy(prev_grad(ispin), grad(ispin)) - END IF END DO ! ispin @@ -1379,13 +1494,11 @@ CONTAINS prepare_to_exit = .TRUE. END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. just_started) THEN + IF (optimizer%early_stopping_on .AND. just_started) & prepare_to_exit = .FALSE. - END IF - IF (grad_norm < almo_scf_env%eps_prev_guess) THEN + IF (grad_norm < almo_scf_env%eps_prev_guess) & use_guess = .TRUE. - END IF ! it is not time to exit just yet IF (.NOT. prepare_to_exit) THEN @@ -1467,6 +1580,10 @@ CONTAINS ! update the step direction IF (.NOT. line_search) THEN + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....updating step direction...." + !ENDIF + cg_iteration = cg_iteration + 1 ! save the previous step @@ -1546,6 +1663,10 @@ CONTAINS END DO ! ispin END IF ! compute_prec + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....applying precomputed preconditioner...." + !ENDIF + IF (my_special_case == xalmo_case_block_diag .OR. & my_special_case == xalmo_case_fully_deloc) THEN @@ -1579,6 +1700,16 @@ CONTAINS filter_eps=almo_scf_env%eps_filter) CALL dbcsr_scale(step(ispin), -1.0_dp) + !CALL dbcsr_copy(m_tmp_no_3,& + ! quench_t(ispin)) + !CALL inverse_of_elements(m_tmp_no_3) + !CALL dbcsr_copy(m_tmp_no_2,step) + !CALL dbcsr_hadamard_product(& + ! m_tmp_no_2,& + ! m_tmp_no_3,& + ! step) + !CALL dbcsr_copy(m_tmp_no_3,quench_t(ispin)) + END DO ! ispin END IF ! special case @@ -1631,6 +1762,10 @@ CONTAINS CALL dbcsr_copy(prev_minus_prec_grad(ispin), step(ispin)) + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....final beta....", beta + !ENDIF + ! conjugate the step direction CALL dbcsr_add(step(ispin), prev_step(ispin), 1.0_dp, beta) @@ -1659,6 +1794,10 @@ CONTAINS step_size = next_step_size_guess*1.05_dp END IF END IF + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,3F12.5)') & + ! "EG", e0, g0, step_size + !ENDIF next_step_size_guess = step_size ELSE IF (fixed_line_search_niter == 0) THEN @@ -1671,6 +1810,10 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,7F12.5)') & + ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der + !ENDIF step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -1681,6 +1824,11 @@ CONTAINS e1 = energy_new appr_sec_der = 2.0*((e1 - e0)/step_size - g0)/step_size g1 = appr_sec_der*step_size + g0 + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,7F12.5)') & + ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der + !ENDIF + !appr_sec_der=(g1-g0)/step_size step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -1996,7 +2144,7 @@ CONTAINS ALLOCATE (m_B0(1, dim_op, nspins)) !m_B0 first dim is 1 now! DO idim0 = 1, dim_op - DO reim = 1, 1 + DO reim = 1, 1 !SIZE(op_sm_set_qs, 1) DO ispin = 1, nspins CALL dbcsr_create(m_B0(reim, idim0, ispin), & template=m_theta(ispin), & @@ -2010,6 +2158,8 @@ CONTAINS ! penalty amplitude adjusts the strenght of volume conservation penalty_amplitude = optimizer%opt_penalty%penalty_strength + !penalty_occ_vol = ( optimizer%opt_penalty%occ_vol_method /= penalty_type_none ) + !penalty_local = ( optimizer%opt_penalty%occ_loc_method /= penalty_type_none ) ! preconditioner control prec_type = optimizer%preconditioner @@ -2303,6 +2453,7 @@ CONTAINS DO ispin = 1, nspins CALL compute_obj_nlmos( & + !obj_function_ispin=obj_function_ispin, & localization_obj_function_ispin=localization_obj_function_ispin, & penalty_func_ispin=penalty_func_ispin, & overlap_determinant=overlap_determinant, & @@ -2479,6 +2630,30 @@ CONTAINS ! TODO: write preconditioner code later ! For now, create matrix filled with 1.0 here CALL fill_matrix_with_ones(approx_inv_hessian(ispin)) + !CALL compute_preconditioner(& + ! m_prec_out=approx_hessian(ispin),& + ! m_ks=almo_scf_env%matrix_ks(ispin),& + ! m_s=matrix_s,& + ! m_siginv=almo_scf_env%template_matrix_sigma(ispin),& + ! m_quench_t=quench_t(ispin),& + ! m_FTsiginv=FTsiginv(ispin),& + ! m_siginvTFTsiginv=siginvTFTsiginv(ispin),& + ! m_ST=ST(ispin),& + ! para_env=almo_scf_env%para_env,& + ! blacs_env=almo_scf_env%blacs_env,& + ! nocc_of_domain=almo_scf_env%nocc_of_domain(:,ispin),& + ! domain_s_inv=almo_scf_env%domain_s_inv(:,ispin),& + ! domain_r_down=domain_r_down(:,ispin),& + ! cpu_of_domain=almo_scf_env%cpu_of_domain,& + ! domain_map=almo_scf_env%domain_map(ispin),& + ! assume_t0_q0x=assume_t0_q0x,& + ! penalty_occ_vol=penalty_occ_vol,& + ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin),& + ! eps_filter=eps_filter,& + ! neg_thr=0.5_dp,& + ! spin_factor=spin_factor,& + ! special_case=my_special_case) + !CALL invert hessian END DO ! ispin END IF @@ -2637,14 +2812,18 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,7F12.5)') & + ! "DT", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der + !ENDIF step_size = -g1/appr_sec_der ELSE IF (linear_search_type == 2) THEN ! alternative method for finding step size ! do not use quadratic approximation, only gradient signs IF (g1sign /= g0sign) THEN - step_size = -step_size/2.0 + step_size = -step_size/2.0; ELSE - step_size = step_size*1.5 + step_size = step_size*1.5; END IF END IF ! end alternative LS types @@ -3247,6 +3426,7 @@ CONTAINS proj_in_template=almo_scf_env%matrix_ov(ispin), & eps_filter=almo_scf_env%eps_filter, & sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin)) + !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),& ! save initial retained virtuals CALL dbcsr_create(vr_fixed, & @@ -3279,6 +3459,17 @@ CONTAINS ! project retained virtuals out of discarded block-by-block ! (1-Q^VR_ALMO)|ALMO_vd> ! this is probably not necessary, do it just to be safe + !CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin),& + ! psi_out=almo_scf_env%matrix_v_disc(ispin),& + ! psi_projector=almo_scf_env%matrix_v_blk(ispin),& + ! metric=almo_scf_env%matrix_s_blk(1),& + ! project_out=.TRUE.,& + ! psi_projector_orthogonal=.FALSE.,& + ! proj_in_template=almo_scf_env%matrix_k_tr(ispin),& + ! eps_filter=almo_scf_env%eps_filter,& + ! sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin)) + !CALL dbcsr_copy(almo_scf_env%matrix_v_disc_blk(ispin),& + ! almo_scf_env%matrix_v_disc(ispin)) ! construct discarded virtuals (1-R)|ALMO_vd> CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin), & @@ -3301,11 +3492,57 @@ CONTAINS CALL dbcsr_create(k_vr_index_down, & template=almo_scf_env%matrix_sigma_vv_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_copy(k_vr_index_down,& + ! almo_scf_env%matrix_sigma_vv_blk(ispin)) + + !CALL get_overlap(bra=almo_scf_env%matrix_v_blk(ispin),& + ! ket=almo_scf_env%matrix_v_blk(ispin),& + ! overlap=k_vr_index_down,& + ! metric=almo_scf_env%matrix_s_blk(1),& + ! retain_overlap_sparsity=.FALSE.,& + ! eps_filter=almo_scf_env%eps_filter) !! create the up metric in the discarded k-subspace CALL dbcsr_create(k_vd_index_down, & template=almo_scf_env%matrix_vv_disc_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_init(k_vd_index_up) + !CALL dbcsr_create(k_vd_index_up,& + ! template=almo_scf_env%matrix_vv_disc_blk(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_copy(k_vd_index_down,& + ! almo_scf_env%matrix_vv_disc_blk(ispin)) + + !CALL get_overlap(bra=almo_scf_env%matrix_v_disc_blk(ispin),& + ! ket=almo_scf_env%matrix_v_disc_blk(ispin),& + ! overlap=k_vd_index_down,& + ! metric=almo_scf_env%matrix_s_blk(1),& + ! retain_overlap_sparsity=.FALSE.,& + ! eps_filter=almo_scf_env%eps_filter) + + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "Inverting blocked overlap matrix of discarded virtuals" + !ENDIF + !CALL invert_Hotelling(k_vd_index_up,& + ! k_vd_index_down,& + ! almo_scf_env%eps_filter) + !IF (safe_mode) THEN + ! CALL dbcsr_init(matrix_tmp1) + ! CALL dbcsr_create(matrix_tmp1,template=k_vd_index_down,& + ! matrix_type=dbcsr_type_no_symmetry) + ! CALL dbcsr_multiply("N","N",1.0_dp,k_vd_index_up,& + ! k_vd_index_down,& + ! 0.0_dp, matrix_tmp1,& + ! filter_eps=almo_scf_env%eps_filter) + ! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp1) + ! CALL dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) + ! frob_matrix=dbcsr_frobenius_norm(matrix_tmp1) + ! IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "Error for (inv(SIG)*SIG-I)",& + ! frob_matrix/frob_matrix_base + ! ENDIF + ! CALL dbcsr_release(matrix_tmp1) + !ENDIF ! init matrices necessary for optimization of truncated virts ! init blocked gradient before setting K to zero @@ -3369,6 +3606,15 @@ CONTAINS template=almo_scf_env%matrix_k_blk(ispin)) CALL dbcsr_set(prev_grad, 0.0_dp) + !CALL dbcsr_init(sigma_oo_guess) + !CALL dbcsr_create(sigma_oo_guess,& + ! template=almo_scf_env%matrix_sigma(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_set(sigma_oo_guess,0.0_dp) + !CALL dbcsr_add_on_diag(sigma_oo_guess,1.0_dp) + !CALL dbcsr_filter(sigma_oo_guess,almo_scf_env%eps_filter) + !CALL dbcsr_print(sigma_oo_guess) + END IF ! done constructing discarded virtuals ! init variables @@ -3406,6 +3652,9 @@ CONTAINS END IF ! decompose the overlap matrix of the current retained orbitals + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "decompose the active VV overlap matrix" + !ENDIF CALL get_overlap(bra=almo_scf_env%matrix_v(ispin), & ket=almo_scf_env%matrix_v(ispin), & overlap=almo_scf_env%matrix_sigma_vv(ispin), & @@ -3478,6 +3727,8 @@ CONTAINS CALL matrix_sqrt_Newton_Schulz(sigma_vv_sqrt, & sigma_vv_sqrt_inv, & almo_scf_env%matrix_sigma_vv(ispin), & + !matrix_sqrt_inv_guess=sigma_vv_sqrt_inv_guess,& + !matrix_sqrt_guess=sigma_vv_sqrt_guess,& threshold=almo_scf_env%eps_filter, & order=almo_scf_env%order_lanczos, & eps_lanczos=almo_scf_env%eps_lanczos, & @@ -3577,6 +3828,9 @@ CONTAINS +1.0_dp, +1.0_dp) ! calculate current occupied overlap + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "Inverting current occ overlap matrix" + !ENDIF CALL get_overlap(bra=t_curr, & ket=t_curr, & overlap=sigma_oo_curr, & @@ -3593,6 +3847,7 @@ CONTAINS sigma_oo_curr, & threshold=almo_scf_env%eps_filter, & use_inv_as_guess=.TRUE.) + !CALL dbcsr_copy(sigma_oo_guess,sigma_oo_curr_inv) END IF IF (safe_mode) THEN CALL dbcsr_create(matrix_tmp1, template=sigma_oo_curr, & @@ -3604,6 +3859,8 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) + !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) + !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (SIG*inv(SIG)-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3620,6 +3877,8 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) + !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) + !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (inv(SIG)*SIG-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3682,6 +3941,7 @@ CONTAINS tmp1_n_vr, & 0.0_dp, grad, & retain_sparsity=.TRUE.) + !filter_eps=almo_scf_env%eps_filter,& ! keep tmp2_n_o for the next step ! keep tmp4_o_vr for the preconditioner @@ -3731,6 +3991,21 @@ CONTAINS IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Computing preconditioner" END IF + !CALL opt_k_create_preconditioner(prec,& + ! almo_scf_env%matrix_v_disc(ispin),& + ! almo_scf_env%matrix_ks_0deloc(ispin),& + ! almo_scf_env%matrix_x(ispin),& + ! tmp4_o_vr,& + ! almo_scf_env%matrix_s(1),& + ! grad,& + ! !almo_scf_env%matrix_v_disc_blk(ispin),& + ! vd_fixed,& + ! t_curr,& + ! k_vd_index_up,& + ! k_vr_index_down,& + ! tmp1_n_vr,& + ! spin_factor,& + ! almo_scf_env%eps_filter) CALL opt_k_create_preconditioner_blk(almo_scf_env, & almo_scf_env%matrix_v_disc(ispin), & tmp4_o_vr, & @@ -3746,6 +4021,7 @@ CONTAINS ! compute the new step CALL opt_k_apply_preconditioner_blk(almo_scf_env, & step, grad, ispin) + !CALL dbcsr_hadamard_product(prec,grad,step) CALL dbcsr_scale(step, -1.0_dp) ! check whether we need to reset conjugate directions @@ -3760,6 +4036,9 @@ CONTAINS ELSE ! check for the errors in the cg algorithm + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) CALL dbcsr_dot(grad, prev_minus_prec_grad, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) conjugacy_error = numer/denom @@ -3797,32 +4076,63 @@ CONTAINS CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_fletcher_reeves) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) + !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) beta = numer/denom CASE (cg_polak_ribiere) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_fletcher) + !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !CALL dbcsr_dot(prev_grad,prev_step,denom) + !beta=-1.0_dp*numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_step, denom) beta = numer/denom CASE (cg_liu_storey) CALL dbcsr_dot(prev_grad, prev_step, denom) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_dai_yuan) + !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_dot(prev_grad,prev_step,denom) + !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_hager_zhang) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_dot(prev_grad,prev_step,denom) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(tmp_k_blk,prev_grad,numer) + !kappa=2.0_dp*numer/denom + !CALL dbcsr_dot(tmp_k_blk,grad,numer) + !tau=numer/denom + !CALL dbcsr_dot(prev_step,grad,numer) + !beta=tau-kappa*numer/denom CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) @@ -3854,6 +4164,7 @@ CONTAINS IF (reset_conjugator) THEN beta = 0.0_dp + !reset_step_size=.TRUE. IF (unit_nr > 0) THEN WRITE (unit_nr, *) "(Re)-setting conjugator to zero" @@ -4079,11 +4390,13 @@ CONTAINS "K iter CG", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun0, line_search_error, beta, conjugacy_error, t2a - t1a + !(flop1+flop2)/(1.0E6_dp*(t2-t1)) ELSE WRITE (unit_nr, '(T6,A,1X,I3,1X,E12.3,F16.10,F16.10,E12.3,E12.3,E12.3,F8.3,F8.3,F10.3)') & "K iter LS", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun1, line_search_error, beta, conjugacy_error, t2a - t1a + !(flop1+flop2)/(1.0E6_dp*(t2-t1)) END IF END IF CALL m_flush(unit_nr) @@ -4240,6 +4553,7 @@ CONTAINS IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CALL dbcsr_release(k_vr_index_down) CALL dbcsr_release(k_vd_index_down) + !CALL dbcsr_release(k_vd_index_up) CALL dbcsr_release(matrix_k_central) CALL dbcsr_release(vr_fixed) CALL dbcsr_release(vd_fixed) @@ -4364,6 +4678,8 @@ CONTAINS ! just get the energy correction CALL ct_step_env_get(ct_step_env, & energy_correction=energy_correction(ispin)) + !copy_da_energy_matrix=matrix_eda(ispin),& + !copy_da_charge_matrix=matrix_cta(ispin),& CALL ct_step_env_clean(ct_step_env) @@ -4384,6 +4700,18 @@ CONTAINS END IF energy_correction_final = energy_correction_final + energy_correction(ispin) + !!! print out the results of decomposition analysis + !!IF (unit_nr>0) THEN + !! WRITE(unit_nr,*) + !! WRITE(unit_nr,'(T2,A)') "ENERGY DECOMPOSITION" + !!ENDIF + !!CALL print_block_sum(eda_matrix(ispin), unit_nr=6) + !!IF (unit_nr>0) THEN + !! WRITE(unit_nr,*) + !! WRITE(unit_nr,'(T2,A)') "CHARGE DECOMPOSITION" + !!ENDIF + !!CALL print_block_sum(cta_matrix(ispin), unit_nr=6) + ! obtain density matrix from updated MOs ! RZK-later sigma and sigma_inv are lost here CALL almo_scf_t_to_proj(t=almo_scf_env%matrix_t(ispin), & @@ -4403,10 +4731,9 @@ CONTAINS para_env=almo_scf_env%para_env, & blacs_env=almo_scf_env%blacs_env) - IF (almo_scf_env%nspins == 1) THEN + IF (almo_scf_env%nspins == 1) & CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) - END IF END DO @@ -4452,6 +4779,17 @@ CONTAINS END IF + DO ispin = 1, nspin + ! RZK-warning the preconditioner is very important + ! IF (.FALSE.) THEN + ! CALL apply_matrix_preconditioner(almo_scf_env%matrix_ks(ispin),& + ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& + ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) + ! ENDIF + !CALL dbcsr_filter(almo_scf_env%matrix_ks(ispin),& + ! almo_scf_env%eps_filter) + END DO + ALLOCATE (matrix_p_almo_scf_converged(nspin)) DO ispin = 1, nspin CALL dbcsr_create(matrix_p_almo_scf_converged(ispin), & @@ -4464,19 +4802,50 @@ CONTAINS DO ispin = 1, nspin nelectron_spin_real(1) = almo_scf_env%nelectrons_spin(ispin) - IF (almo_scf_env%nspins == 1) THEN + IF (almo_scf_env%nspins == 1) & nelectron_spin_real(1) = nelectron_spin_real(1)/2 - END IF local_mu(1) = SUM(almo_scf_env%mu_of_domain(:, ispin))/almo_scf_env%ndomains fake(1) = 123523 + ! RZK UPDATE! the update algorithm is removed because + ! RZK UPDATE! it requires updating core LS_SCF routines + ! RZK UPDATE! (the code exists in the CVS version) CPABORT("CVS only: density_matrix_sign has not been updated in SVN") + ! RZK UPDATE!CALL density_matrix_sign(almo_scf_env%matrix_p(ispin),& + ! RZK UPDATE! local_mu,& + ! RZK UPDATE! almo_scf_env%fixed_mu,& + ! RZK UPDATE! almo_scf_env%matrix_ks_0deloc(ispin),& + ! RZK UPDATE! almo_scf_env%matrix_s(1), & + ! RZK UPDATE! almo_scf_env%matrix_s_inv(1), & + ! RZK UPDATE! nelectron_spin_real,& + ! RZK UPDATE! almo_scf_env%eps_filter,& + ! RZK UPDATE! fake) + ! RZK UPDATE! + almo_scf_env%mu = local_mu(1) - IF (almo_scf_env%nspins == 1) THEN + !IF (almo_scf_env%has_s_preconditioner) THEN + ! CALL apply_matrix_preconditioner(& + ! almo_scf_env%matrix_p_blk(ispin),& + ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& + ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) + !ENDIF + !CALL dbcsr_filter(almo_scf_env%matrix_p(ispin),& + ! almo_scf_env%eps_filter) + + IF (almo_scf_env%nspins == 1) & CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) - END IF + + !CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin),& + ! almo_scf_env%matrix_p(ispin),& + ! energy_correction(ispin)) + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) + ! WRITE(unit_nr,'(T2,A,I6,F20.9)') "EFAKE",ispin,& + ! energy_correction(ispin) + ! WRITE(unit_nr,*) + !ENDIF CALL dbcsr_add(matrix_p_almo_scf_converged(ispin), & almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp) CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin), & @@ -4589,6 +4958,13 @@ CONTAINS tmp1_n_vr, tmp2_n_vr, tmp_n_vd, & tmp_vd_vd_blk, tmp_vr_vr_blk +! init diag blocks outside +! init diag blocks otside +!INTEGER :: iblock_row, iblock_col,& +! nblkrows_tot, nblkcols_tot +!REAL(KIND=dp), DIMENSION(:, :), POINTER :: p_new_block +!INTEGER :: mynode, hold, row, col + CALL timeset(routineN, handle) ! initialize a matrix to 1.0 @@ -4986,6 +5362,562 @@ CONTAINS END SUBROUTINE opt_k_apply_preconditioner_blk +!! ************************************************************************************************** +!!> \brief Reduce the number of virtual orbitals by rotating them within +!!> a domain. The rotation is such that minimizes the frobenius norm of +!!> the Fov domain-blocks of the discarded virtuals +!!> \par History +!!> 2011.08 created [Rustam Z Khaliullin] +!!> \author Rustam Z Khaliullin +!! ************************************************************************************************** +! SUBROUTINE truncate_subspace_v_blk(qs_env,almo_scf_env) +! +! TYPE(qs_environment_type), POINTER :: qs_env +! TYPE(almo_scf_env_type) :: almo_scf_env +! +! CHARACTER(len=*), PARAMETER :: routineN = 'truncate_subspace_v_blk', & +! routineP = moduleN//':'//routineN +! +! INTEGER :: handle, ispin, iblock_row, & +! iblock_col, iblock_row_size, & +! iblock_col_size, retained_v, & +! iteration, line_search_step, & +! unit_nr, line_search_step_last +! REAL(KIND=dp) :: t1, obj_function, grad_norm,& +! c0, b0, a0, obj_function_new,& +! t2, alpha, ff1, ff2, step1,& +! step2,& +! frob_matrix_base,& +! frob_matrix +! LOGICAL :: safe_mode, converged, & +! prepare_to_exit, failure +! TYPE(cp_logger_type), POINTER :: logger +! TYPE(dbcsr_type) :: Fon, Fov, Fov_filtered, & +! temp1_oo, temp2_oo, Fov_original, & +! temp0_ov, U_blk_tot, U_blk, & +! grad_blk, step_blk, matrix_filter, & +! v_full_new,v_full_tmp,& +! matrix_sigma_vv_full,& +! matrix_sigma_vv_full_sqrt,& +! matrix_sigma_vv_full_sqrt_inv,& +! matrix_tmp1,& +! matrix_tmp2 +! +! REAL(kind=dp), DIMENSION(:, :), POINTER :: data_p, p_new_block +! TYPE(dbcsr_iterator_type) :: iter +! +! +!REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: eigenvalues, WORK +!REAL(kind=dp), DIMENSION(:,:), ALLOCATABLE :: data_copy, left_vectors, right_vectors +!INTEGER :: LWORK, INFO +!TYPE(dbcsr_type) :: temp_u_v_full_blk +! +! CALL timeset(routineN,handle) +! +! safe_mode=.TRUE. +! +! ! get a useful output_unit +! logger => cp_get_default_logger() +! IF (logger%para_env%is_source()) THEN +! unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) +! ELSE +! unit_nr=-1 +! ENDIF +! +! DO ispin=1,almo_scf_env%nspins +! +! t1 = m_walltime() +! +! !!!!!!!!!!!!!!!!! +! ! 0. Orthogonalize virtuals +! ! Unfortunately, we have to do it in the FULL V subspace :( +! +! CALL dbcsr_init(v_full_new) +! CALL dbcsr_create(v_full_new,& +! template=almo_scf_env%matrix_v_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! project the occupied subspace out +! CALL almo_scf_p_out_from_v(almo_scf_env%matrix_v_full_blk(ispin),& +! v_full_new,almo_scf_env%matrix_ov_full(ispin),& +! ispin,almo_scf_env) +! +! ! init overlap and its functions +! CALL dbcsr_init(matrix_sigma_vv_full) +! CALL dbcsr_init(matrix_sigma_vv_full_sqrt) +! CALL dbcsr_init(matrix_sigma_vv_full_sqrt_inv) +! CALL dbcsr_create(matrix_sigma_vv_full,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_create(matrix_sigma_vv_full_sqrt,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_create(matrix_sigma_vv_full_sqrt_inv,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! construct VV overlap +! CALL almo_scf_mo_to_sigma(v_full_new,& +! matrix_sigma_vv_full,& +! almo_scf_env%matrix_s(1),& +! almo_scf_env%eps_filter) +! +! IF (unit_nr>0) THEN +! WRITE(unit_nr,*) "sqrt and inv(sqrt) of the FULL virtual MO overlap" +! ENDIF +! +! ! construct orthogonalization matrices +! CALL matrix_sqrt_Newton_Schulz(matrix_sigma_vv_full_sqrt,& +! matrix_sigma_vv_full_sqrt_inv,& +! matrix_sigma_vv_full,& +! threshold=almo_scf_env%eps_filter,& +! order=almo_scf_env%order_lanczos,& +! eps_lanczos=almo_scf_env%eps_lanczos,& +! max_iter_lanczos=almo_scf_env%max_iter_lanczos) +! IF (safe_mode) THEN +! CALL dbcsr_init(matrix_tmp1) +! CALL dbcsr_create(matrix_tmp1,template=matrix_sigma_vv_full,& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_init(matrix_tmp2) +! CALL dbcsr_create(matrix_tmp2,template=matrix_sigma_vv_full,& +! matrix_type=dbcsr_type_no_symmetry) +! +! CALL dbcsr_multiply("N","N",1.0_dp,matrix_sigma_vv_full_sqrt_inv,& +! matrix_sigma_vv_full,& +! 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& +! matrix_sigma_vv_full_sqrt_inv,& +! 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) +! +! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp2) +! CALL dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) +! frob_matrix=dbcsr_frobenius_norm(matrix_tmp2) +! IF (unit_nr>0) THEN +! WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",frob_matrix/frob_matrix_base +! ENDIF +! +! CALL dbcsr_release(matrix_tmp1) +! CALL dbcsr_release(matrix_tmp2) +! ENDIF +! +! ! discard unnecessary overlap functions +! CALL dbcsr_release(matrix_sigma_vv_full) +! CALL dbcsr_release(matrix_sigma_vv_full_sqrt) +! +!! this can be re-written because we have (1-P)|v> +! +! !!!!!!!!!!!!!!!!!!! +! ! 1. Compute F_ov +! CALL dbcsr_init(Fon) +! CALL dbcsr_create(Fon,& +! template=almo_scf_env%matrix_v_full_blk(ispin)) +! CALL dbcsr_init(Fov) +! CALL dbcsr_create(Fov,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! CALL dbcsr_init(Fov_filtered) +! CALL dbcsr_create(Fov_filtered,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! CALL dbcsr_init(temp1_oo) +! CALL dbcsr_create(temp1_oo,& +! template=almo_scf_env%matrix_sigma(ispin),& +! !matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_init(temp2_oo) +! CALL dbcsr_create(temp2_oo,& +! template=almo_scf_env%matrix_sigma(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& +! almo_scf_env%matrix_ks_0deloc(ispin),& +! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& +! almo_scf_env%matrix_v_full_blk(ispin),& +! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& +! almo_scf_env%matrix_t_blk(ispin),& +! 0.0_dp,temp1_oo,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,temp1_oo,& +! almo_scf_env%matrix_sigma_inv(ispin),& +! 0.0_dp,temp2_oo,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_release(temp1_oo) +! +! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& +! almo_scf_env%matrix_s(1),& +! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& +! almo_scf_env%matrix_v_full_blk(ispin),& +! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_release(Fon) +! +! CALL dbcsr_multiply("N","N",-1.0_dp,temp2_oo,& +! Fov_filtered,& +! 1.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_release(temp2_oo) +! +! CALL dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_sigma_inv(ispin),& +! Fov,0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fov_filtered,& +! matrix_sigma_vv_full_sqrt_inv,& +! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! !CALL dbcsr_copy(Fov,Fov_filtered) +!CALL dbcsr_print(Fov) +! +! IF (safe_mode) THEN +! CALL dbcsr_init(Fov_original) +! CALL dbcsr_create(Fov_original,template=Fov) +! CALL dbcsr_copy(Fov_original,Fov) +! ENDIF +! +!!! remove diagonal blocks +!!CALL dbcsr_iterator_start(iter,Fov) +!!DO WHILE (dbcsr_iterator_blocks_left(iter)) +!! +!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +!! row_size=iblock_row_size,col_size=iblock_col_size) +!! +!! IF (iblock_row.eq.iblock_col) data_p(:,:)=0.0_dp +!! +!!ENDDO +!!CALL dbcsr_iterator_stop(iter) +!!CALL dbcsr_finalize(Fov) +! +!!! perform svd of blocks +!!!!! THIS ROUTINE WORKS ONLY ON ONE CPU AND ONLY FOR 2 MOLECULES !!! +!!CALL dbcsr_init(temp_u_v_full_blk) +!!CALL dbcsr_create(temp_u_v_full_blk,& +!! template=almo_scf_env%matrix_vv_full_blk(ispin),& +!! matrix_type=dbcsr_type_no_symmetry) +!! +!!CALL dbcsr_work_create(temp_u_v_full_blk,& +!! work_mutable=.TRUE.) +!!CALL dbcsr_iterator_start(iter,Fov) +!!DO WHILE (dbcsr_iterator_blocks_left(iter)) +!! +!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +!! row_size=iblock_row_size,col_size=iblock_col_size) +!! +!! IF (iblock_row.ne.iblock_col) THEN +!! +!! ! Prepare data +!! allocate(eigenvalues(min(iblock_row_size,iblock_col_size))) +!! allocate(data_copy(iblock_row_size,iblock_col_size)) +!! allocate(left_vectors(iblock_row_size,iblock_row_size)) +!! allocate(right_vectors(iblock_col_size,iblock_col_size)) +!! data_copy(:,:)=data_p(:,:) +!! +!! ! Query the optimal workspace for dgesvd +!! LWORK = -1 +!! allocate(WORK(MAX(1,LWORK))) +!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& +!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& +!! right_vectors,iblock_col_size,WORK,LWORK,INFO) +!! LWORK = INT(WORK( 1 )) +!! deallocate(WORK) +!! +!! ! Allocate the workspace and perform svd +!! allocate(WORK(MAX(1,LWORK))) +!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& +!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& +!! right_vectors,iblock_col_size,WORK,LWORK,INFO) +!! deallocate(WORK) +!! IF( INFO/=0 ) THEN +!! CPABORT("DGESVD failed") +!! END IF +!! +!! ! copy right singular vectors into a unitary matrix +!! CALL dbcsr_put_block(temp_u_v_full_blk,iblock_col,iblock_col,right_vectors) +!! +!! deallocate(eigenvalues) +!! deallocate(data_copy) +!! deallocate(left_vectors) +!! deallocate(right_vectors) +!! +!! ENDIF +!!ENDDO +!!CALL dbcsr_iterator_stop(iter) +!!CALL dbcsr_finalize(temp_u_v_full_blk) +!!!CALL dbcsr_print(temp_u_v_full_blk) +!!CALL dbcsr_multiply("N","T",1.0_dp,Fov,temp_u_v_full_blk,& +!! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +!! +!!CALL dbcsr_copy(Fov,Fov_filtered) +!!CALL dbcsr_print(Fov) +! +! !!!!!!!!!!!!!!!!!!! +! ! 2. Initialize variables +! +! ! temp space +! CALL dbcsr_init(temp0_ov) +! CALL dbcsr_create(temp0_ov,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! +! ! current unitary matrix +! CALL dbcsr_init(U_blk) +! CALL dbcsr_create(U_blk,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! unitary matrix accumulator +! CALL dbcsr_init(U_blk_tot) +! CALL dbcsr_create(U_blk_tot,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_add_on_diag(U_blk_tot,1.0_dp) +! +!!CALL dbcsr_add_on_diag(U_blk,1.0_dp) +!!CALL dbcsr_multiply("N","T",1.0_dp,U_blk,temp_u_v_full_blk,& +!! 0.0_dp,U_blk_tot,filter_eps=almo_scf_env%eps_filter) +!! +!!CALL dbcsr_release(temp_u_v_full_blk) +! +! ! init gradient +! CALL dbcsr_init(grad_blk) +! CALL dbcsr_create(grad_blk,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! init step matrix +! CALL dbcsr_init(step_blk) +! CALL dbcsr_create(step_blk,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! "retain discarded" filter (0.0 - retain, 1.0 - discard) +! CALL dbcsr_init(matrix_filter) +! CALL dbcsr_create(matrix_filter,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! ! copy Fov into the filter matrix temporarily +! ! so we know which blocks contain significant elements +! CALL dbcsr_copy(matrix_filter,Fov) +! +! ! fill out filter elements block-by-block +! CALL dbcsr_iterator_start(iter,matrix_filter) +! DO WHILE (dbcsr_iterator_blocks_left(iter)) +! +! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +! row_size=iblock_row_size,col_size=iblock_col_size) +! +! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) +! +! data_p(:,1:retained_v)=0.0_dp +! data_p(:,(retained_v+1):iblock_col_size)=1.0_dp +! +! ENDDO +! CALL dbcsr_iterator_stop(iter) +! CALL dbcsr_finalize(matrix_filter) +! +! ! apply the filter +! CALL dbcsr_hadamard_product(Fov,matrix_filter,Fov_filtered) +! +! !!!!!!!!!!!!!!!!!!!!! +! ! 3. start iterative minimization of the elements to be discarded +! iteration=0 +! converged=.FALSE. +! prepare_to_exit=.FALSE. +! DO +! +! iteration=iteration+1 +! +! !!!!!!!!!!!!!!!!!!!!!!!!! +! ! 4. compute the gradient +! CALL dbcsr_set(grad_blk,0.0_dp) +! ! create the diagonal blocks only +! CALL dbcsr_add_on_diag(grad_blk,1.0_dp) +! +! CALL dbcsr_multiply("T","N",2.0_dp,Fov_filtered,Fov,& +! 0.0_dp,grad_blk,retain_sparsity=.TRUE.,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_multiply("T","N",-2.0_dp,Fov,Fov_filtered,& +! 1.0_dp,grad_blk,retain_sparsity=.TRUE.,& +! filter_eps=almo_scf_env%eps_filter) +! +! !!!!!!!!!!!!!!!!!!!!!!! +! ! 5. check convergence +! obj_function = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 +! grad_norm = dbcsr_frobenius_norm(grad_blk) +! converged=(grad_norm.lt.almo_scf_env%truncate_v_eps_convergence) +! IF (converged.OR.(iteration.ge.almo_scf_env%truncate_v_max_iter)) THEN +! prepare_to_exit=.TRUE. +! ENDIF +! +! IF (.NOT.prepare_to_exit) THEN +! +! !!!!!!!!!!!!!!!!!!!!!!! +! ! 6. perform steps in the direction of the gradient +! ! a. first, perform a trial step to "see" the parameters +! ! of the parabola along the gradient: +! ! a0 * x^2 + b0 * x + c0 +! ! b. then perform the step to the bottom of the parabola +! +! ! get c0 +! c0 = obj_function +! ! get b0 <= d_f/d_alpha along grad +! !!!CALL dbcsr_multiply("N","N",4.0_dp,Fov,grad_blk,& +! !!! 0.0_dp,temp0_ov,& +! !!! filter_eps=almo_scf_env%eps_filter) +! !!!CALL dbcsr_dot(Fov_filtered,temp0_ov,b0) +! +! alpha=almo_scf_env%truncate_v_trial_step_size +! +! line_search_step_last=3 +! DO line_search_step=1,line_search_step_last +! CALL dbcsr_copy(step_blk,grad_blk) +! CALL dbcsr_scale(step_blk,-1.0_dp*alpha) +! CALL generator_to_unitary(step_blk,U_blk,& +! almo_scf_env%eps_filter) +! CALL dbcsr_multiply("N","N",1.0_dp,Fov,U_blk,0.0_dp,temp0_ov,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& +! Fov_filtered) +! +! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 +! IF (line_search_step.eq.1) THEN +! ff1 = obj_function_new +! step1 = alpha +! ELSE IF (line_search_step.eq.2) THEN +! ff2 = obj_function_new +! step2 = alpha +! ENDIF +! +! IF (unit_nr>0.AND.(line_search_step.ne.line_search_step_last)) THEN +! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3)') & +! "JOINT_SVD_lin",& +! iteration,& +! alpha,& +! obj_function,& +! obj_function_new,& +! obj_function_new-obj_function +! ENDIF +! +! IF (line_search_step.eq.1) THEN +! alpha=2.0_dp*alpha +! ENDIF +! IF (line_search_step.eq.2) THEN +! a0 = ((ff1-c0)/step1 - (ff2-c0)/step2) / (step1 - step2) +! b0 = (ff1-c0)/step1 - a0*step1 +! ! step size in to the bottom of "the parabola" +! alpha=-b0/(2.0_dp*a0) +! ! update the default step size +! almo_scf_env%truncate_v_trial_step_size=alpha +! ENDIF +! !!!IF (line_search_step.eq.1) THEN +! !!! a0 = (obj_function_new - b0 * alpha - c0) / (alpha*alpha) +! !!! ! step size in to the bottom of "the parabola" +! !!! alpha=-b0/(2.0_dp*a0) +! !!! !IF (alpha.gt.10.0_dp) alpha=10.0_dp +! !!!ENDIF +! +! ENDDO +! +! ! update Fov and U_blk_tot (use grad_blk as tmp storage) +! CALL dbcsr_copy(Fov,temp0_ov) +! CALL dbcsr_multiply("N","N",1.0_dp,U_blk_tot,U_blk,& +! 0.0_dp,grad_blk,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_copy(U_blk_tot,grad_blk) +! +! ENDIF +! +! t2 = m_walltime() +! +! IF (unit_nr>0) THEN +! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3,E12.3,F10.3)') & +! "JOINT_SVD_itr",& +! iteration,& +! alpha,& +! obj_function,& +! obj_function_new,& +! obj_function_new-obj_function,& +! grad_norm,& +! t2-t1 +! !(flop1+flop2)/(1.0E6_dp*(t2-t1)) +! CALL m_flush(unit_nr) +! ENDIF +! +! t1 = m_walltime() +! +! IF (prepare_to_exit) EXIT +! +! ENDDO ! stop iterations +! +! IF (safe_mode) THEN +! CALL dbcsr_multiply("N","N",1.0_dp,Fov_original,& +! U_blk_tot,0.0_dp,temp0_ov,& +! filter_eps=almo_scf_env%eps_filter) +!CALL dbcsr_print(temp0_ov) +! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& +! Fov_filtered) +! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 +! +! IF (unit_nr>0) THEN +! WRITE(unit_nr,'(T6,A,1X,E12.3)') & +! "SANITY CHECK:",& +! obj_function_new +! CALL m_flush(unit_nr) +! ENDIF +! +! CALL dbcsr_release(Fov_original) +! ENDIF +! +! CALL dbcsr_release(temp0_ov) +! CALL dbcsr_release(U_blk) +! CALL dbcsr_release(grad_blk) +! CALL dbcsr_release(step_blk) +! CALL dbcsr_release(matrix_filter) +! CALL dbcsr_release(Fov) +! CALL dbcsr_release(Fov_filtered) +! +! ! compute rotated virtual orbitals +! CALL dbcsr_init(v_full_tmp) +! CALL dbcsr_create(v_full_tmp,& +! template=almo_scf_env%matrix_v_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! v_full_new,& +! matrix_sigma_vv_full_sqrt_inv,0.0_dp,v_full_tmp,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! v_full_tmp,& +! U_blk_tot,0.0_dp,v_full_new,& +! filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_release(matrix_sigma_vv_full_sqrt_inv) +! CALL dbcsr_release(v_full_tmp) +! CALL dbcsr_release(U_blk_tot) +! +!!!!! orthogonalized virtuals are not blocked +! ! copy new virtuals into the truncated matrix +! !CALL dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin),& +! CALL dbcsr_work_create(almo_scf_env%matrix_v(ispin),& +! work_mutable=.TRUE.) +! CALL dbcsr_iterator_start(iter,v_full_new) +! DO WHILE (dbcsr_iterator_blocks_left(iter)) +! +! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +! row_size=iblock_row_size,col_size=iblock_col_size) +! +! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) +! +! CALL dbcsr_put_block(almo_scf_env%matrix_v(ispin), iblock_row,iblock_col,data_p(:,1:retained_v)) +! CPASSERT(retained_v.gt.0) +! +! ENDDO ! iterator +! CALL dbcsr_iterator_stop(iter) +! !!CALL dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin)) +! CALL dbcsr_finalize(almo_scf_env%matrix_v(ispin)) +! +! CALL dbcsr_release(v_full_new) +! +! ENDDO ! ispin +! +! CALL timestop(handle) +! +! END SUBROUTINE truncate_subspace_v_blk + ! ************************************************************************************************** !> \brief Compute the gradient wrt the main variable (e.g. Theta, X) !> \param m_grad_out ... @@ -5117,9 +6049,44 @@ CONTAINS template=m_t, & matrix_type=dbcsr_type_no_symmetry) + ! do d_E/d_T first + !IF (.NOT.PRESENT(m_FTsiginv)) THEN + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_ks,& + ! m_t,& + ! 0.0_dp,m_tmp_no_1,& + ! filter_eps=eps_filter) + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_tmp_no_1,& + ! m_siginv,& + ! 0.0_dp,m_FTsiginv,& + ! filter_eps=eps_filter) + !ENDIF + CALL dbcsr_copy(m_tmp_no_2, m_quench_t) CALL dbcsr_copy(m_tmp_no_2, m_FTsiginv, keep_sparsity=.TRUE.) + !IF (.NOT.PRESENT(m_siginvTFTsiginv)) THEN + ! CALL dbcsr_multiply("T","N",1.0_dp,& + ! m_t,& + ! m_FTsiginv,& + ! 0.0_dp,m_tmp_oo_1,& + ! filter_eps=eps_filter) + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_siginv,& + ! m_tmp_oo_1,& + ! 0.0_dp,m_siginvTFTsiginv,& + ! filter_eps=eps_filter) + !ENDIF + + !IF (.NOT.PRESENT(m_ST)) THEN + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_s,& + ! m_t,& + ! 0.0_dp,m_ST,& + ! filter_eps=eps_filter) + !ENDIF + CALL dbcsr_multiply("N", "N", -1.0_dp, & m_ST, & m_siginvTFTsiginv, & @@ -5167,12 +6134,15 @@ CONTAINS SELECT CASE (2) ! allows for selection of different spread functionals CASE (1) ! functional = -W_I * log( |z_I|^2 ) CPABORT("Localization function is not implemented") + !coeff = -(weights(idim0)/z2(ielem)) CASE (2) ! functional = W_I * ( 1 - |z_I|^2 ) coeff = -weights(idim0) CASE (3) ! functional = W_I * ( 1 - |z_I| ) CPABORT("Localization function is not implemented") + !coeff = -(weights(idim0)/(2.0_dp*z2(ielem))) END SELECT CALL dbcsr_add(temp2, temp1, 1.0_dp, coeff) + !CALL dbcsr_add(grad_loc, temp1, 1.0_dp, 1.0_dp) END DO ! end loop over idim0 CALL dbcsr_add(m_tmp_no_2, temp2, my_energy_coeff, my_localiz_coeff*4.0_dp) @@ -5180,6 +6150,13 @@ CONTAINS ! add penalty on the occupied volume: det(sigma) IF (penalty_occ_vol) THEN + !RZK-warning CALL dbcsr_multiply("N","N",& + !RZK-warning penalty_occ_vol_prefactor,& + !RZK-warning m_ST,& + !RZK-warning m_siginv,& + !RZK-warning 1.0_dp,m_tmp_no_2,& + !RZK-warning retain_sparsity=.TRUE.,& + !RZK-warning ) CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", & penalty_occ_vol_prefactor, & @@ -5190,6 +6167,7 @@ CONTAINS ! this norm does not contain the normalization factors penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) energy_g_norm = dbcsr_maxabs(m_tmp_no_2) + !WRITE (*, "(A30,2F20.10)") "Energy/penalty g norms (no norm): ", energy_g_norm, penalty_occ_vol_g_norm CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, 1.0_dp) END IF @@ -5203,6 +6181,17 @@ CONTAINS ! This is because tr(T).G_Energy = 0 and ! tr(T).G_Penalty = c0*I + !! faster way to take the norm into account (tested for vol penalty olny) + !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) + !!CALL dbcsr_copy(m_tmp_no_1, m_ST, keep_sparsity=.TRUE.) + !!CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, -penalty_occ_vol_prefactor) + !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) + !!CALL dbcsr_multiply("N", "N", 1.0_dp, & + !! m_tmp_no_2, & + !! m_sig_sqrti_ii, & + !! 0.0_dp, m_tmp_no_1, & + !! retain_sparsity=.TRUE.) + ! slower way of taking the norm into account CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -5277,6 +6266,34 @@ CONTAINS CALL dbcsr_copy(m_tmp_no_1, m_grad_out) END IF + !! check whether the gradient lies entirely in R or Q + !CALL dbcsr_multiply("T","N",1.0_dp,& + ! m_t,& + ! m_tmp_no_1,& + ! 0.0_dp,m_tmp_oo_1,& + ! filter_eps=eps_filter,& + ! ) + !CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_siginv,& + ! m_tmp_oo_1,& + ! 0.0_dp,m_tmp_oo_2,& + ! filter_eps=eps_filter,& + ! ) + !CALL dbcsr_copy(m_tmp_no_2,m_tmp_no_1) + !CALL dbcsr_multiply("N","N",-1.0_dp,& + ! m_ST,& + ! m_tmp_oo_2,& + ! 1.0_dp,m_tmp_no_2,& + ! retain_sparsity=.TRUE.,& + ! ) + !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) + !WRITE(*,"(A50,2F20.10)") "Virtual-space projection of the gradient", penalty_occ_vol_g_norm + !CALL dbcsr_add(m_tmp_no_2,m_tmp_no_1,1.0_dp,-1.0_dp) + !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) + !WRITE(*,"(A50,2F20.10)") "Occupied-space projection of the gradient", penalty_occ_vol_g_norm + !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) + !WRITE(*,"(A50,2F20.10)") "Full gradient", penalty_occ_vol_g_norm + ! transform d_E/d_T to d_E/d_theta IF (optimize_theta) THEN CALL dbcsr_copy(m_tmp_no_2, m_theta) @@ -5634,6 +6651,7 @@ CONTAINS CALL dbcsr_get_diag(m_temp_oo_4, tg_diagonal) CALL dbcsr_set(m_temp_oo_4, 0.0_dp) CALL dbcsr_set_diag(m_temp_oo_4, tg_diagonal) + !CALL para_group%sum(tg_diagonal) z2(:) = z2(:) + tg_diagonal(:)*tg_diagonal(:) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -6034,6 +7052,15 @@ CONTAINS CALL dbcsr_copy(m_f_vv_out, m_prec_out) END IF +#if 0 +!penalty_only=.TRUE. + WRITE (unit_nr, *) "prefactor0:", penalty_occ_vol_prefactor + !IF (penalty_occ_vol) THEN + CALL dbcsr_desymmetrize(m_s, & + m_prec_out) + !CALL dbcsr_scale(m_prec_out,-penalty_occ_vol_prefactor) + !ENDIF +#else ! sum up the F_vv and S_vv terms CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, 1.0_dp) @@ -6045,6 +7072,7 @@ CONTAINS CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, penalty_occ_vol_prefactor) END IF +#endif CALL dbcsr_copy(m_tmp_nn_1, m_prec_out) @@ -6140,6 +7168,67 @@ CONTAINS END IF ! special_case + ! invert using cholesky (works with S matrix, will not work with S-SRS matrix) + !!!CALL cp_dbcsr_cholesky_decompose(prec_vv,& + !!! para_env=almo_scf_env%para_env,& + !!! blacs_env=almo_scf_env%blacs_env) + !!!CALL cp_dbcsr_cholesky_invert(prec_vv,& + !!! para_env=almo_scf_env%para_env,& + !!! blacs_env=almo_scf_env%blacs_env,& + !!! uplo_to_full=.TRUE.) + !!!CALL dbcsr_filter(prec_vv,& + !!! almo_scf_env%eps_filter) + !!! + + ! re-create the matrix because desymmetrize is buggy - + ! it will create multiple copies of blocks + !!!DESYM!CALL dbcsr_create(prec_vv,& + !!!DESYM! template=almo_scf_env%matrix_s(1),& + !!!DESYM! matrix_type=dbcsr_type_no_symmetry) + !!!DESYM!CALL dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& + !!!DESYM! prec_vv) + !CALL dbcsr_multiply("N","N",1.0_dp,& + ! almo_scf_env%matrix_s(1),& + ! matrix_t_out(ispin),& + ! 0.0_dp,m_tmp_no_1,& + ! filter_eps=almo_scf_env%eps_filter) + !CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_tmp_no_1,& + ! almo_scf_env%matrix_sigma_inv(ispin),& + ! 0.0_dp,m_tmp_no_3,& + ! filter_eps=almo_scf_env%eps_filter) + !CALL dbcsr_multiply("N","T",-1.0_dp,& + ! m_tmp_no_3,& + ! m_tmp_no_1,& + ! 1.0_dp,prec_vv,& + ! filter_eps=almo_scf_env%eps_filter) + !CALL dbcsr_add_on_diag(prec_vv,& + ! prec_sf_mixing_s) + + !CALL dbcsr_create(prec_oo,& + ! template=almo_scf_env%matrix_sigma(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& + ! prec_oo) + !CALL dbcsr_filter(prec_oo,& + ! almo_scf_env%eps_filter) + + !! invert using cholesky + !CALL dbcsr_create(prec_oo_inv,& + ! template=prec_oo,& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_desymmetrize(prec_oo,& + ! prec_oo_inv) + !CALL cp_dbcsr_cholesky_decompose(prec_oo_inv,& + ! para_env=almo_scf_env%para_env,& + ! blacs_env=almo_scf_env%blacs_env) + !CALL cp_dbcsr_cholesky_invert(prec_oo_inv,& + ! para_env=almo_scf_env%para_env,& + ! blacs_env=almo_scf_env%blacs_env,& + ! uplo_to_full=.TRUE.) + CALL dbcsr_release(m_tmp_nn_1) CALL dbcsr_release(m_tmp_no_3) @@ -6485,6 +7574,10 @@ CONTAINS filter_eps=eps_filter) ! RZK-warning +! compute preconditioner even if we do not use it +! this is for debugging because compute_preconditioner includes +! computing F_vv and S_vv necessary for +! IF ( use_preconditioner ) THEN ! domain_s_inv and domain_r_down are never used with assume_t0_q0x=FALSE CALL compute_preconditioner( & @@ -6517,6 +7610,8 @@ CONTAINS skip_inversion=.FALSE. & ) +! ENDIF ! use_preconditioner + ! initial guess CALL dbcsr_copy(m_delta(ispin), m_quench_t(ispin)) ! in order to use dbcsr_set matrix blocks must exist @@ -6552,7 +7647,10 @@ CONTAINS penalty_occ_vol_pf2=penalty_occ_vol_pf2(ispin), & m_s=m_s(1), & para_env=para_env, & - blacs_env=blacs_env) + blacs_env=blacs_env & + ) + ! correct solution by the spin factor + !CALL dbcsr_scale(m_zet(ispin),1.0_dp/(2.0_dp*spin_factor)) ELSE ! use PCG to solve H.D=-G @@ -6577,7 +7675,10 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter) + filter_eps=eps_filter & + !matrix_trimmer=,& + !use_trimmer=.FALSE.,& + ) END IF ! special_case @@ -6631,7 +7732,8 @@ CONTAINS normalize_orbitals=normalize_orbitals, & penalty_occ_vol_prefactor=penalty_occ_vol_prefactor, & eps_filter=eps_filter, & - path_num=hessian_path_reuse) + path_num=hessian_path_reuse & + ) ! alpha is computed outside the spin loop numer = 0.0_dp @@ -6676,6 +7778,10 @@ CONTAINS ! compute the new step (apply preconditioner if available) IF (use_preconditioner) THEN + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....applying preconditioner...." + !ENDIF + IF (special_case == xalmo_case_block_diag .OR. & special_case == xalmo_case_fully_deloc) THEN @@ -6695,7 +7801,10 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter) + filter_eps=eps_filter & + !matrix_trimmer=,& + !use_trimmer=.FALSE.,& + ) END IF ! special case @@ -6728,6 +7837,7 @@ CONTAINS t2 = m_walltime() IF (unit_nr > 0) THEN + !iter_type=TRIM("ALMO SCF "//iter_type) iter_type = TRIM("NR STEP") WRITE (unit_nr, '(T6,A9,I6,F14.5,F14.5,F15.10,F9.2)') & iter_type, iteration, & @@ -6750,6 +7860,26 @@ CONTAINS END DO ! outer loop +! is not necessary if penalty_occ_vol_pf2=0.0 +#if 0 + + IF (penalty_occ_vol) THEN + + DO ispin = 1, nspins + + CALL dbcsr_copy(m_zet(ispin), m_grad(ispin)) + CALL dbcsr_dot(m_delta(ispin), m_zet(ispin), alpha) + WRITE (unit_nr, *) "trace(grad.delta): ", alpha + alpha = -1.0_dp/(penalty_occ_vol_pf2(ispin)*alpha - 1.0_dp) + WRITE (unit_nr, *) "correction alpha: ", alpha + CALL dbcsr_scale(m_delta(ispin), alpha) + + END DO + + END IF + +#endif + DO ispin = 1, nspins ! check whether the step lies entirely in R or Q @@ -6956,6 +8086,44 @@ CONTAINS ! apply pre-computed F_vv and S_vv to X +#if 0 +! RZK-warning: negative sign at penalty_prefactor_local is that +! magical fix for the negative definite problem +! (since penalty_prefactor_local<0 the coeff before S_vv must +! be multiplied by -1 to take the step in the right direction) +!CALL dbcsr_multiply("N","N",-4.0_dp*penalty_prefactor_local,& +! m_s_vv(ispin),& +! m_tmp_x_in,& +! 0.0_dp,m_tmp_no_1,& +! filter_eps=eps_filter) +!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) +!CALL dbcsr_multiply("N","N",1.0_dp,& +! m_tmp_no_1,& +! m_siginv(ispin),& +! 0.0_dp,m_x_out(ispin),& +! retain_sparsity=.TRUE.) + + CALL dbcsr_multiply("N", "N", 1.0_dp, & + m_s(1), & + m_tmp_x_in, & + 0.0_dp, m_tmp_no_1, & + filter_eps=eps_filter) + CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) + CALL dbcsr_multiply("N", "N", 1.0_dp, & + m_tmp_no_1, & + m_siginv(ispin), & + 0.0_dp, m_x_out(ispin), & + retain_sparsity=.TRUE.) + +!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) +!CALL dbcsr_multiply("N","N",1.0_dp,& +! m_s(1),& +! m_tmp_x_in,& +! 0.0_dp,m_x_out(ispin),& +! retain_sparsity=.TRUE.) + +#else + ! debugging: only vv matrices, oo matrices are kronecker CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -6972,6 +8140,75 @@ CONTAINS retain_sparsity=.TRUE.) CALL dbcsr_add(m_x_out(ispin), m_tmp_no_2, & 1.0_dp, -4.0_dp*penalty_prefactor_local + 1.0_dp) +#endif + +! ! F_vv.X.S_oo +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_ks_vv(ispin),& +! m_tmp_x_in,& +! 0.0_dp,m_tmp_no_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_tmp_no_1,& +! m_siginv(ispin),& +! 0.0_dp,m_x_out(ispin),& +! retain_sparsity=.TRUE.,& +! ) +! +! ! S_vv.X.F_oo +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_s_vv(ispin),& +! m_tmp_x_in,& +! 0.0_dp,m_tmp_no_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_tmp_no_1,& +! m_siginvTFTsiginv(ispin),& +! 0.0_dp,m_tmp_no_2,& +! retain_sparsity=.TRUE.,& +! ) +! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& +! 1.0_dp,-1.0_dp) +!! we have to add occ voll penalty here (the Svv termi (i.e. both Svv.D.Soo) +!! and STsiginv terms) +! +! ! S_vo.X^t.F_vo +! CALL dbcsr_multiply("T","N",1.0_dp,& +! m_tmp_x_in,& +! m_g_full(ispin),& +! 0.0_dp,m_tmp_oo_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_STsiginv(ispin),& +! m_tmp_oo_1,& +! 0.0_dp,m_tmp_no_2,& +! retain_sparsity=.TRUE.,& +! ) +! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& +! 1.0_dp,-1.0_dp) +! +! ! S_vo.X^t.F_vo +! CALL dbcsr_multiply("T","N",1.0_dp,& +! m_tmp_x_in,& +! m_STsiginv(ispin),& +! 0.0_dp,m_tmp_oo_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_g_full(ispin),& +! m_tmp_oo_1,& +! 0.0_dp,m_tmp_no_2,& +! retain_sparsity=.TRUE.,& +! ) +! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& +! 1.0_dp,-1.0_dp) ELSE IF (path_num == hessian_path_assemble) THEN @@ -7163,6 +8400,12 @@ CONTAINS WRITE (unit_nr, *) "penalty_prefactor_local: ", penalty_prefactor_local WRITE (unit_nr, *) "penalty_prefactor_2: ", penalty_occ_vol_pf2 + !CALL dbcsr_print(matrix_grad) + !CALL dbcsr_print(matrix_F_ao_sym) + !CALL dbcsr_print(matrix_S_ao_sym) + !CALL dbcsr_print(matrix_F_mo_sym) + !CALL dbcsr_print(matrix_S_mo_sym) + ! loop over domains to find the size of the Hessian H_size = 0 DO col = 1, nblkcols_tot @@ -7262,6 +8505,23 @@ CONTAINS S_mo_block(1:mo_block_sizes(row), 1:mo_block_sizes(col)) = block_p(:, :) END IF + !WRITE(*,*) "F_AO_BLOCK", row, col, ao_domain_sizes(row), ao_domain_sizes(col) + !DO ii=1,ao_domain_sizes(row) + ! WRITE(*,'(100F13.9)') F_ao_block(ii,:) + !ENDDO + !WRITE(*,*) "S_AO_BLOCK", row, col + !DO ii=1,ao_domain_sizes(row) + ! WRITE(*,'(100F13.9)') S_ao_block(ii,:) + !ENDDO + !WRITE(*,*) "F_MO_BLOCK", row, col + !DO ii=1,mo_block_sizes(row) + ! WRITE(*,'(100F13.9)') F_mo_block(ii,:) + !ENDDO + !WRITE(*,*) "S_MO_BLOCK", row, col, mo_block_sizes(row), mo_block_sizes(col) + !DO ii=1,mo_block_sizes(row) + ! WRITE(*,'(100F13.9)') S_mo_block(ii,:) + !ENDDO + ! construct tensor products for the current row-column fragment pair lev2_vert_offset = 0 DO orb_j = 1, mo_block_sizes(row) @@ -7271,8 +8531,16 @@ CONTAINS IF (orb_i == orb_j .AND. row == col) THEN H(lev1_vert_offset + lev2_vert_offset + 1:lev1_vert_offset + lev2_vert_offset + ao_domain_sizes(row), & lev1_hori_offset + lev2_hori_offset + 1:lev1_hori_offset + lev2_hori_offset + ao_domain_sizes(col)) & + != -penalty_prefactor_local*S_ao_block(:,:) = F_ao_block(:, :) + S_ao_block(:, :) +!=S_ao_block(:,:) +!RZK-warning =F_ao_block(:,:)+( 1.0_dp + penalty_prefactor_local )*S_ao_block(:,:) +! =S_mo_block(orb_j,orb_i)*F_ao_block(:,:)& +! -F_mo_block(orb_j,orb_i)*S_ao_block(:,:)& +! +penalty_prefactor_local*S_mo_block(orb_j,orb_i)*S_ao_block(:,:) END IF + !WRITE(*,*) row, col, orb_j, orb_i, lev1_vert_offset+lev2_vert_offset+1, ao_domain_sizes(row),& + ! lev1_hori_offset+lev2_hori_offset+1, ao_domain_sizes(col), S_mo_block(orb_j,orb_i) lev2_hori_offset = lev2_hori_offset + ao_domain_sizes(col) @@ -7300,6 +8568,180 @@ CONTAINS CALL dbcsr_release(matrix_S_mo_sym) CALL dbcsr_release(matrix_F_mo_sym) +!! ! Two more terms of the Hessian: S_vo.D.F_vo and F_vo.D.S_vo +!! ! It seems that these terms break positive definite property of the Hessian +!! ALLOCATE(H1(H_size,H_size)) +!! ALLOCATE(H2(H_size,H_size)) +!! H1=0.0_dp +!! H2=0.0_dp +!! DO row = 1, nblkcols_tot +!! +!! lev1_hori_offset=0 +!! DO col = 1, nblkcols_tot +!! +!! CALL dbcsr_get_block_p(matrix_F_vo,& +!! row, col, block_p, found) +!! CALL dbcsr_get_block_p(matrix_S_vo,& +!! row, col, block_p2, found2) +!! +!! lev1_vert_offset=0 +!! DO block_col = 1, nblkcols_tot +!! +!! CALL dbcsr_get_block_p(quench_t,& +!! row, block_col, p_new_block, found_row) +!! +!! IF (found_row) THEN +!! +!! ! determine offset in this short loop +!! lev2_vert_offset=0 +!! DO block_row=1,row-1 +!! CALL dbcsr_get_block_p(quench_t,& +!! block_row, block_col, p_new_block, found_col) +!! IF (found_col) lev2_vert_offset=lev2_vert_offset+ao_block_sizes(block_row) +!! ENDDO +!! !!!!!!!! short loop +!! +!! ! over all electrons of the block +!! DO orb_i=1, mo_block_sizes(col) +!! +!! ! into all possible locations +!! DO orb_j=1, mo_block_sizes(block_col) +!! +!! ! column is copied several times +!! DO copy=1, ao_domain_sizes(col) +!! +!! IF (found) THEN +!! +!! !WRITE(*,*) row, col, block_col, orb_i, orb_j, copy,& +!! ! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1,& +!! ! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy +!! +!! H1( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& +!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& +!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& +!! =block_p(:,orb_i) +!! +!! ENDIF ! found block in the data matrix +!! +!! IF (found2) THEN +!! +!! H2( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& +!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& +!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& +!! =block_p2(:,orb_i) +!! +!! ENDIF ! found block in the data matrix +!! +!! ENDDO +!! +!! ENDDO +!! +!! ENDDO +!! +!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) +!! +!! ENDIF ! found block in the quench matrix +!! +!! lev1_vert_offset=lev1_vert_offset+& +!! ao_domain_sizes(block_col)*mo_block_sizes(block_col) +!! +!! ENDDO +!! +!! lev1_hori_offset=lev1_hori_offset+& +!! ao_domain_sizes(col)*mo_block_sizes(col) +!! +!! ENDDO +!! +!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) +!! +!! ENDDO +!! H1(:,:)=H1(:,:)*2.0_dp*spin_factor +!! !!!WRITE(*,*) "F_vo" +!! !!!DO ii=1,H_size +!! !!! WRITE(*,'(100F13.9)') H1(ii,:) +!! !!!ENDDO +!! !!!WRITE(*,*) "S_vo" +!! !!!DO ii=1,H_size +!! !!! WRITE(*,'(100F13.9)') H2(ii,:) +!! !!!ENDDO +!! !!!!! add terms to the hessian +!! DO ii=1,H_size +!! DO jj=1,H_size +!!! add penalty_occ_vol term +!! H(ii,jj)=H(ii,jj)-H1(ii,jj)*H2(jj,ii)-H1(jj,ii)*H2(ii,jj) +!! ENDDO +!! ENDDO +!! DEALLOCATE(H1) +!! DEALLOCATE(H2) + +!! ! S_vo.S_vo diagonal component due to determiant constraint +!! ! use grad vector temporarily +!! IF (penalty_occ_vol) THEN +!! ALLOCATE(Grad_vec(H_size)) +!! Grad_vec(:)=0.0_dp +!! lev1_vert_offset=0 +!! ! loop over all electron blocks +!! DO col = 1, nblkcols_tot +!! +!! ! loop over AO-rows of the dbcsr matrix +!! lev2_vert_offset=0 +!! DO row = 1, nblkrows_tot +!! +!! CALL dbcsr_get_block_p(quench_t,& +!! row, col, block_p, found_row) +!! IF (found_row) THEN +!! +!! CALL dbcsr_get_block_p(matrix_S_vo,& +!! row, col, block_p, found) +!! IF (found) THEN +!! ! copy the data into the vector, column by column +!! DO orb_i=1, mo_block_sizes(col) +!! Grad_vec(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& +!! lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& +!! =block_p(:,orb_i) +!! ENDDO +!! +!! ENDIF +!! +!! lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) +!! +!! ENDIF +!! +!! ENDDO +!! +!! lev1_vert_offset=lev1_vert_offset+ao_domain_sizes(col)*mo_block_sizes(col) +!! +!! ENDDO ! loop over electron blocks +!! ! update H now +!! DO ii=1,H_size +!! DO jj=1,H_size +!! H(ii,jj)=H(ii,jj)+penalty_occ_vol_prefactor*& +!! penalty_occ_vol_pf2*Grad_vec(ii)*Grad_vec(jj) +!! ENDDO +!! ENDDO +!! DEALLOCATE(Grad_vec) +!! ENDIF ! penalty_occ_vol + +!S-1.G ! invert S using cholesky +!S-1.G CALL dbcsr_create(m_prec_out,& +!S-1.G template=m_s,& +!S-1.G matrix_type=dbcsr_type_no_symmetry) +!S-1.G CALL dbcsr_copy(m_prec_out,m_s) +!S-1.G CALL dbcsr_cholesky_decompose(m_prec_out,& +!S-1.G para_env=para_env,& +!S-1.G blacs_env=blacs_env) +!S-1.G CALL dbcsr_cholesky_invert(m_prec_out,& +!S-1.G para_env=para_env,& +!S-1.G blacs_env=blacs_env,& +!S-1.G uplo_to_full=.TRUE.) +!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& +!S-1.G m_prec_out,& +!S-1.G matrix_grad,& +!S-1.G 0.0_dp,matrix_step,& +!S-1.G filter_eps=1.0E-10_dp) +!S-1.G !CALL dbcsr_release(m_prec_out) +!S-1.G ALLOCATE(test3(H_size)) + ! convert gradient from the dbcsr matrix to the vector form ALLOCATE (Grad_vec(H_size)) Grad_vec(:) = 0.0_dp @@ -7323,10 +8765,22 @@ CONTAINS Grad_vec(lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + 1: & lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + ao_block_sizes(row)) & = block_p(:, orb_i) +!WRITE(*,*) "GRAD: ", row, col, orb_i, lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1, ao_block_sizes(row) END DO END IF +!S-1.G CALL dbcsr_get_block_p(matrix_step,& +!S-1.G row, col, block_p, found) +!S-1.G IF (found) THEN +!S-1.G ! copy the data into the vector, column by column +!S-1.G DO orb_i=1, mo_block_sizes(col) +!S-1.G test3(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& +!S-1.G lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& +!S-1.G =block_p(:,orb_i) +!S-1.G ENDDO +!S-1.G ENDIF + lev2_vert_offset = lev2_vert_offset + ao_block_sizes(row) END IF @@ -7337,6 +8791,12 @@ CONTAINS END DO ! loop over electron blocks + !WRITE(*,*) "HESSIAN" + !DO ii=1,H_size + ! WRITE(*,*) ii + ! WRITE(*,'(20F14.10)') H(ii,:) + !ENDDO + ! invert the Hessian INFO = 0 ALLOCATE (Hinv(H_size, H_size)) @@ -7364,6 +8824,21 @@ CONTAINS ! Step_vec contains Grad_vec here Step_vec(:) = MATMUL(TRANSPOSE(Hinv), Grad_vec) + ! compute U.tr(U)-1 = error + !ALLOCATE(test(H_size,H_size)) + !test(:,:)=MATMUL(TRANSPOSE(Hinv),Hinv) + !DO ii=1,H_size + ! test(ii,ii)=test(ii,ii)-1.0_dp + !ENDDO + !test_error=0.0_dp + !DO ii=1,H_size + ! DO jj=1,H_size + ! test_error=test_error+test(jj,ii)*test(jj,ii) + ! ENDDO + !ENDDO + !WRITE(*,*) "U.tr(U)-1 error: ", SQRT(test_error) + !DEALLOCATE(test) + ! invert eigenvalues and use eigenvectors to compute the Hessian inverse ! project out zero-eigenvalue directions ALLOCATE (test(H_size, H_size)) @@ -7385,8 +8860,46 @@ CONTAINS Hinv(:, :) = test2(:, :) DEALLOCATE (test, test2) + !! shift to kill singularity + !shift=0.0_dp + !IF (eigenvalues(1).lt.0.0_dp) THEN + ! CPABORT("Negative eigenvalue(s)") + ! shift=abs(eigenvalues(1)) + ! WRITE(*,*) "Lowest eigenvalue: ", eigenvalues(1) + !ENDIF + !DO ii=1, H_size + ! IF (eigenvalues(ii).gt.eps_zero) THEN + ! shift=shift+min(1.0_dp,eigenvalues(ii))*1.0E-4_dp + ! EXIT + ! ENDIF + !ENDDO + !WRITE(*,*) "Hessian shift: ", shift + !DO ii=1, H_size + ! H(ii,ii)=H(ii,ii)+shift + !ENDDO + !! end shift + DEALLOCATE (eigenvalues) +!!!! Hinv=H +!!!! INFO=0 +!!!! CALL dpotrf('L', H_size, Hinv, H_size, INFO ) +!!!! IF( INFO/=0 ) THEN +!!!! WRITE(*,*) 'DPOTRF ERROR MESSAGE: ', INFO +!!!! CPABORT("DPOTRF failed") +!!!! END IF +!!!! CALL dpotri('L', H_size, Hinv, H_size, INFO ) +!!!! IF( INFO/=0 ) THEN +!!!! WRITE(*,*) 'DPOTRI ERROR MESSAGE: ', INFO +!!!! CPABORT("DPOTRI failed") +!!!! END IF +!!!! ! complete the matrix +!!!! DO ii=1,H_size +!!!! DO jj=ii+1,H_size +!!!! Hinv(ii,jj)=Hinv(jj,ii) +!!!! ENDDO +!!!! ENDDO + ! compute the inversion error ALLOCATE (test(H_size, H_size)) test(:, :) = MATMUL(Hinv, H) @@ -7406,6 +8919,7 @@ CONTAINS ALLOCATE (Step_vec(H_size)) ALLOCATE (tmp(H_size)) tmp(:) = MATMUL(Hinv, Grad_vec) + !tmp(:)=MATMUL(Hinv,test3) Step_vec(:) = -1.0_dp*tmp(:) ALLOCATE (tmpr(H_size)) @@ -7463,6 +8977,19 @@ CONTAINS CALL dbcsr_finalize(matrix_step) +!S-1.G CALL dbcsr_create(m_tmp_no_1,& +!S-1.G template=matrix_step,& +!S-1.G matrix_type=dbcsr_type_no_symmetry) +!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& +!S-1.G m_prec_out,& +!S-1.G matrix_step,& +!S-1.G 0.0_dp,m_tmp_no_1,& +!S-1.G filter_eps=1.0E-10_dp,& +!S-1.G ) +!S-1.G CALL dbcsr_copy(matrix_step,m_tmp_no_1) +!S-1.G CALL dbcsr_release(m_tmp_no_1) +!S-1.G CALL dbcsr_release(m_prec_out) + DEALLOCATE (mo_block_sizes, ao_block_sizes) DEALLOCATE (ao_domain_sizes) @@ -7608,6 +9135,8 @@ CONTAINS ! penalty amplitude adjusts the strength of volume conservation penalty_occ_vol = .FALSE. + !(almo_scf_env%penalty%occ_vol_method /= almo_occ_vol_penalty_none .AND. & + ! my_special_case == xalmo_case_fully_deloc) normalize_orbitals = penalty_occ_vol penalty_amplitude = 0.0_dp !almo_scf_env%penalty%occ_vol_coeff ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) @@ -7877,6 +9406,8 @@ CONTAINS ! check convergence and other exit criteria DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin)) + !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & + ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin grad_norm_ref = MAXVAL(grad_norm_spin) @@ -7898,9 +9429,8 @@ CONTAINS scf_converged = .TRUE. border_reached = .FALSE. expected_reduction = 0.0_dp - IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) THEN + IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) & EXIT adjust_r_loop - END IF ELSE scf_converged = .FALSE. END IF @@ -8257,6 +9787,35 @@ CONTAINS END IF ! special_case + ! slower but more reliable way to get inverted hessian + !DO ispin = 1, nspins + ! CALL compute_preconditioner( & + ! domain_prec_out=domain_model_hessian_inv(:, ispin), & + ! m_prec_out=m_model_hessian_inv(ispin), & ! RZK-warning: this one is not inverted if DOMAINs + ! m_ks=almo_scf_env%matrix_ks(ispin), & + ! m_s=almo_scf_env%matrix_s(1), & + ! m_siginv=almo_scf_env%matrix_sigma_inv(ispin), & + ! m_quench_t=quench_t(ispin), & + ! m_FTsiginv=FTsiginv(ispin), & + ! m_siginvTFTsiginv=siginvTFTsiginv(ispin), & + ! m_ST=ST(ispin), & + ! para_env=almo_scf_env%para_env, & + ! blacs_env=almo_scf_env%blacs_env, & + ! nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), & + ! domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), & + ! domain_r_down=domain_r_down(:, ispin), & + ! cpu_of_domain=almo_scf_env%cpu_of_domain, & + ! domain_map=almo_scf_env%domain_map(ispin), & + ! assume_t0_q0x=.FALSE., & + ! penalty_occ_vol=penalty_occ_vol, & + ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), & + ! eps_filter=almo_scf_env%eps_filter, & + ! neg_thr=1.0E10_dp, & + ! spin_factor=spin_factor, & + ! skip_inversion=.FALSE., & + ! special_case=my_special_case) + !ENDDO ! ispin + CASE DEFAULT CPABORT("Unknown preconditioner") @@ -8339,9 +9898,8 @@ CONTAINS ) IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size IF (step_size > 1.0_dp .OR. step_size < 0.0_dp) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Step size (", step_size, ") must lie inside (0,1)" - END IF CPABORT("Wrong dog leg step. We should never end up here.") END IF @@ -8408,6 +9966,8 @@ CONTAINS ! Model grad norm DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(m_model_r(ispin)) + !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & + ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin model_grad_norm = MAXVAL(grad_norm_spin) @@ -8521,6 +10081,7 @@ CONTAINS END DO ! ispin ! compute the energy + !IF (.NOT. same_position) THEN CALL main_var_to_xalmos_and_loss_func( & almo_scf_env=almo_scf_env, & qs_env=qs_env, & @@ -8543,6 +10104,7 @@ CONTAINS do_penalty=penalty_occ_vol, & special_case=my_special_case) loss_trial = energy_trial + penalty_trial + !ENDIF ! not same_position rho = (loss_trial - loss_start)/expected_reduction loss_change_to_report = loss_trial - loss_start diff --git a/src/almo_scf_qs.F b/src/almo_scf_qs.F index 82bf191e1c..99b41e1c95 100644 --- a/src/almo_scf_qs.F +++ b/src/almo_scf_qs.F @@ -288,6 +288,63 @@ 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 @@ -554,7 +611,7 @@ CONTAINS n_el_f=REAL(almo_scf_env%nelectrons_total, dp), & maxocc=2.0_dp, & flexible_electron_count=dft_control%relax_multiplicity) - ELSE IF (almo_scf_env%nspins == 2) THEN + ELSEIF (almo_scf_env%nspins == 2) THEN CALL allocate_mo_set(mo_set=mos(ispin), & nao=nrow_fm, & nmo=ncol_fm, & @@ -1439,6 +1496,23 @@ CONTAINS DEALLOCATE (last_atom_of_molecule) END IF + !mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(& + ! dbcsr_distribution(almo_scf_env%quench_t(ispin)))) + !CALL dbcsr_get_info(almo_scf_env%quench_t(ispin), distribution=dist, & + ! nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) + !DO row = 1, nblkrows_tot + ! DO col = 1, nblkcols_tot + ! tr = .FALSE. + ! iblock_row = row + ! iblock_col = col + ! CALL dbcsr_get_stored_coordinates(almo_scf_env%quench_t(ispin),& + ! iblock_row, iblock_col, tr, hold) + ! CALL dbcsr_get_block_p(almo_scf_env%quench_t(ispin),& + ! row, col, p_old_block, found) + ! write(*,*) "RST_NOTE:", mynode, row, col, hold, found + ! ENDDO + !ENDDO + CALL timestop(handle) END SUBROUTINE almo_scf_construct_quencher diff --git a/src/almo_scf_types.F b/src/almo_scf_types.F index a75d2577d9..d4c9030aa1 100644 --- a/src/almo_scf_types.F +++ b/src/almo_scf_types.F @@ -569,9 +569,8 @@ 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) THEN + IF (almo_scf_env%almo_history%istore > 0) & 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) @@ -581,9 +580,8 @@ 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) THEN + IF (almo_scf_env%xalmo_history%istore > 0) & CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_t(ispin)) - END IF END DO DEALLOCATE (almo_scf_env%xalmo_history%matrix_p_up_down) !DEALLOCATE (almo_scf_env%xalmo_history%matrix_x) diff --git a/src/aobasis/ai_contraction.F b/src/aobasis/ai_contraction.F index 02d87a97e3..57bacd8e99 100644 --- a/src/aobasis/ai_contraction.F +++ b/src/aobasis/ai_contraction.F @@ -439,7 +439,7 @@ CONTAINS ELSE qab(ia:ja, ib:jb) = qab(ia:ja, ib:jb) + sab(1:na, 1:nb) END IF - ELSE IF (dir == "OUT" .OR. dir == "out") THEN + ELSEIF (dir == "OUT" .OR. dir == "out") THEN ! SAB <= QAB(block) ja = ia + na - 1 jb = ib + nb - 1 diff --git a/src/aobasis/ai_eri_debug.F b/src/aobasis/ai_eri_debug.F index ea40188793..4838e75ed3 100644 --- a/src/aobasis/ai_eri_debug.F +++ b/src/aobasis/ai_eri_debug.F @@ -128,16 +128,16 @@ CONTAINS IF (dn(1) > 0) THEN IABCD = os(an, bn, cn + i1, dn - i1) - (D(1) - C(1))*os(an, bn, cn, dn - i1) - ELSE IF (dn(2) > 0) THEN + ELSEIF (dn(2) > 0) THEN IABCD = os(an, bn, cn + i2, dn - i2) - (D(2) - C(2))*os(an, bn, cn, dn - i2) - ELSE IF (dn(3) > 0) THEN + ELSEIF (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) - ELSE IF (bn(2) > 0) THEN + ELSEIF (bn(2) > 0) THEN IABCD = os(an + i2, bn - i2, cn, dn) - (B(2) - A(2))*os(an, bn - i2, cn, dn) - ELSE IF (bn(3) > 0) THEN + ELSEIF (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) - ELSE IF (cn(2) > 0) THEN + ELSEIF (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) - ELSE IF (cn(3) > 0) THEN + ELSEIF (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) - ELSE IF (an(2) > 0) THEN + ELSEIF (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) - ELSE IF (an(3) > 0) THEN + ELSEIF (an(3) > 0) THEN IABCD = (P(3) - A(3))*os(an - i3, bn, cn, dn, m) + & (W(3) - P(3))*os(an - i3, bn, cn, dn, m + 1) + & 0.5_dp*(an(3) - 1)/xsi*os(an - i3 - i3, bn, cn, dn, m) - & diff --git a/src/aobasis/ai_os_rr.F b/src/aobasis/ai_os_rr.F index f515ef089e..f5682c7b4c 100644 --- a/src/aobasis/ai_os_rr.F +++ b/src/aobasis/ai_os_rr.F @@ -162,7 +162,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(az - 1, dp)*(rr(m, coa2z, 1) - rr(m + 1, coa2z, 1)) END DO END IF - ELSE IF (ay > 0) THEN + ELSEIF (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 - ELSE IF (ax > 0) THEN + ELSEIF (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 - ELSE IF (by > 0) THEN + ELSEIF (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 - ELSE IF (bx > 0) THEN + ELSEIF (bx > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(1)*rr(m, coa, cob1x) - rcp(1)*rr(m + 1, coa, cob1x) END DO diff --git a/src/aobasis/ai_overlap.F b/src/aobasis/ai_overlap.F index a3fe82c3e1..29b7a50a38 100644 --- a/src/aobasis/ai_overlap.F +++ b/src/aobasis/ai_overlap.F @@ -2050,12 +2050,12 @@ CONTAINS DO l = 0, la IF (l == 0) THEN fun(:, l) = z_one - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN fun(:, l) = CMPLX(0.0_dp, 0.5_dp*oa*gval(:), KIND=dp) - ELSE IF (l == 2) THEN + ELSEIF (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) - ELSE IF (l == 3) THEN + ELSEIF (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 - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN gun(:, l) = CMPLX(0.0_dp, 0.5_dp*ob*gval(:), KIND=dp) - ELSE IF (l == 2) THEN + ELSEIF (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) - ELSE IF (l == 3) THEN + ELSEIF (l == 3) THEN gun(:, l) = CMPLX(0.0_dp, -(0.5_dp*ob*gval(:))**3, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.0_dp, 0.75_dp*ob*ob*gval(:), KIND=dp) ELSE diff --git a/src/aobasis/ai_overlap3_debug.F b/src/aobasis/ai_overlap3_debug.F index 76c062b1e8..2be04a16d7 100644 --- a/src/aobasis/ai_overlap3_debug.F +++ b/src/aobasis/ai_overlap3_debug.F @@ -99,25 +99,25 @@ CONTAINS IF (bn(1) > 0) THEN IACB = os_overlap3(an, cn + i1, bn - i1) + (C(1) - B(1))*os_overlap3(an, cn, bn - i1) - ELSE IF (bn(2) > 0) THEN + ELSEIF (bn(2) > 0) THEN IACB = os_overlap3(an, cn + i2, bn - i2) + (C(2) - B(2))*os_overlap3(an, cn, bn - i2) - ELSE IF (bn(3) > 0) THEN + ELSEIF (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) - ELSE IF (cn(2) > 0) THEN + ELSEIF (cn(2) > 0) THEN IACB = os_overlap3(an + i2, cn - i2, bn) + (A(2) - C(2))*os_overlap3(an, cn - i2, bn) - ELSE IF (cn(3) > 0) THEN + ELSEIF (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) - ELSE IF (an(2) > 0) THEN + ELSEIF (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) - ELSE IF (an(3) > 0) THEN + ELSEIF (an(3) > 0) THEN IACB = (G(3) - A(3))*os_overlap3(an - i3, cn, bn) + & 0.5_dp*(an(3) - 1)/(xsi + xc)*os_overlap3(an - i3 - i3, cn, bn) ELSE diff --git a/src/aobasis/ai_overlap_debug.F b/src/aobasis/ai_overlap_debug.F index 63bc5f7edc..e25ec161b7 100644 --- a/src/aobasis/ai_overlap_debug.F +++ b/src/aobasis/ai_overlap_debug.F @@ -87,18 +87,18 @@ CONTAINS IF (bn(1) > 0) THEN IAB = os_overlap2(an + i1, bn - i1) + (A(1) - B(1))*os_overlap2(an, bn - i1) - ELSE IF (bn(2) > 0) THEN + ELSEIF (bn(2) > 0) THEN IAB = os_overlap2(an + i2, bn - i2) + (A(2) - B(2))*os_overlap2(an, bn - i2) - ELSE IF (bn(3) > 0) THEN + ELSEIF (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) - ELSE IF (an(2) > 0) THEN + ELSEIF (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) - ELSE IF (an(3) > 0) THEN + ELSEIF (an(3) > 0) THEN IAB = (P(3) - A(3))*os_overlap2(an - i3, bn) + & 0.5_dp*(an(3) - 1)/xsi*os_overlap2(an - i3 - i3, bn) ELSE diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 6f25224995..3b2b3555fa 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -1680,9 +1680,8 @@ CONTAINS l(nshell(iset) - ishell + i, iset) = lshell END DO END DO - IF (LEN_TRIM(line_att) /= 0) THEN + IF (LEN_TRIM(line_att) /= 0) & 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!") @@ -2504,9 +2503,8 @@ CONTAINS ng = gto_basis_set%npgf(1) DO iset = 1, nset - IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) THEN + IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) & CPABORT("different number of primitves") - END IF END DO IF (do_ortho) THEN @@ -2684,7 +2682,7 @@ CONTAINS s00 = ai*aj*(pi*ab)**1.50_dp IF (l == 0) THEN sss = s00 - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN sss = s00*ab*0.5_dp ELSE CPABORT("aovlp lvalue") diff --git a/src/arnoldi/arnoldi_data_methods.F b/src/arnoldi/arnoldi_data_methods.F index d88400ae01..05acfa5bdb 100644 --- a/src/arnoldi/arnoldi_data_methods.F +++ b/src/arnoldi/arnoldi_data_methods.F @@ -138,15 +138,13 @@ CONTAINS CALL control%mp_group%set_handle(group_handle) CALL control%pcol_group%set_handle(pcol_handle) - IF (.NOT. subgroups_defined) THEN + IF (.NOT. subgroups_defined) & 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) THEN + IF (SIZE(matrix) == 1) & control%symmetric = dbcsr_get_matrix_type(matrix(1)%matrix) == dbcsr_type_symmetric - END IF ! Set the control parameters control%max_iter = max_iter @@ -160,28 +158,23 @@ CONTAINS control%nrestart = nrestarts control%generalized_ev = generalized_ev - IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) THEN + IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) & 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) THEN + IF (control%generalized_ev .AND. selection_crit == 1) & CALL cp_abort(__LOCATION__, & 'generalized ev can only highest OR lowest EV') - END IF - IF (control%generalized_ev .AND. nval_request /= 1) THEN + IF (control%generalized_ev .AND. nval_request /= 1) & CALL cp_abort(__LOCATION__, & 'generalized ev can only compute one EV at the time') - END IF - IF (control%generalized_ev .AND. control%nrestart == 0) THEN + IF (control%generalized_ev .AND. control%nrestart == 0) & CALL cp_abort(__LOCATION__, & 'outer loops are mandatory for generalized EV, set nrestart appropriatly') - END IF - IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) THEN + IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) & 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) @@ -393,9 +386,8 @@ CONTAINS INTEGER :: ev_ind INTEGER, DIMENSION(:), POINTER :: selected_ind - IF (ind > get_nval_out(arnoldi_env)) THEN + IF (ind > get_nval_out(arnoldi_env)) & CPABORT('outside range of indexed evals') - END IF selected_ind => get_sel_ind(arnoldi_env) ev_ind = selected_ind(ind) @@ -419,9 +411,8 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: selected_ind NULLIFY (evals) - IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) THEN + IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) & CPABORT('array for eval output too small') - END IF selected_ind => get_sel_ind(arnoldi_env) evals => get_evals(arnoldi_env) diff --git a/src/arnoldi/arnoldi_geev.F b/src/arnoldi/arnoldi_geev.F index 02af49f3c9..5c014fca00 100644 --- a/src/arnoldi/arnoldi_geev.F +++ b/src/arnoldi/arnoldi_geev.F @@ -14,12 +14,7 @@ !> \author Florian Schiffmann ! ************************************************************************************************** MODULE arnoldi_geev -#if defined (__HAS_IEEE_EXCEPTIONS) - USE ieee_exceptions, ONLY: ieee_get_halting_mode, & - ieee_set_halting_mode, & - IEEE_ALL -#endif - USE kinds, ONLY: dp + USE kinds, ONLY: dp #include "../base/base_uses.f90" IMPLICIT NONE @@ -81,9 +76,7 @@ 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 @@ -100,19 +93,8 @@ 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) @@ -162,7 +144,7 @@ CONTAINS i = 1 DO WHILE (i <= ndim) IF (ABS(eval2(i)) < EPSILON(REAL(0.0, dp))) THEN - evec_r(:, i) = evec_r(:, i)/NORM2(evec_r(:, i)) + evec_r(:, i) = evec_r(:, i)/SQRT(DOT_PRODUCT(evec_r(:, i), evec_r(:, i))) revec(:, i) = CMPLX(evec_r(:, i), REAL(0.0, dp), dp) levec(:, i) = CMPLX(evec_l(:, i), REAL(0.0, dp), dp) i = i + 1 diff --git a/src/arnoldi/arnoldi_methods.F b/src/arnoldi/arnoldi_methods.F index 2790c5d1b8..3ac3ef9ef7 100644 --- a/src/arnoldi/arnoldi_methods.F +++ b/src/arnoldi/arnoldi_methods.F @@ -561,7 +561,7 @@ CONTAINS ar_data%local_history = Zmat ! broadcast the Hessenberg matrix so we don't need to care later on - DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat) + DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat); DEALLOCATE (Zmat); DEALLOCATE (BZmat) CALL timestop(handle) diff --git a/src/atom_electronic_structure.F b/src/atom_electronic_structure.F index d490a9d9f6..c180ff67a2 100644 --- a/src/atom_electronic_structure.F +++ b/src/atom_electronic_structure.F @@ -343,10 +343,10 @@ CONTAINS xcmat%op = 0._dp CALL calculate_atom_vxc_lda(xcmat, atom, xc_section) ! ZMP added options for the zmp calculations, building external density and vxc potential - ELSE IF (need_zmp) THEN + ELSEIF (need_zmp) THEN xcmat%op = 0._dp CALL calculate_atom_zmp(ext_density=ext_density, atom=atom, lprint=.FALSE., xcmat=xcmat) - ELSE IF (need_vxc) THEN + ELSEIF (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 - ELSE IF (ne == 2._dp*nm) THEN !closed shell + ELSEIF (ne == 2._dp*nm) THEN !closed shell atom%state%occa(l, k) = nm atom%state%occb(l, k) = nm - ELSE IF (atom%state%multiplicity == -2) THEN !High spin case + ELSEIF (atom%state%multiplicity == -2) THEN !High spin case atom%state%occa(l, k) = MIN(ne, nm) atom%state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_energy.F b/src/atom_energy.F index c14bece975..7d2a7b853d 100644 --- a/src/atom_energy.F +++ b/src/atom_energy.F @@ -1103,11 +1103,11 @@ CONTAINS IF (PRESENT(counter)) THEN WRITE (str, "(I12)") counter - ELSE IF (PRESENT(rval)) THEN + ELSEIF (PRESENT(rval)) THEN WRITE (str, "(G18.8)") rval - ELSE IF (PRESENT(ival)) THEN + ELSEIF (PRESENT(ival)) THEN WRITE (str, "(I12)") ival - ELSE IF (PRESENT(cval)) THEN + ELSEIF (PRESENT(cval)) THEN WRITE (str, "(A)") TRIM(ADJUSTL(cval)) ELSE WRITE (str, "(A)") "" diff --git a/src/atom_fit.F b/src/atom_fit.F index 0f9bf3b62a..b80ba7e82d 100644 --- a/src/atom_fit.F +++ b/src/atom_fit.F @@ -657,7 +657,7 @@ CONTAINS ntarget = ntarget + 1 wtot = wtot + atom%weight*w_virt/100._dp END IF - ELSE IF (k < atom%state%maxn_occ(l)) THEN + ELSEIF (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 - ELSE IF (k < atom%state%maxn_occ(l)) THEN + ELSEIF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1:2) = w_semi atom%orbitals%wrefchg(k, l, 1:2) = w_semi/100._dp atom%orbitals%crefene(k, l, 1:2) = t_semi diff --git a/src/atom_grb.F b/src/atom_grb.F index e23bccc669..2575d79300 100644 --- a/src/atom_grb.F +++ b/src/atom_grb.F @@ -152,9 +152,8 @@ 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) THEN + IF (ngp <= 0) & CPABORT("# point radial grid < 0") - END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp ! diff --git a/src/atom_kind_orbitals.F b/src/atom_kind_orbitals.F index 30ceb56c06..25c3265e68 100644 --- a/src/atom_kind_orbitals.F +++ b/src/atom_kind_orbitals.F @@ -273,7 +273,7 @@ CONTAINS ! total number of occupied orbitals IF (PRESENT(nocc) .AND. ghost) THEN nocc = 0 - ELSE IF (PRESENT(nocc)) THEN + ELSEIF (PRESENT(nocc)) THEN nocc = 0 DO l = 0, lmat DO k = 1, 7 diff --git a/src/atom_operators.F b/src/atom_operators.F index 6f1e65e81f..3a0e95ab1d 100644 --- a/src/atom_operators.F +++ b/src/atom_operators.F @@ -120,14 +120,14 @@ CONTAINS rc = potential%rcon sc = potential%scon cpot(1:m) = (basis%grid%rad(1:m)/rc)**sc - ELSE IF (potential%conf_type == barrier_conf) THEN + ELSEIF (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 - ELSE IF (basis%grid%rad(i) < rc) THEN + ELSEIF (basis%grid%rad(i) < rc) THEN x = (basis%grid%rad(i) - ron)/om x = 1._dp - x cpot(i) = -6._dp*x**5 + 15._dp*x**4 - 10._dp*x**3 + 1._dp diff --git a/src/atom_optimization.F b/src/atom_optimization.F index 8d4986d7a8..d2ffa6a3fc 100644 --- a/src/atom_optimization.F +++ b/src/atom_optimization.F @@ -221,7 +221,7 @@ CONTAINS IF (nm < 1) nm = history%max_history fmat = a*history%hmat(nnow)%fmat + (1._dp - a)*history%hmat(nm)%fmat END IF - ELSE IF (history%hlen == 1) THEN + ELSEIF (history%hlen == 1) THEN fmat = history%hmat(nnow)%fmat ELSE CPABORT("Length of matrix history hlen < 1") diff --git a/src/atom_output.F b/src/atom_output.F index 8562be639a..59d577c206 100644 --- a/src/atom_output.F +++ b/src/atom_output.F @@ -192,19 +192,16 @@ 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) THEN + IF (atom%energy%exc /= 0._dp) & 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) THEN + IF (atom%energy%eexchange /= 0._dp) & 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) THEN + IF (atom%energy%elsd /= 0._dp) & WRITE (iw, '(T20,A,T61,F20.12)') " Local Spin-potential Energy ::", atom%energy%elsd - END IF WRITE (iw, '(T20,A,T61,F20.12)') " Nonlocal Pseudopotential Energy ::", atom%energy%epnl END IF IF (atom%potential%confinement) THEN diff --git a/src/atom_pseudo.F b/src/atom_pseudo.F index c77de88e67..7064b7a535 100644 --- a/src/atom_pseudo.F +++ b/src/atom_pseudo.F @@ -257,10 +257,10 @@ CONTAINS ne = state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSE IF (ne == 2._dp*nm) THEN !closed shell + ELSEIF (ne == 2._dp*nm) THEN !closed shell state%occa(l, k) = nm state%occb(l, k) = nm - ELSE IF (state%multiplicity == -2) THEN !High spin case + ELSEIF (state%multiplicity == -2) THEN !High spin case state%occa(l, k) = MIN(ne, nm) state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_set_basis.F b/src/atom_set_basis.F index f66006b6d4..767bc5a76e 100644 --- a/src/atom_set_basis.F +++ b/src/atom_set_basis.F @@ -204,7 +204,7 @@ CONTAINS basis%ddbf(k, i, l) = (REAL(l*(l - 1), dp)*rk**(l - 2) - & 2._dp*al*REAL(2*l + 1, dp)*rk**(l) + 4._dp*al*rk**(l + 2))*ear END DO - ELSE IF (basis%basis_type == CGTO_BASIS) THEN + ELSEIF (basis%basis_type == CGTO_BASIS) THEN DO k = 1, nr rk = basis%grid%rad(k) ear = EXP(-al*basis%grid%rad(k)**2) diff --git a/src/atom_sgp.F b/src/atom_sgp.F index 2289ec8964..178e7e93bd 100644 --- a/src/atom_sgp.F +++ b/src/atom_sgp.F @@ -122,7 +122,7 @@ CONTAINS ! generate the transformed potentials IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, basis) - ELSE IF (is_upf) THEN + ELSEIF (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) - ELSE IF (is_upf) THEN + ELSEIF (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) - ELSE IF (is_upf) THEN + ELSEIF (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) - ELSE IF (is_upf) THEN + ELSEIF (is_upf) THEN CALL upfints(core%op, hnl%op, atom_ref%basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") diff --git a/src/atom_types.F b/src/atom_types.F index a1a2a54115..502369a13b 100644 --- a/src/atom_types.F +++ b/src/atom_types.F @@ -414,9 +414,8 @@ 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) THEN + IF (ngp <= 0) & 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. @@ -841,9 +840,8 @@ CONTAINS CALL allocate_grid_atom(gbasis%grid) ngp = SIZE(r) quadtype = do_gapw_log - IF (ngp <= 0) THEN + IF (ngp <= 0) & CPABORT("The number of radial grid points must be greater than zero.") - END IF CALL create_grid_atom(gbasis%grid, ngp, 1, 1, 0, quadtype) gbasis%grid%nr = ngp gbasis%grid%rad(:) = r(:) diff --git a/src/atom_upf.F b/src/atom_upf.F index 8c226de646..3a19e15d04 100644 --- a/src/atom_upf.F +++ b/src/atom_upf.F @@ -218,39 +218,39 @@ CONTAINS IF (nametag(2:8) == "PP_INFO") THEN CPASSERT(nametag(9:9) == ">") CALL upf_info_section(parser, pot) - ELSE IF (nametag(2:10) == "PP_HEADER") THEN + ELSEIF (nametag(2:10) == "PP_HEADER") THEN IF (.NOT. (nametag(11:11) == ">")) THEN CALL upf_header_option(parser, pot) END IF - ELSE IF (nametag(2:8) == "PP_MESH") THEN + ELSEIF (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) - ELSE IF (nametag(2:8) == "PP_NLCC") THEN + ELSEIF (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 - ELSE IF (nametag(2:9) == "PP_LOCAL") THEN + ELSEIF (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 - ELSE IF (nametag(2:12) == "PP_NONLOCAL") THEN + ELSEIF (nametag(2:12) == "PP_NONLOCAL") THEN CPASSERT(nametag(13:13) == ">") CALL upf_nonlocal_section(parser, pot) - ELSE IF (nametag(2:13) == "PP_SEMILOCAL") THEN + ELSEIF (nametag(2:13) == "PP_SEMILOCAL") THEN CALL upf_semilocal_section(parser, pot) - ELSE IF (nametag(2:9) == "PP_PSWFC") THEN + ELSEIF (nametag(2:9) == "PP_PSWFC") THEN ! skip section for now - ELSE IF (nametag(2:11) == "PP_RHOATOM") THEN + ELSEIF (nametag(2:11) == "PP_RHOATOM") THEN ! skip section for now - ELSE IF (nametag(2:7) == "PP_PAW") THEN + ELSEIF (nametag(2:7) == "PP_PAW") THEN ! skip section for now - ELSE IF (nametag(2:6) == "/UPF>") THEN + ELSEIF (nametag(2:6) == "/UPF>") THEN EXIT END IF END IF @@ -856,7 +856,7 @@ CONTAINS END IF IF (icount > ms) EXIT END DO - ELSE IF (string(1:15) == "") THEN + ELSEIF (string(1:15) == "") THEN EXIT ELSE ! diff --git a/src/atom_utils.F b/src/atom_utils.F index ae92b95ee4..8465ff388a 100644 --- a/src/atom_utils.F +++ b/src/atom_utils.F @@ -2549,7 +2549,7 @@ CONTAINS ja = ibptr(ia, la) jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) + sab(1:nna, 1:nnb) - ELSE IF (basis%basis_type == CGTO_BASIS) THEN + ELSEIF (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) - ELSE IF (basis%basis_type == CGTO_BASIS) THEN + ELSEIF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) diff --git a/src/atoms_input.F b/src/atoms_input.F index 1156efb330..4e3b87bbf4 100644 --- a/src/atoms_input.F +++ b/src/atoms_input.F @@ -144,9 +144,8 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & 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 @@ -196,26 +195,24 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & 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) THEN + IF (LEN_TRIM(error_message) /= 0) & 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) @@ -346,9 +343,8 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & 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)) @@ -397,9 +393,8 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & CPABORT("incorrectly formatted line in coord section'"//line_att//"'") - END IF IF (wrd == 1) THEN at_name_c(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name_c(ishell)) diff --git a/src/auto_basis.F b/src/auto_basis.F index 23546df6e7..94bccf5995 100644 --- a/src/auto_basis.F +++ b/src/auto_basis.F @@ -61,7 +61,7 @@ CONTAINS INTEGER, INTENT(IN), OPTIONAL :: basis_sort CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname, kname + CHARACTER(LEN=default_string_length) :: bsname 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, econf) + NULLIFY (orb_basis_set) IF (.NOT. PRESENT(basis_type)) THEN CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") ELSE @@ -106,15 +106,6 @@ 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)) @@ -245,7 +236,7 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: exact_1c_terms, tda_kernel CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname, kname + CHARACTER(LEN=default_string_length) :: bsname INTEGER :: i, j, l, laux, linc, lm, lmax, lval, n1, & n2, nsets, z INTEGER, DIMENSION(0:18) :: nval @@ -276,21 +267,12 @@ CONTAINS END IF ! CPASSERT(.NOT. ASSOCIATED(lri_aux_basis_set)) - NULLIFY (orb_basis_set, econf) + NULLIFY (orb_basis_set) CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") IF (ASSOCIATED(orb_basis_set)) THEN CALL get_basis_keyfigures(orb_basis_set, lmax, zmin, zmax, zeff) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) - IF (.NOT. ASSOCIATED(econf)) THEN - CALL get_qs_kind(qs_kind, name=kname) - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS LRI_AUX cannot process atom kind "// & - "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & - "definition of potential or electron configuration; "// & - "consider setting keyword ELEC_CONF explicitly for "// & - "GHOST atom kind that has assigned a basis set") - END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) diff --git a/src/base/base_hooks.F b/src/base/base_hooks.F index d31f199528..dd7931e047 100644 --- a/src/base/base_hooks.F +++ b/src/base/base_hooks.F @@ -145,9 +145,8 @@ CONTAINS IF (ASSOCIATED(timestop_hook)) THEN CALL timestop_hook(handle) ELSE - IF (handle /= -1) THEN + IF (handle /= -1) & CALL cp_abort(cp__l("base_hooks.F", __LINE__), "Got wrong handle") - END IF END IF END SUBROUTINE timestop diff --git a/src/base/machine.F b/src/base/machine.F index a2e21f7fa0..9cadaa31a7 100644 --- a/src/base/machine.F +++ b/src/base/machine.F @@ -741,17 +741,14 @@ CONTAINS ! on a posix system LOGNAME should be defined CALL get_environment_variable("LOGNAME", value=user, status=istat) ! nope, check alternative - IF (istat /= 0) THEN + IF (istat /= 0) & CALL get_environment_variable("USER", value=user, status=istat) - END IF ! nope, check alternative - IF (istat /= 0) THEN + IF (istat /= 0) & CALL get_environment_variable("USERNAME", value=user, status=istat) - END IF ! fall back - IF (istat /= 0) THEN + IF (istat /= 0) & user = "" - END IF END SUBROUTINE m_getlog diff --git a/src/bse_full_diag.F b/src/bse_full_diag.F index cf267f5bb4..b2d0ad2626 100644 --- a/src/bse_full_diag.F +++ b/src/bse_full_diag.F @@ -22,10 +22,8 @@ MODULE bse_full_diag exciton_descr_type,& get_exciton_descriptors,& get_oscillator_strengths - USE bse_util, ONLY: assemble_joint_ov_slab,& - comp_eigvec_coeff_BSE,& + USE bse_util, ONLY: 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,& @@ -41,11 +39,9 @@ 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,& @@ -96,44 +92,32 @@ CONTAINS homo, virtual, dimen_RI, mp2_env, & para_env, qs_env) - TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ij_bse, & + TYPE(cp_fm_type), 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(:), INTENT(IN) :: Eigenval - INTEGER, INTENT(IN) :: unit_nr - INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual - INTEGER, INTENT(IN) :: dimen_RI + REAL(KIND=dp), DIMENSION(:) :: Eigenval + INTEGER, INTENT(IN) :: unit_nr, homo, virtual, dimen_RI TYPE(mp2_type), INTENT(INOUT) :: mp2_env TYPE(mp_para_env_type), INTENT(INOUT) :: para_env TYPE(qs_environment_type), POINTER :: qs_env CHARACTER(LEN=*), PARAMETER :: routineN = 'create_A' - INTEGER :: a_virt_row, handle, i_occ_row, i_row_global, ii, isp, j_col_global, jj, k_isp, & - k_ov, n_ov_joint, ncol_local_A, nrow_local_A, nspins, sizeeigen - INTEGER, ALLOCATABLE, DIMENSION(:) :: eig_offsets, n_ov, offsets + INTEGER :: a_virt_row, handle, i_occ_row, & + i_row_global, ii, j_col_global, jj, & + ncol_local_A, nrow_local_A, sizeeigen 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_S_joint, & - fm_struct_W - TYPE(cp_fm_type) :: fm_A_copy, fm_S_joint, fm_W + TYPE(cp_fm_struct_type), POINTER :: fm_struct_A, fm_struct_W + TYPE(cp_fm_type) :: fm_A_copy, 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 @@ -149,12 +133,6 @@ 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 @@ -171,141 +149,115 @@ 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(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_struct_create(fm_struct_A, context=fm_mat_S_ia_bse%matrix_struct%context, nrow_global=homo*virtual, & + ncol_global=homo*virtual, para_env=fm_mat_S_ia_bse%matrix_struct%para_env) CALL cp_fm_create(fm_A, fm_struct_A, name="fm_A_iajb") CALL cp_fm_set_all(fm_A, 0.0_dp) - ! 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 + IF (tddfpt_control%do_bse_w_only) 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 - ! Create A matrix from GW Energies, v_ia,jb and W_ij,ab - ! v_ia,jb = \sum_P B^P_ia B^P_jb (Coulomb) + CALL cp_fm_struct_create(fm_struct_W, context=fm_mat_S_ab_bse%matrix_struct%context, nrow_global=homo**2, & + ncol_global=virtual**2, para_env=fm_mat_S_ab_bse%matrix_struct%para_env) + CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ijab") + CALL cp_fm_set_all(fm_W, 0.0_dp) + + ! Create A matrix from GW Energies, v_ia,jb and W_ij,ab (different blacs_env!) + ! v_ia,jb, which is directly initialized in A (with a factor of alpha) + ! v_ia,jb = \sum_P B^P_ia B^P_jb IF ((.NOT. tddfpt_control%do_bse) .AND. (.NOT. tddfpt_control%do_bse_w_only)) THEN - IF (nspins > 1) THEN - ! Assemble joint ia-slab for a single Coulomb gemm across all spin blocks - CALL cp_fm_struct_create(fm_struct_S_joint, & - context=fm_mat_S_ia_bse(1)%matrix_struct%context, & - nrow_global=dimen_RI, ncol_global=n_ov_joint, & - para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) - CALL cp_fm_create(fm_S_joint, fm_struct_S_joint, name="fm_S_ia_joint") - CALL cp_fm_set_all(fm_S_joint, 0.0_dp) - CALL assemble_joint_ov_slab(fm_mat_S_ia_bse, offsets, n_ov, dimen_RI, fm_S_joint) - CALL parallel_gemm(transa="T", transb="N", m=n_ov_joint, n=n_ov_joint, k=dimen_RI, & - alpha=alpha, matrix_a=fm_S_joint, matrix_b=fm_S_joint, beta=0.0_dp, & - matrix_c=fm_A) - CALL cp_fm_release(fm_S_joint) - CALL cp_fm_struct_release(fm_struct_S_joint) - ELSE - CALL parallel_gemm(transa="T", transb="N", m=homo(1)*virtual(1), n=homo(1)*virtual(1), & - k=dimen_RI, alpha=alpha, & - matrix_a=fm_mat_S_ia_bse(1), matrix_b=fm_mat_S_ia_bse(1), & - beta=0.0_dp, matrix_c=fm_A) - END IF + CALL parallel_gemm(transa="T", transb="N", m=homo*virtual, n=homo*virtual, k=dimen_RI, alpha=alpha, & + matrix_a=fm_mat_S_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, & + matrix_c=fm_A) 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 - ! W term on sigma-diagonal blocks only: W^sigma_ij,ab = sum_P barB^P_ij B^P_ab - ! offsets(isp) places each block at the correct position in joint A. - ! For nspins=1: offsets(1)=0, equivalent to the original code. - DO isp = 1, nspins - IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN - CALL cp_fm_struct_create(fm_struct_W, context=fm_mat_S_ab_bse(isp)%matrix_struct%context, & - nrow_global=homo(isp)**2, ncol_global=virtual(isp)**2, & - para_env=fm_mat_S_ab_bse(isp)%matrix_struct%para_env) - CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ijab") - CALL cp_fm_set_all(fm_W, 0.0_dp) - !W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab - CALL parallel_gemm(transa="T", transb="N", m=homo(isp)**2, n=virtual(isp)**2, & - k=dimen_RI, alpha=alpha_screening, & - matrix_a=fm_mat_S_bar_ij_bse(isp), matrix_b=fm_mat_S_ab_bse(isp), & - beta=0.0_dp, matrix_c=fm_W) - reordering = [1, 3, 2, 4] - CALL fm_general_add_bse(fm_A, fm_W, -1.0_dp, homo(isp), virtual(isp), & - virtual(isp), virtual(isp), unit_nr, reordering, mp2_env, & - row_offset=offsets(isp), col_offset=offsets(isp)) - IF (nspins == 1 .AND. tddfpt_control%do_bse_w_only) THEN - CALL fm_general_add_bse(fm_A_copy, fm_W, -1.0_dp, homo(1), virtual(1), & - virtual(1), virtual(1), unit_nr, reordering, mp2_env) - END IF - ! W and A stash for TDDFPT path (closed-shell only; open-shell deferred) - IF (nspins == 1) THEN - IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. & - tddfpt_control%do_bse_gw_only) THEN - NULLIFY (ex_env) - CALL get_qs_env(qs_env, exstate_env=ex_env) - IF (.NOT. tddfpt_control%do_bse_gw_only) THEN - ALLOCATE (ex_env%bse_w_matrix_MO(1, 1)) - ALLOCATE (ex_env%bse_a_matrix_MO(1, 1)) - CALL cp_fm_create(ex_env%bse_w_matrix_MO(1, 1), fm_struct_W) - CALL cp_fm_create(ex_env%bse_a_matrix_MO(1, 1), fm_struct_A) - CALL cp_fm_to_fm(fm_W, ex_env%bse_w_matrix_MO(1, 1)) - IF (tddfpt_control%do_bse_w_only) THEN - CALL cp_fm_to_fm(fm_A_copy, ex_env%bse_a_matrix_MO(1, 1)) - ELSE - CALL cp_fm_to_fm(fm_A, ex_env%bse_a_matrix_MO(1, 1)) - END IF - END IF - END IF - END IF - CALL cp_fm_release(fm_W) - CALL cp_fm_struct_release(fm_struct_W) - END IF - END DO + ! If infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals + IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN + !W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab + CALL parallel_gemm(transa="T", transb="N", m=homo**2, n=virtual**2, k=dimen_RI, alpha=alpha_screening, & + matrix_a=fm_mat_S_bar_ij_bse, matrix_b=fm_mat_S_ab_bse, beta=0.0_dp, & + matrix_c=fm_W) + END IF 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) - ! Get local row/col indices for direct diagonal access - CALL cp_fm_get_info(matrix=fm_A, nrow_local=nrow_local_A, ncol_local=ncol_local_A, & - row_indices=row_indices_A, col_indices=col_indices_A) + ! We start by moving data from local parts of W_ij,ab to the full matrix A_ia,jb using buffers + CALL cp_fm_get_info(matrix=fm_A, & + nrow_local=nrow_local_A, & + ncol_local=ncol_local_A, & + row_indices=row_indices_A, & + col_indices=col_indices_A) + ! Writing -1.0_dp * W_ij,ab to A_ia,jb, i.e. beta = -1.0_dp, + ! W_ij,ab: nrow_secidx_in = homo, ncol_secidx_in = virtual + ! A_ia,jb: nrow_secidx_out = virtual, ncol_secidx_out = virtual - !Add (ε_a-ε_i) on the diagonal of each sigma-block; cross-spin blocks have no ε contribution. + ! If infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals + IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN + reordering = [1, 3, 2, 4] + CALL fm_general_add_bse(fm_A, fm_W, -1.0_dp, homo, virtual, & + virtual, virtual, unit_nr, reordering, mp2_env) + IF (tddfpt_control%do_bse_w_only) THEN + CALL fm_general_add_bse(fm_A_copy, fm_W, -1.0_dp, homo, virtual, & + virtual, virtual, unit_nr, reordering, mp2_env) + END IF + END IF + !full matrix W is not needed anymore, release it to save memory + IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. & + tddfpt_control%do_bse_gw_only) THEN + NULLIFY (ex_env) + CALL get_qs_env(qs_env, exstate_env=ex_env) + IF (.NOT. tddfpt_control%do_bse_gw_only) THEN + ALLOCATE (ex_env%bse_w_matrix_MO(1, 1)) ! for now only closed-shell + ALLOCATE (ex_env%bse_a_matrix_MO(1, 1)) ! for now only closed-shell + CALL cp_fm_create(ex_env%bse_w_matrix_MO(1, 1), fm_struct_W) + CALL cp_fm_create(ex_env%bse_a_matrix_MO(1, 1), fm_struct_A) + CALL cp_fm_to_fm(fm_W, ex_env%bse_w_matrix_MO(1, 1)) + IF (tddfpt_control%do_bse_w_only) THEN + CALL cp_fm_to_fm(fm_A_copy, ex_env%bse_a_matrix_MO(1, 1)) + ELSE + CALL cp_fm_to_fm(fm_A, ex_env%bse_a_matrix_MO(1, 1)) + END IF + END IF + END IF + CALL cp_fm_release(fm_W) + IF (tddfpt_control%do_bse_w_only) CALL cp_fm_release(fm_A_copy) + + !Now add the energy differences (ε_a-ε_i) on the diagonal (i.e. δ_ij δ_ab) of A_ia,jb IF (.NOT. tddfpt_control%do_bse) THEN - DO ii = 1, nrow_local_A - i_row_global = row_indices_A(ii) - DO jj = 1, ncol_local_A - j_col_global = col_indices_A(jj) - IF (i_row_global == j_col_global) THEN - ! Decode spin: isp such that i_row_global in [offsets(isp)+1, offsets(isp)+n_ov(isp)] - isp = nspins - DO k_isp = 1, nspins - 1 - IF (i_row_global <= offsets(k_isp) + n_ov(k_isp)) THEN - isp = k_isp - EXIT - END IF - END DO - k_ov = i_row_global - offsets(isp) - i_occ_row = (k_ov - 1)/virtual(isp) + 1 - a_virt_row = MOD(k_ov - 1, virtual(isp)) + 1 - eigen_diff = Eigenval(eig_offsets(isp) + a_virt_row + homo(isp)) - & - Eigenval(eig_offsets(isp) + i_occ_row) - fm_A%local_data(ii, jj) = fm_A%local_data(ii, jj) + eigen_diff - END IF - END DO + DO ii = 1, nrow_local_A + + i_row_global = row_indices_A(ii) + + DO jj = 1, ncol_local_A + + j_col_global = col_indices_A(jj) + + IF (i_row_global == j_col_global) THEN + i_occ_row = (i_row_global - 1)/virtual + 1 + a_virt_row = MOD(i_row_global - 1, virtual) + 1 + eigen_diff = Eigenval(a_virt_row + homo) - Eigenval(i_occ_row) + fm_A%local_data(ii, jj) = fm_A%local_data(ii, jj) + eigen_diff + + END IF END DO + END DO END IF - ! GW eigenvalue stash for TDDFPT path (closed-shell only) - IF (nspins == 1) THEN - IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. & - tddfpt_control%do_bse_gw_only) THEN - sizeeigen = SIZE(Eigenval) - ALLOCATE (ex_env%gw_eigen(sizeeigen)) - ex_env%gw_eigen(:) = Eigenval(:) - END IF + IF (tddfpt_control%do_bse .OR. tddfpt_control%do_bse_w_only .OR. tddfpt_control%do_bse_gw_only) THEN + sizeeigen = SIZE(Eigenval) + ALLOCATE (ex_env%gw_eigen(sizeeigen)) ! for now only closed-shell + ex_env%gw_eigen(:) = Eigenval(:) END IF CALL cp_fm_struct_release(fm_struct_A) - DEALLOCATE (n_ov, offsets, eig_offsets) + CALL cp_fm_struct_release(fm_struct_W) CALL cp_blacs_env_release(blacs_env) @@ -331,41 +283,32 @@ 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), DIMENSION(:), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ia_bse + TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_bar_ia_bse TYPE(cp_fm_type), INTENT(INOUT) :: fm_B - INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual - INTEGER, INTENT(IN) :: dimen_RI, unit_nr + INTEGER, INTENT(IN) :: homo, virtual, dimen_RI, unit_nr TYPE(mp2_type), INTENT(INOUT) :: mp2_env CHARACTER(LEN=*), PARAMETER :: routineN = 'create_B' - INTEGER :: handle, isp, n_ov_joint, nspins - INTEGER, ALLOCATABLE, DIMENSION(:) :: n_ov, offsets + INTEGER :: handle INTEGER, DIMENSION(4) :: reordering REAL(KIND=dp) :: alpha, alpha_screening - TYPE(cp_fm_struct_type), POINTER :: fm_struct_B, fm_struct_S_joint, & - fm_struct_W - TYPE(cp_fm_type) :: fm_S_joint, fm_W + TYPE(cp_fm_struct_type), POINTER :: fm_struct_v + TYPE(cp_fm_type) :: 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 - ! 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. + ! Determines factor of exchange term, depending on requested spin configuration (cf. input_constants.F) 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 @@ -373,68 +316,40 @@ CONTAINS alpha_screening = 1.0_dp END IF - ! Joint B over all spin blocks: B_ia,jb = alpha*(ia|bj) - W^sigma_ib,aj (W spin-diagonal) - NULLIFY (fm_struct_B) - CALL cp_fm_struct_create(fm_struct_B, context=fm_mat_S_ia_bse(1)%matrix_struct%context, & - nrow_global=n_ov_joint, ncol_global=n_ov_joint, & - para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) - CALL cp_fm_create(fm_B, fm_struct_B, name="fm_B_iajb") + CALL cp_fm_struct_create(fm_struct_v, context=fm_mat_S_ia_bse%matrix_struct%context, nrow_global=homo*virtual, & + ncol_global=homo*virtual, para_env=fm_mat_S_ia_bse%matrix_struct%para_env) + CALL cp_fm_create(fm_B, fm_struct_v, name="fm_B_iajb") CALL cp_fm_set_all(fm_B, 0.0_dp) - ! Coulomb v_ia,jb = sum_P B^P_ia B^P_jb (= (ia|bj)); cross-spin blocks filled automatically. - IF (nspins > 1) THEN - NULLIFY (fm_struct_S_joint) - CALL cp_fm_struct_create(fm_struct_S_joint, & - context=fm_mat_S_ia_bse(1)%matrix_struct%context, & - nrow_global=dimen_RI, ncol_global=n_ov_joint, & - para_env=fm_mat_S_ia_bse(1)%matrix_struct%para_env) - CALL cp_fm_create(fm_S_joint, fm_struct_S_joint, name="fm_S_ia_joint") - CALL cp_fm_set_all(fm_S_joint, 0.0_dp) - CALL assemble_joint_ov_slab(fm_mat_S_ia_bse, offsets, n_ov, dimen_RI, fm_S_joint) - CALL parallel_gemm(transa="T", transb="N", m=n_ov_joint, n=n_ov_joint, k=dimen_RI, & - alpha=alpha, matrix_a=fm_S_joint, matrix_b=fm_S_joint, beta=0.0_dp, & - matrix_c=fm_B) - CALL cp_fm_release(fm_S_joint) - CALL cp_fm_struct_release(fm_struct_S_joint) - ELSE - CALL parallel_gemm(transa="T", transb="N", m=homo(1)*virtual(1), n=homo(1)*virtual(1), & - k=dimen_RI, alpha=alpha, & - matrix_a=fm_mat_S_ia_bse(1), matrix_b=fm_mat_S_ia_bse(1), & - beta=0.0_dp, matrix_c=fm_B) - END IF + CALL cp_fm_create(fm_W, fm_struct_v, name="fm_W_ibaj") + CALL cp_fm_set_all(fm_W, 0.0_dp) 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) - ! 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 infinite screening is applied, fm_W is simply 0 - Otherwise it needs to be computed from 3c integrals IF (mp2_env%bse%screening_method /= bse_screening_rpa) THEN - DO isp = 1, nspins - NULLIFY (fm_struct_W) - CALL cp_fm_struct_create(fm_struct_W, & - context=fm_mat_S_ia_bse(isp)%matrix_struct%context, & - nrow_global=homo(isp)*virtual(isp), & - ncol_global=homo(isp)*virtual(isp), & - para_env=fm_mat_S_ia_bse(isp)%matrix_struct%para_env) - CALL cp_fm_create(fm_W, fm_struct_W, name="fm_W_ibaj") - CALL cp_fm_set_all(fm_W, 0.0_dp) - CALL parallel_gemm(transa="T", transb="N", m=homo(isp)*virtual(isp), & - n=homo(isp)*virtual(isp), k=dimen_RI, alpha=alpha_screening, & - matrix_a=fm_mat_S_bar_ia_bse(isp), matrix_b=fm_mat_S_ia_bse(isp), & - beta=0.0_dp, matrix_c=fm_W) - reordering = [1, 4, 3, 2] - CALL fm_general_add_bse(fm_B, fm_W, -1.0_dp, virtual(isp), virtual(isp), & - virtual(isp), virtual(isp), unit_nr, reordering, mp2_env, & - row_offset=offsets(isp), col_offset=offsets(isp)) - CALL cp_fm_release(fm_W) - CALL cp_fm_struct_release(fm_struct_W) - END DO + ! W_ib,aj = \sum_P \bar{B}^P_ib B^P_aj + CALL parallel_gemm(transa="T", transb="N", m=homo*virtual, n=homo*virtual, k=dimen_RI, alpha=alpha_screening, & + matrix_a=fm_mat_S_bar_ia_bse, matrix_b=fm_mat_S_ia_bse, beta=0.0_dp, & + matrix_c=fm_W) + + ! from W_ib,ja to A_ia,jb (formally: W_ib,aj, but our internal indexorder is different) + ! Writing -1.0_dp * W_ib,ja to A_ia,jb, i.e. beta = -1.0_dp, + ! W_ib,ja: nrow_secidx_in = virtual, ncol_secidx_in = virtual + ! A_ia,jb: nrow_secidx_out = virtual, ncol_secidx_out = virtual + reordering = [1, 4, 3, 2] + CALL fm_general_add_bse(fm_B, fm_W, -1.0_dp, virtual, virtual, & + virtual, virtual, unit_nr, reordering, mp2_env) END IF - CALL cp_fm_struct_release(fm_struct_B) - DEALLOCATE (n_ov, offsets) - + CALL cp_fm_release(fm_W) + CALL cp_fm_struct_release(fm_struct_v) CALL timestop(handle) END SUBROUTINE create_B @@ -449,18 +364,20 @@ 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, & - unit_nr, mp2_env, diag_est) + homo, virtual, 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) :: unit_nr + INTEGER, INTENT(IN) :: homo, virtual, unit_nr TYPE(mp2_type), INTENT(INOUT) :: mp2_env REAL(KIND=dp), INTENT(IN) :: diag_est @@ -529,7 +446,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) - CALL cp_fm_get_info(fm_A, nrow_global=dim_mat) + dim_mat = homo*virtual 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) @@ -577,7 +494,7 @@ CONTAINS unit_nr, diag_est, mp2_env, qs_env, mo_coeff) TYPE(cp_fm_type), INTENT(INOUT) :: fm_C - INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred + INTEGER, 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 @@ -587,7 +504,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'diagonalize_C' - INTEGER :: diag_info, handle, n_ov_joint, nspins + INTEGER :: diag_info, handle 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, & @@ -595,9 +512,6 @@ 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.' @@ -607,7 +521,7 @@ CONTAINS !Now: Diagonalize it CALL cp_fm_create(fm_eigvec_Z, fm_C%matrix_struct) - ALLOCATE (Exc_ens(n_ov_joint)) + ALLOCATE (Exc_ens(homo*virtual)) CALL choose_eigv_solver(fm_C, fm_eigvec_Z, Exc_ens, diag_info) @@ -639,7 +553,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=n_ov_joint, n=n_ov_joint, k=n_ov_joint, alpha=1.0_dp, & + CALL parallel_gemm(transa="N", transb="N", m=homo*virtual, n=homo*virtual, k=homo*virtual, 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) @@ -649,7 +563,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=n_ov_joint, n=n_ov_joint, k=n_ov_joint, alpha=1.0_dp, & + CALL parallel_gemm(transa="N", transb="N", m=homo*virtual, n=homo*virtual, k=homo*virtual, 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) @@ -674,15 +588,9 @@ CONTAINS CALL cp_fm_release(fm_mat_eigvec_transform_diff) CALL cp_fm_release(fm_mat_eigvec_transform_sum) - IF (nspins == 1) THEN - CALL postprocess_bse(Exc_ens, fm_eigvec_X, mp2_env, qs_env, mo_coeff, & - homo(1), virtual(1), homo_irred(1), unit_nr, & - .FALSE., fm_eigvec_Y) - ELSE - ! Open-shell ABBA: helper forms X+Y internally and prints amplitudes (X and Y). - CALL bse_open_shell_optical(Exc_ens, fm_eigvec_X, homo, virtual, homo_irred, & - .FALSE., qs_env, mo_coeff, mp2_env, unit_nr, fm_eigvec_Y) - END IF + CALL postprocess_bse(Exc_ens, fm_eigvec_X, mp2_env, qs_env, mo_coeff, & + homo, virtual, homo_irred, unit_nr, & + .FALSE., fm_eigvec_Y) DEALLOCATE (Exc_ens) CALL cp_fm_release(fm_eigvec_X) @@ -708,8 +616,7 @@ CONTAINS unit_nr, diag_est, mp2_env, qs_env, mo_coeff) TYPE(cp_fm_type), INTENT(INOUT) :: fm_A - INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred - INTEGER, INTENT(IN) :: unit_nr + INTEGER, INTENT(IN) :: homo, virtual, homo_irred, unit_nr REAL(KIND=dp), INTENT(IN) :: diag_est TYPE(mp2_type), INTENT(INOUT) :: mp2_env TYPE(qs_environment_type), POINTER :: qs_env @@ -717,23 +624,23 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'diagonalize_A' - INTEGER :: diag_info, handle, n_ov_joint, nspins + INTEGER :: diag_info, handle REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Exc_ens TYPE(cp_fm_type) :: fm_eigvec CALL timeset(routineN, handle) - nspins = SIZE(homo) - n_ov_joint = SUM(homo*virtual) - + !Continue with formatting of subroutine create_A 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(n_ov_joint)) + ALLOCATE (Exc_ens(homo*virtual)) CALL choose_eigv_solver(fm_A, fm_eigvec, Exc_ens, diag_info) @@ -742,13 +649,8 @@ CONTAINS "Diagonalization of A failed in TDA-BSE") END IF - IF (nspins == 1) THEN - CALL postprocess_bse(Exc_ens, fm_eigvec, mp2_env, qs_env, mo_coeff, & - homo(1), virtual(1), homo_irred(1), unit_nr, .TRUE.) - ELSE - CALL bse_open_shell_optical(Exc_ens, fm_eigvec, homo, virtual, homo_irred, & - .TRUE., qs_env, mo_coeff, mp2_env, unit_nr) - END IF + CALL postprocess_bse(Exc_ens, fm_eigvec, mp2_env, qs_env, mo_coeff, & + homo, virtual, homo_irred, unit_nr, .TRUE.) CALL cp_fm_release(fm_eigvec) DEALLOCATE (Exc_ens) @@ -757,154 +659,6 @@ 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 ... @@ -1029,7 +783,7 @@ CONTAINS info_approximation, mp2_env, unit_nr) ! Print single particle transition amplitudes, i.e. components of eigenvectors X and Y - CALL print_transition_amplitudes(fm_eigvec_X, [homo], [virtual], [homo_irred], & + CALL print_transition_amplitudes(fm_eigvec_X, homo, virtual, homo_irred, & info_approximation, mp2_env, unit_nr, fm_eigvec_Y) ! Prints optical properties, if state is a singlet diff --git a/src/bse_main.F b/src/bse_main.F index c47efa401f..0aea47722c 100644 --- a/src/bse_main.F +++ b/src/bse_main.F @@ -23,16 +23,12 @@ 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_create,& - cp_fm_release,& - cp_fm_to_fm,& + USE cp_fm_types, ONLY: cp_fm_release,& cp_fm_type USE cp_log_handling, ONLY: cp_get_default_logger,& cp_logger_type @@ -88,14 +84,13 @@ 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), DIMENSION(:), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_ij_bse, & + TYPE(cp_fm_type), 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 - INTEGER, DIMENSION(:), INTENT(IN) :: bse_lev_virt + INTEGER, INTENT(IN) :: dimen_RI, dimen_RI_red, bse_lev_virt TYPE(group_dist_d1_type), INTENT(IN) :: gd_array INTEGER, INTENT(IN) :: color_sub TYPE(mp2_type) :: mp2_env @@ -105,24 +100,16 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'start_bse_calculation' - 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 + INTEGER :: handle, homo_red, virtual_red 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, Eigenval_reduced_1, & - Eigenval_reduced_2, & - Eigenval_reduced_joint + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Eigenval_reduced 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_Q_copy, & - fm_sqrt_A_minus_B - TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_S_ab_trunc_arr, & - fm_mat_S_bar_ia_bse_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ia_trunc_arr, & - fm_mat_S_ij_trunc_arr + TYPE(cp_fm_type) :: fm_A_BSE, fm_B_BSE, fm_C_BSE, fm_inv_sqrt_A_minus_B, fm_mat_S_ab_trunc, & + fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, & + fm_sqrt_A_minus_B TYPE(cp_logger_type), POINTER :: logger TYPE(dft_control_type), POINTER :: dft_control TYPE(mp_para_env_type), POINTER :: para_env @@ -130,8 +117,7 @@ CONTAINS CALL timeset(routineN, handle) - nspins = SIZE(homo) - para_env => fm_mat_S_ia_bse(1)%matrix_struct%para_env + para_env => fm_mat_S_ia_bse%matrix_struct%para_env my_do_fulldiag = .FALSE. my_do_iterat_diag = .FALSE. @@ -165,202 +151,117 @@ CONTAINS mp2_env%bse%bse_debug_print = .TRUE. END IF - CALL fm_mat_S_ia_bse(1)%matrix_struct%para_env%sync() - - ALLOCATE (homo_red_arr(nspins), virt_red_arr(nspins)) - ALLOCATE (fm_mat_S_ia_trunc_arr(nspins), fm_mat_S_ij_trunc_arr(nspins), fm_mat_S_ab_trunc_arr(nspins)) - ALLOCATE (fm_mat_S_bar_ia_bse_arr(nspins), fm_mat_S_bar_ij_bse_arr(nspins)) - - 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) - - ALLOCATE (n_ov_arr(nspins), offsets_arr(nspins)) - CALL get_bse_spin_block_layout(homo_red_arr, virt_red_arr, n_ov_arr, offsets_arr, n_ov_joint) - - CALL adapt_BSE_input_params(n_ov_joint, 1, unit_nr, mp2_env, qs_env) - - ! 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_A(fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr, & - fm_A_BSE, Eigenval_reduced_joint, unit_nr, & - homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) - ELSE - CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ab_trunc_arr, & - fm_A_BSE, Eigenval_reduced_joint, unit_nr, & - homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) - END IF - IF (my_do_abba) THEN - IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & - mp2_env%bse%screening_method == bse_screening_alpha) THEN - CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_ia_trunc_arr, fm_B_BSE, & - homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) - ELSE - CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ia_bse_arr, fm_B_BSE, & - homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) - END IF - CALL create_hermitian_form_of_ABBA(fm_A_BSE, fm_B_BSE, fm_C_BSE, & - fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - unit_nr, mp2_env, diag_runtime_est) - CALL cp_fm_release(fm_B_BSE) - END IF - NULLIFY (dft_control, tddfpt_control) - CALL get_qs_env(qs_env, dft_control=dft_control) - tddfpt_control => dft_control%tddfpt2_control - ! 4th arg (homo_irred) = full per-spin occupied counts: per-spin absolute-MO labels for - ! the amplitude table, and N_e = SUM(homo_irred) for the TRK print. - IF (my_do_tda .AND. (.NOT. tddfpt_control%do_bse)) THEN - CALL diagonalize_A(fm_A_BSE, homo_red_arr, virt_red_arr, homo, & - unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) - END IF - CALL cp_fm_release(fm_A_BSE) - IF (my_do_abba) THEN - CALL diagonalize_C(fm_C_BSE, homo_red_arr, virt_red_arr, homo, & - fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) - CALL cp_fm_release(fm_C_BSE) - END IF - END IF - - DO ispin = 1, nspins - CALL cp_fm_release(fm_mat_S_bar_ia_bse_arr(ispin)) - CALL cp_fm_release(fm_mat_S_bar_ij_bse_arr(ispin)) - CALL cp_fm_release(fm_mat_S_ia_trunc_arr(ispin)) - CALL cp_fm_release(fm_mat_S_ij_trunc_arr(ispin)) - CALL cp_fm_release(fm_mat_S_ab_trunc_arr(ispin)) - END DO - IF (mp2_env%bse%do_nto_analysis) DEALLOCATE (mp2_env%bse%bse_nto_state_list_final) - DEALLOCATE (Eigenval_reduced_joint, n_ov_arr, offsets_arr) - - ELSE - ! === Closed-shell n_spin=1 path (bit-identical) === - CALL truncate_BSE_matrices(fm_mat_S_ia_bse(1), fm_mat_S_ij_bse(1), fm_mat_S_ab_bse(1), & - fm_mat_S_ia_trunc_arr(1), fm_mat_S_ij_trunc_arr(1), & - fm_mat_S_ab_trunc_arr(1), & - Eigenval_scf(:, 1, 1), Eigenval(:, 1, 1), Eigenval_reduced, & - homo(1), virtual(1), dimen_RI, unit_nr, & - bse_lev_virt(1), homo_red_arr(1), virt_red_arr(1), mp2_env) - CALL mult_B_with_W(fm_mat_S_ij_trunc_arr(1), fm_mat_S_ia_trunc_arr(1), & - fm_mat_S_bar_ia_bse_arr(1), fm_mat_S_bar_ij_bse_arr(1), & - fm_mat_Q_static_bse_gemm, dimen_RI_red, homo_red_arr(1), virt_red_arr(1)) - - IF (my_do_iterat_diag) THEN - CALL fill_local_3c_arrays(fm_mat_S_ab_trunc_arr(1), fm_mat_S_ia_trunc_arr(1), & - fm_mat_S_bar_ia_bse_arr(1), fm_mat_S_bar_ij_bse_arr(1), & - B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & - B_iaQ_bse_local, dimen_RI_red, homo_red_arr(1), & - virt_red_arr(1), gd_array, color_sub, para_env) - END IF - - CALL adapt_BSE_input_params(homo_red_arr(1), virt_red_arr(1), unit_nr, mp2_env, qs_env) - - IF (my_do_fulldiag) THEN - n_ov_joint = homo_red_arr(1)*virt_red_arr(1) - CALL estimate_BSE_resources(n_ov_joint, unit_nr, my_do_abba, para_env, diag_runtime_est) - IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & - mp2_env%bse%screening_method == bse_screening_alpha) THEN - CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr, & - fm_A_BSE, Eigenval_reduced, unit_nr, & - homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) - ELSE - CALL create_A(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ij_bse_arr, fm_mat_S_ab_trunc_arr, & - fm_A_BSE, Eigenval_reduced, unit_nr, & - homo_red_arr, virt_red_arr, dimen_RI, mp2_env, para_env, qs_env) - END IF - IF (my_do_abba) THEN - IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & - mp2_env%bse%screening_method == bse_screening_alpha) THEN - CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_ia_trunc_arr, fm_B_BSE, & - homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) - ELSE - CALL create_B(fm_mat_S_ia_trunc_arr, fm_mat_S_bar_ia_bse_arr, fm_B_BSE, & - homo_red_arr, virt_red_arr, dimen_RI, unit_nr, mp2_env) - END IF - CALL create_hermitian_form_of_ABBA(fm_A_BSE, fm_B_BSE, fm_C_BSE, & - fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - unit_nr, mp2_env, diag_runtime_est) - END IF - CALL cp_fm_release(fm_B_BSE) - - NULLIFY (dft_control, tddfpt_control) - CALL get_qs_env(qs_env, dft_control=dft_control) - tddfpt_control => dft_control%tddfpt2_control - IF (my_do_tda .AND. (.NOT. tddfpt_control%do_bse)) THEN - CALL diagonalize_A(fm_A_BSE, homo_red_arr, virt_red_arr, homo, & - unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) - END IF - CALL cp_fm_release(fm_A_BSE) - IF (my_do_abba) THEN - CALL diagonalize_C(fm_C_BSE, homo_red_arr, virt_red_arr, homo, & - fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & - unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) - END IF - CALL cp_fm_release(fm_C_BSE) - END IF - - 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 + CALL fm_mat_S_ia_bse%matrix_struct%para_env%sync() + ! We apply the BSE cutoffs using the DFT Eigenenergies + ! Reduce matrices in case of energy cutoff for occupied and unoccupied in A/B-BSE-matrices + CALL truncate_BSE_matrices(fm_mat_S_ia_bse, fm_mat_S_ij_bse, fm_mat_S_ab_bse, & + fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & + Eigenval_scf(:, 1, 1), Eigenval(:, 1, 1), Eigenval_reduced, & + homo(1), virtual(1), dimen_RI, unit_nr, & + bse_lev_virt, & + homo_red, virtual_red, & + mp2_env) + ! \bar{B}^P_rs = \sum_R W_PR B^R_rs where B^R_rs = \sum_T [1/sqrt(v)]_RT (T|rs) + ! r,s: MO-index, P,R,T: RI-index + ! B: fm_mat_S_..., W: fm_mat_Q_... + CALL mult_B_with_W(fm_mat_S_ij_trunc, fm_mat_S_ia_trunc, fm_mat_S_bar_ia_bse, & + fm_mat_S_bar_ij_bse, fm_mat_Q_static_bse_gemm, & + dimen_RI_red, homo_red, virtual_red) + IF (my_do_iterat_diag) THEN + CALL fill_local_3c_arrays(fm_mat_S_ab_trunc, fm_mat_S_ia_trunc, & + fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, & + B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & + B_iaQ_bse_local, dimen_RI_red, homo_red, virtual_red, & + gd_array, color_sub, para_env) END IF - DEALLOCATE (homo_red_arr, virt_red_arr) - DEALLOCATE (fm_mat_S_ia_trunc_arr, fm_mat_S_ij_trunc_arr, fm_mat_S_ab_trunc_arr) - DEALLOCATE (fm_mat_S_bar_ia_bse_arr, fm_mat_S_bar_ij_bse_arr) + CALL adapt_BSE_input_params(homo_red, virtual_red, unit_nr, mp2_env, qs_env) + + IF (my_do_fulldiag) THEN + ! Quick estimate of memory consumption and runtime of diagonalizations + CALL estimate_BSE_resources(homo_red, virtual_red, unit_nr, my_do_abba, & + para_env, diag_runtime_est) + ! Matrix A constructed from GW energies and 3c-B-matrices (cf. subroutine mult_B_with_W) + ! A_ia,jb = (ε_a-ε_i) δ_ij δ_ab + α * v_ia,jb - W_ij,ab + ! ε_a, ε_i are GW singleparticle energies from Eigenval_reduced + ! α is a spin-dependent factor + ! v_ia,jb = \sum_P B^P_ia B^P_jb (unscreened Coulomb interaction) + ! W_ij,ab = \sum_P \bar{B}^P_ij B^P_ab (screened Coulomb interaction) + + ! For unscreened W matrix, we need fm_mat_S_ij_trunc + IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & + mp2_env%bse%screening_method == bse_screening_alpha) THEN + CALL create_A(fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & + fm_A_BSE, Eigenval_reduced, unit_nr, & + homo_red, virtual_red, dimen_RI, mp2_env, & + para_env, qs_env) + ELSE + CALL create_A(fm_mat_S_ia_trunc, fm_mat_S_bar_ij_bse, fm_mat_S_ab_trunc, & + fm_A_BSE, Eigenval_reduced, unit_nr, & + homo_red, virtual_red, dimen_RI, mp2_env, & + para_env, qs_env) + END IF + IF (my_do_abba) THEN + ! Matrix B constructed from 3c-B-matrices (cf. subroutine mult_B_with_W) + ! B_ia,jb = α * v_ia,jb - W_ib,aj + ! α is a spin-dependent factor + ! v_ia,jb = \sum_P B^P_ia B^P_jb (unscreened Coulomb interaction) + ! W_ib,aj = \sum_P \bar{B}^P_ib B^P_aj (screened Coulomb interaction) + + ! For unscreened W matrix, we need fm_mat_S_ia_trunc + IF (mp2_env%bse%screening_method == bse_screening_tdhf .OR. & + mp2_env%bse%screening_method == bse_screening_alpha) THEN + CALL create_B(fm_mat_S_ia_trunc, fm_mat_S_ia_trunc, fm_B_BSE, & + homo_red, virtual_red, dimen_RI, unit_nr, mp2_env) + ELSE + CALL create_B(fm_mat_S_ia_trunc, fm_mat_S_bar_ia_bse, fm_B_BSE, & + homo_red, virtual_red, dimen_RI, unit_nr, mp2_env) + END IF + ! Construct Matrix C=(A-B)^0.5 (A+B) (A-B)^0.5 to solve full BSE matrix as a hermitian problem + ! (cf. Eq. (A7) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001)). + ! We keep fm_sqrt_A_minus_B and fm_inv_sqrt_A_minus_B for print of singleparticle transitions + ! of ABBA as described in Eq. (A10) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001). + CALL create_hermitian_form_of_ABBA(fm_A_BSE, fm_B_BSE, fm_C_BSE, & + fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & + homo_red, virtual_red, unit_nr, mp2_env, diag_runtime_est) + END IF + CALL cp_fm_release(fm_B_BSE) + + NULLIFY (dft_control, tddfpt_control) + CALL get_qs_env(qs_env, dft_control=dft_control) + tddfpt_control => dft_control%tddfpt2_control + IF ((my_do_tda) .AND. (.NOT. tddfpt_control%do_bse)) THEN + ! Solving the hermitian eigenvalue equation A X^n = Ω^n X^n + CALL diagonalize_A(fm_A_BSE, homo_red, virtual_red, homo(1), & + unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + END IF + ! Release to avoid faulty use of changed A matrix + CALL cp_fm_release(fm_A_BSE) + IF (my_do_abba) THEN + ! Solving eigenvalue equation C Z^n = (Ω^n)^2 Z^n . + ! Here, the eigenvectors Z^n relate to X^n via + ! Eq. (A10) in F. Furche J. Chem. Phys., Vol. 114, No. 14, (2001). + CALL diagonalize_C(fm_C_BSE, homo_red, virtual_red, homo(1), & + fm_sqrt_A_minus_B, fm_inv_sqrt_A_minus_B, & + unit_nr, diag_runtime_est, mp2_env, qs_env, mo_coeff) + END IF + ! Release to avoid faulty use of changed C matrix + CALL cp_fm_release(fm_C_BSE) + END IF + + CALL deallocate_matrices_bse(fm_mat_S_bar_ia_bse, fm_mat_S_bar_ij_bse, & + fm_mat_S_ia_trunc, fm_mat_S_ij_trunc, fm_mat_S_ab_trunc, & + fm_mat_Q_static_bse_gemm, mp2_env) + DEALLOCATE (Eigenval_reduced) + IF (my_do_iterat_diag) THEN + ! Contains untested Block-Davidson algorithm + CALL do_subspace_iterations(B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, & + B_iaQ_bse_local, homo(1), virtual(1), mp2_env%bse%bse_spin_config, unit_nr, & + Eigenval(:, 1, 1), para_env, mp2_env) + ! Deallocate local 3c-B-matrices + DEALLOCATE (B_bar_ijQ_bse_local, B_abQ_bse_local, B_bar_iaQ_bse_local, B_iaQ_bse_local) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A4,T7,A53)') 'BSE|', 'The BSE was successfully calculated. Have a nice day!' diff --git a/src/bse_print.F b/src/bse_print.F index 877c6eab1c..4ee98507c5 100644 --- a/src/bse_print.F +++ b/src/bse_print.F @@ -17,8 +17,7 @@ MODULE bse_print cite_reference USE bse_properties, ONLY: compute_and_print_absorption_spectrum,& exciton_descr_type - USE bse_util, ONLY: filter_eigvec_contrib,& - get_bse_spin_block_layout + USE bse_util, ONLY: filter_eigvec_contrib USE cp_fm_types, ONLY: cp_fm_get_info,& cp_fm_type USE input_constants, ONLY: bse_screening_alpha,& @@ -240,8 +239,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,T30,A7,T44,A8,T55,A27)') 'BSE|', & - 'Excitation n', multiplet, 'TDA/ABBA', 'Excitation energy Ω^n (eV)' + WRITE (unit_nr, '(T2,A4,T11,A12,T26,A11,T44,A8,T55,A27)') 'BSE|', & + 'Excitation n', "Spin Config", 'TDA/ABBA', 'Excitation energy Ω^n (eV)' END IF !prints actual energies values IF (unit_nr > 0) THEN @@ -270,7 +269,7 @@ CONTAINS info_approximation, mp2_env, unit_nr, fm_eigvec_Y) TYPE(cp_fm_type), INTENT(IN) :: fm_eigvec_X - INTEGER, DIMENSION(:), INTENT(IN) :: homo, virtual, homo_irred + INTEGER, 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 @@ -278,15 +277,10 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'print_transition_amplitudes' - INTEGER :: handle, i_exc, isp, n_ov_joint, nspins - INTEGER, ALLOCATABLE, DIMENSION(:) :: n_ov, offsets + INTEGER :: handle, i_exc 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)') & @@ -306,41 +300,27 @@ CONTAINS 'BSE|', "i.e. |X_ia^n| > ", mp2_env%bse%eps_x, " or |Y_ia^n| > ", & mp2_env%bse%eps_x, ", respectively :" - IF (nspins == 1) THEN - WRITE (unit_nr, '(T2,A4,T15,A27,I5,A13,I5,A3)') 'BSE|', '-- Quick reminder: HOMO i =', & - homo_irred(1), ' and LUMO a =', homo_irred(1) + 1, " --" - WRITE (unit_nr, '(T2,A4)') 'BSE|' - WRITE (unit_nr, '(T2,A4,T7,A12,T30,A1,T32,A5,T42,A1,T49,A8,T64,A17)') & - "BSE|", "Excitation n", "i", "=>/<=", "a", 'TDA/ABBA', "|X_ia^n|/|Y_ia^n|" - ELSE - ! bare A (no width) for sigma-bearing literals: explicit widths count bytes, and the - ! 2-byte UTF-8 sigma would otherwise truncate. - DO isp = 1, nspins - WRITE (unit_nr, '(T2,A4,T15,A,I2,A,I5,A,I5,A)') 'BSE|', & - '-- Quick reminder: σ =', isp, ', HOMO i =', homo_irred(isp), & - ' and LUMO a =', homo_irred(isp) + 1, " --" - END DO - WRITE (unit_nr, '(T2,A4)') 'BSE|' - WRITE (unit_nr, '(T2,A4,T7,A12,T22,A,T30,A1,T32,A5,T42,A1,T49,A8,T64,A)') & - "BSE|", "Excitation n", "σ", "i", "=>/<=", "a", 'TDA/ABBA', "|X_iaσ^n|/|Y_iaσ^n|" - END IF + WRITE (unit_nr, '(T2,A4,T15,A27,I5,A13,I5,A3)') 'BSE|', '-- Quick reminder: HOMO i =', & + homo_irred, ' and LUMO a =', homo_irred + 1, " --" + WRITE (unit_nr, '(T2,A4)') 'BSE|' + WRITE (unit_nr, '(T2,A4,T7,A12,T30,A1,T32,A5,T42,A1,T49,A8,T64,A17)') & + "BSE|", "Excitation n", "i", "=>/<=", "a", 'TDA/ABBA', "|X_ia^n|/|Y_ia^n|" END IF - DO i_exc = 1, MIN(n_ov_joint, mp2_env%bse%num_print_exc) + DO i_exc = 1, MIN(homo*virtual, 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, offsets) + unit_nr, mp2_env) 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, offsets) + unit_nr, mp2_env) END IF END DO - DEALLOCATE (n_ov, offsets) CALL timestop(handle) END SUBROUTINE print_transition_amplitudes @@ -358,11 +338,10 @@ 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, open_shell) + info_approximation, mp2_env, unit_nr) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Exc_ens, oscill_str REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: trans_mom_bse, polarizability_residues @@ -371,18 +350,13 @@ 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 @@ -393,22 +367,12 @@ 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 (my_open_shell) THEN - IF (flag_TDA) THEN - WRITE (unit_nr, '(T2,A4,T10,A)') & - 'BSE|', "d_r^n = sum_σ sum_ia < ψ_iσ | r | ψ_aσ > X_iaσ^n" - ELSE - WRITE (unit_nr, '(T2,A4,T10,A)') & - 'BSE|', "d_r^n = sum_σ sum_ia < ψ_iσ | r | ψ_aσ > ( X_iaσ^n + Y_iaσ^n )" - END IF + IF (flag_TDA) THEN + WRITE (unit_nr, '(T2,A4,T10,A)') & + 'BSE|', "d_r^n = sqrt(2) sum_ia < ψ_i | r | ψ_a > X_ia^n" ELSE - IF (flag_TDA) THEN - WRITE (unit_nr, '(T2,A4,T10,A)') & - 'BSE|', "d_r^n = sqrt(2) sum_ia < ψ_i | r | ψ_a > X_ia^n" - ELSE - WRITE (unit_nr, '(T2,A4,T10,A)') & - 'BSE|', "d_r^n = sum_ia sqrt(2) < ψ_i | r | ψ_a > ( X_ia^n + Y_ia^n )" - END IF + 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 WRITE (unit_nr, '(T2,A4)') 'BSE|' WRITE (unit_nr, '(T2,A4,T14,A)') & @@ -451,10 +415,8 @@ 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:', MERGE(homo_irred, homo_irred*2, my_open_shell) + 'Number of electrons N_e:', homo_irred*2 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|' @@ -496,58 +458,36 @@ 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, offsets) + unit_nr, mp2_env) TYPE(cp_fm_type), INTENT(IN) :: fm_eigvec CHARACTER(LEN=2), INTENT(IN) :: direction_excitation CHARACTER(LEN=10), INTENT(IN) :: info_approximation - INTEGER, INTENT(IN) :: i_exc - INTEGER, DIMENSION(:), INTENT(IN) :: virtual, homo, homo_irred + INTEGER :: i_exc, 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, isp, k, num_entries - INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_homo, idx_spin, idx_virt + INTEGER :: handle, k, num_entries + INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_homo, 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 (SIZE(homo) == 1) THEN - CALL filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, & - i_exc, virtual(1), num_entries, mp2_env) - IF (unit_nr > 0) THEN - DO k = 1, num_entries - WRITE (unit_nr, '(T2,A4,T14,I5,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') & - "BSE|", i_exc, homo_irred(1) - homo(1) + idx_homo(k), direction_excitation, & - homo_irred(1) + idx_virt(k), info_approximation, ABS(eigvec_entries(k)) - END DO - END IF - ELSE - CALL filter_eigvec_contrib(fm_eigvec, idx_homo, idx_virt, eigvec_entries, & - i_exc, virtual(1), num_entries, mp2_env, & - offsets=offsets, virtual_per_spin=virtual, idx_spin=idx_spin) - IF (unit_nr > 0) THEN - DO k = 1, num_entries - isp = idx_spin(k) - WRITE (unit_nr, '(T2,A4,T14,I5,T22,A2,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') & - "BSE|", i_exc, spin_label(isp), & - homo_irred(isp) - homo(isp) + idx_homo(k), direction_excitation, & - homo_irred(isp) + idx_virt(k), info_approximation, ABS(eigvec_entries(k)) - END DO - END IF - DEALLOCATE (idx_spin) + IF (unit_nr > 0) THEN + DO k = 1, num_entries + WRITE (unit_nr, '(T2,A4,T14,I5,T26,I5,T35,A2,T38,I5,T51,A6,T65,F16.4)') & + "BSE|", i_exc, homo_irred - homo + idx_homo(k), direction_excitation, & + homo_irred + idx_virt(k), info_approximation, ABS(eigvec_entries(k)) + END DO END IF DEALLOCATE (idx_homo) DEALLOCATE (idx_virt) @@ -647,7 +587,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 > ≥ 1 without TDA.' + 'where c_n = < 𝚿_n | 𝚿_n > deviates from 1 without TDA.' END IF WRITE (unit_nr, '(T2,A4)') prefix_output WRITE (unit_nr, '(T2,A4)') prefix_output diff --git a/src/bse_util.F b/src/bse_util.F index c134e7c215..d6d53fbba4 100644 --- a/src/bse_util.F +++ b/src/bse_util.F @@ -92,8 +92,7 @@ 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, & - get_bse_spin_block_layout, determine_bse_combined_window, assemble_joint_ov_slab + reshuffle_eigvec, print_bse_nto_cubes, trace_exciton_descr CONTAINS @@ -194,12 +193,9 @@ 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, & - row_offset, col_offset) + nrow_secidx_out, ncol_secidx_out, unit_nr, reordering, mp2_env) TYPE(cp_fm_type), INTENT(INOUT) :: fm_out TYPE(cp_fm_type), INTENT(IN) :: fm_in @@ -209,14 +205,13 @@ 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, my_col_offset, my_row_offset, ncol_block_in, ncol_block_out, ncol_local_in, & - ncol_local_out, nprocs, nrow_block_in, nrow_block_out, nrow_local_in, nrow_local_out, & - proc_send, row_idx_loc, send_pcol, send_prow + iproc, jj, ncol_block_in, ncol_block_out, ncol_local_in, ncol_local_out, nprocs, & + nrow_block_in, nrow_block_out, nrow_local_in, nrow_local_out, proc_send, row_idx_loc, & + send_pcol, send_prow INTEGER, ALLOCATABLE, DIMENSION(:) :: entry_counter, num_entries_rec, & num_entries_send INTEGER, DIMENSION(4) :: indices_in @@ -227,14 +222,6 @@ 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) @@ -293,8 +280,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 = my_row_offset + indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out - idx_col_out = my_col_offset + indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out + idx_row_out = indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out + idx_col_out = indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out send_prow = fm_out%matrix_struct%g2p_row(idx_row_out) send_pcol = fm_out%matrix_struct%g2p_col(idx_col_out) @@ -373,8 +360,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 = my_row_offset + indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out - idx_col_out = my_col_offset + indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out + idx_row_out = indices_in(reordering(2)) + (indices_in(reordering(1)) - 1)*nrow_secidx_out + idx_col_out = indices_in(reordering(4)) + (indices_in(reordering(3)) - 1)*ncol_secidx_out send_prow = fm_out%matrix_struct%g2p_row(idx_row_out) send_pcol = fm_out%matrix_struct%g2p_col(idx_col_out) @@ -856,24 +843,20 @@ CONTAINS END SUBROUTINE comp_eigvec_coeff_BSE ! ************************************************************************************************** -!> \brief Sorts excitation entries by ascending primary index, reordering the secondary index, -!> the eigenvector coefficients and - open shell - the spin index alongside -!> \param idx_prim Primary index of each entry; sorted in place and used as the sort key -!> \param idx_sec Secondary index of each entry, reordered to follow idx_prim -!> \param eigvec_entries Eigenvector coefficients of each entry, reordered to follow idx_prim -!> \param idx_spin Optional spin index of each entry (open shell), reordered to follow idx_prim +!> \brief ... +!> \param idx_prim ... +!> \param idx_sec ... +!> \param eigvec_entries ... ! ************************************************************************************************** - SUBROUTINE sort_excitations(idx_prim, idx_sec, eigvec_entries, idx_spin) + SUBROUTINE sort_excitations(idx_prim, idx_sec, eigvec_entries) 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, & - idx_spin_work, tmp_index + INTEGER, ALLOCATABLE, DIMENSION(:) :: idx_prim_work, idx_sec_work, tmp_index LOGICAL :: unique_entries REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: eigvec_entries_work @@ -887,12 +870,10 @@ 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) @@ -901,10 +882,6 @@ 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) @@ -923,10 +900,6 @@ 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) @@ -934,13 +907,11 @@ 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 @@ -953,16 +924,17 @@ CONTAINS ! ************************************************************************************************** !> \brief Roughly estimates the needed runtime and memory during the BSE run -!> \param n_ov_joint ... +!> \param homo_red ... +!> \param virtual_red ... !> \param unit_nr ... !> \param bse_abba ... !> \param para_env ... !> \param diag_runtime_est ... ! ************************************************************************************************** - SUBROUTINE estimate_BSE_resources(n_ov_joint, unit_nr, bse_abba, & + SUBROUTINE estimate_BSE_resources(homo_red, virtual_red, unit_nr, bse_abba, & para_env, diag_runtime_est) - INTEGER, INTENT(IN) :: n_ov_joint, unit_nr + INTEGER :: homo_red, virtual_red, unit_nr LOGICAL :: bse_abba TYPE(mp_para_env_type), POINTER :: para_env REAL(KIND=dp) :: diag_runtime_est @@ -983,7 +955,7 @@ CONTAINS num_BSE_matrices = 10 END IF - full_dim = INT(n_ov_joint, KIND=int_8)**2*INT(num_BSE_matrices, KIND=int_8) + full_dim = (INT(homo_red, KIND=int_8)**2*INT(virtual_red, 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) @@ -998,7 +970,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(n_ov_joint, KIND=int_8)/11000_int_8, KIND=dp)**3* & + diag_runtime_est = REAL(INT(homo_red, KIND=int_8)*INT(virtual_red, KIND=int_8)/11000_int_8, KIND=dp)**3* & 10*32/REAL(para_env%num_pe, KIND=dp) CALL timestop(handle) @@ -1016,27 +988,21 @@ 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, & - offsets, virtual_per_spin, idx_spin) + i_exc, virtual, num_entries, mp2_env) 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, isp, jj, & - kk, ksp, ncol_local, nrow_local, & - num_entries_local, r_local, v_local + INTEGER :: eigvec_idx, handle, ii, iproc, jj, kk, & + ncol_local, nrow_local, & + num_entries_local INTEGER, ALLOCATABLE, DIMENSION(:) :: num_entries_to_comm INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices REAL(KIND=dp) :: eigvec_entry @@ -1080,7 +1046,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), 3)) + ALLOCATE (buffer_entries(iproc)%indx(num_entries_to_comm(iproc), 2)) buffer_entries(iproc)%msg = 0.0_dp buffer_entries(iproc)%indx = 0 END DO @@ -1095,24 +1061,8 @@ CONTAINS eigvec_idx = row_indices(ii) eigvec_entry = fm_eigvec%local_data(ii, jj) IF (ABS(eigvec_entry) > mp2_env%bse%eps_x) THEN - ! Decode spin block from the joint row index (blocks are contiguous; sigma is the - ! largest offset strictly below eigvec_idx). offsets absent -> closed shell, sigma=1. - isp = 1 - r_local = eigvec_idx - v_local = virtual - IF (PRESENT(offsets)) THEN - DO ksp = SIZE(offsets), 1, -1 - IF (eigvec_idx > offsets(ksp)) THEN - isp = ksp - EXIT - END IF - END DO - r_local = eigvec_idx - offsets(isp) - v_local = virtual_per_spin(isp) - END IF - buffer_entries(para_env%mepos)%indx(kk, 1) = (r_local - 1)/v_local + 1 - buffer_entries(para_env%mepos)%indx(kk, 2) = MOD(r_local - 1, v_local) + 1 - buffer_entries(para_env%mepos)%indx(kk, 3) = isp + buffer_entries(para_env%mepos)%indx(kk, 1) = (eigvec_idx - 1)/virtual + 1 + buffer_entries(para_env%mepos)%indx(kk, 2) = MOD(eigvec_idx - 1, virtual) + 1 buffer_entries(para_env%mepos)%msg(kk) = eigvec_entry kk = kk + 1 END IF @@ -1129,7 +1079,6 @@ 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 @@ -1137,7 +1086,6 @@ 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 @@ -1155,12 +1103,8 @@ CONTAINS NULLIFY (col_indices) !Now sort the results according to the involved singleparticle orbitals - ! (homo first, then virtual). idx_spin is payload, permuted alongside the entries. - IF (PRESENT(idx_spin)) THEN - CALL sort_excitations(idx_homo, idx_virt, eigvec_entries, idx_spin) - ELSE - CALL sort_excitations(idx_homo, idx_virt, eigvec_entries) - END IF + ! (homo first, then virtual) + CALL sort_excitations(idx_homo, idx_virt, eigvec_entries) CALL timestop(handle) @@ -1176,47 +1120,35 @@ 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 cutoff_occ ... -!> \param cutoff_empty ... +!> \param mp2_env ... ! ************************************************************************************************** SUBROUTINE determine_cutoff_indices(Eigenval, & homo, virtual, & homo_red, virt_red, & homo_incl, virt_incl, & - cutoff_occ, cutoff_empty) + mp2_env) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval INTEGER, INTENT(IN) :: homo, virtual INTEGER, INTENT(OUT) :: homo_red, virt_red, homo_incl, virt_incl - REAL(KIND=dp), INTENT(IN) :: cutoff_occ, cutoff_empty + TYPE(mp2_type), INTENT(INOUT) :: mp2_env CHARACTER(LEN=*), PARAMETER :: routineN = 'determine_cutoff_indices' - INTEGER :: handle, i_chk, i_homo, j_virt + INTEGER :: handle, i_homo, j_virt CALL timeset(routineN, handle) ! Determine index in homo and virtual for truncation - ! Uses indices of outermost orbitals within energy range (-cutoff_occ,cutoff_empty) - IF (cutoff_occ > 0 .OR. cutoff_empty > 0) THEN - ! The scans below EXIT at the first orbital beyond the cutoff, which only yields the correct - ! window on an ascending axis. A non-monotonic one (G0W0) stops at the first inversion and - ! silently drops in-window orbitals. - DO i_chk = 2, homo + virtual - IF (Eigenval(i_chk) < Eigenval(i_chk - 1)) THEN - CALL cp_abort(__LOCATION__, & - "determine_cutoff_indices: eigenvalues are not ascending. Take the "// & - "energy cutoff on the DFT axis; the G0W0 axis is not ordered.") - END IF - END DO - - IF (-cutoff_occ < Eigenval(1) - Eigenval(homo) & - .OR. cutoff_occ < 0) THEN + ! Uses indices of outermost orbitals within energy range (-mp2_env%bse%bse_cutoff_occ,mp2_env%bse%bse_cutoff_empty) + IF (mp2_env%bse%bse_cutoff_occ > 0 .OR. mp2_env%bse%bse_cutoff_empty > 0) THEN + IF (-mp2_env%bse%bse_cutoff_occ < Eigenval(1) - Eigenval(homo) & + .OR. mp2_env%bse%bse_cutoff_occ < 0) THEN homo_red = homo homo_incl = 1 ELSE homo_incl = 1 DO i_homo = 1, homo - IF (Eigenval(i_homo) - Eigenval(homo) > -cutoff_occ) THEN + IF (Eigenval(i_homo) - Eigenval(homo) > -mp2_env%bse%bse_cutoff_occ) THEN homo_incl = i_homo EXIT END IF @@ -1224,14 +1156,14 @@ CONTAINS homo_red = homo - homo_incl + 1 END IF - IF (cutoff_empty > Eigenval(homo + virtual) - Eigenval(homo + 1) & - .OR. cutoff_empty < 0) THEN + IF (mp2_env%bse%bse_cutoff_empty > Eigenval(homo + virtual) - Eigenval(homo + 1) & + .OR. mp2_env%bse%bse_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) > cutoff_empty) THEN + IF (Eigenval(homo + j_virt) - Eigenval(homo + 1) > mp2_env%bse%bse_cutoff_empty) THEN virt_incl = j_virt - 1 EXIT END IF @@ -1249,91 +1181,6 @@ 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 ... @@ -1353,8 +1200,6 @@ 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, & @@ -1362,8 +1207,7 @@ CONTAINS homo, virtual, dimen_RI, unit_nr, & bse_lev_virt, & homo_red, virt_red, & - mp2_env, & - homo_incl_in, virt_incl_in) + mp2_env) TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_ia_bse, fm_mat_S_ij_bse, & fm_mat_S_ab_bse @@ -1375,7 +1219,6 @@ 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' @@ -1386,58 +1229,45 @@ CONTAINS CALL timeset(routineN, handle) - ! Determine index in homo and virtual for truncation. - ! When homo_incl_in/virt_incl_in are provided (combined-window path), skip per-spin - ! determine_cutoff_indices and the print; caller already printed via determine_bse_combined_window. - IF (PRESENT(homo_incl_in)) THEN - homo_incl = homo_incl_in - virt_incl = virt_incl_in - homo_red = homo - homo_incl + 1 - virt_red = virt_incl - ELSE - CALL determine_cutoff_indices(Eigenval_scf, & - homo, virtual, & - homo_red, virt_red, & - homo_incl, virt_incl, & - mp2_env%bse%bse_cutoff_occ, mp2_env%bse%bse_cutoff_empty) + ! Determine index in homo and virtual for truncation + ! Uses indices of outermost orbitals within energy range (-mp2_env%bse%bse_cutoff_occ,mp2_env%bse%bse_cutoff_empty) - IF (unit_nr > 0) THEN - IF (mp2_env%bse%bse_cutoff_occ > 0) THEN - WRITE (unit_nr, '(T2,A4,T7,A29,T71,F10.3)') 'BSE|', 'Cutoff occupied orbitals [eV]', & - mp2_env%bse%bse_cutoff_occ*evolt - ELSE - WRITE (unit_nr, '(T2,A4,T7,A37)') 'BSE|', 'No cutoff given for occupied orbitals' - END IF - IF (mp2_env%bse%bse_cutoff_empty > 0) THEN - WRITE (unit_nr, '(T2,A4,T7,A26,T71,F10.3)') 'BSE|', 'Cutoff empty orbitals [eV]', & - mp2_env%bse%bse_cutoff_empty*evolt - ELSE - WRITE (unit_nr, '(T2,A4,T7,A34)') 'BSE|', 'No cutoff given for empty orbitals' - END IF - WRITE (unit_nr, '(T2,A4,T7,A20,T71,I10)') 'BSE|', 'First occupied index', homo_incl - WRITE (unit_nr, '(T2,A4,T7,A32,T71,I10)') 'BSE|', 'Last empty index (not MO index!)', virt_incl - WRITE (unit_nr, '(T2,A4,T7,A35,T71,F10.3)') 'BSE|', 'Energy of first occupied index [eV]', & - Eigenval(homo_incl)*evolt - WRITE (unit_nr, '(T2,A4,T7,A31,T71,F10.3)') 'BSE|', 'Energy of last empty index [eV]', & - Eigenval(homo + virt_incl)*evolt - WRITE (unit_nr, '(T2,A4,T7,A54,T71,F10.3)') 'BSE|', & - 'Energy difference of first occupied index to HOMO [eV]', & - -(Eigenval(homo_incl) - Eigenval(homo))*evolt - WRITE (unit_nr, '(T2,A4,T7,A50,T71,F10.3)') 'BSE|', & - 'Energy difference of last empty index to LUMO [eV]', & - (Eigenval(homo + virt_incl) - Eigenval(homo + 1))*evolt - WRITE (unit_nr, '(T2,A4,T7,A35,T71,I10)') 'BSE|', 'Number of GW-corrected occupied MOs', & - mp2_env%ri_g0w0%corr_mos_occ - WRITE (unit_nr, '(T2,A4,T7,A32,T71,I10)') 'BSE|', 'Number of GW-corrected empty MOs', & - bse_lev_virt - WRITE (unit_nr, '(T2,A4)') 'BSE|' + CALL determine_cutoff_indices(Eigenval_scf, & + homo, virtual, & + homo_red, virt_red, & + homo_incl, virt_incl, & + mp2_env) + + IF (unit_nr > 0) THEN + IF (mp2_env%bse%bse_cutoff_occ > 0) THEN + WRITE (unit_nr, '(T2,A4,T7,A29,T71,F10.3)') 'BSE|', 'Cutoff occupied orbitals [eV]', & + mp2_env%bse%bse_cutoff_occ*evolt + ELSE + WRITE (unit_nr, '(T2,A4,T7,A37)') 'BSE|', 'No cutoff given for occupied orbitals' 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 > bse_lev_virt) THEN + IF (virt_incl > mp2_env%ri_g0w0%corr_mos_virt) THEN CPABORT("Number of GW-corrected virtual MOs too small for chosen BSE cutoff") END IF END IF @@ -1651,7 +1481,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(A6,I3.3,A5,I2.2,a11)') "_NEXC_", istate, "_NTO_", i, "_Hole_State" - ELSE IF (iset == 2) THEN + ELSEIF (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)) @@ -1663,7 +1493,7 @@ CONTAINS log_filename=.FALSE., ignore_should_output=.TRUE., mpi_io=mpi_io) IF (iset == 1) THEN WRITE (title, *) "Natural Transition Orbital Hole State", i - ELSE IF (iset == 2) THEN + ELSEIF (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) @@ -1878,11 +1708,10 @@ 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, ispin) + homo_red, virtual_red, context_BSE) TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), & INTENT(INOUT) :: fm_multipole_ai_trunc, & @@ -1893,12 +1722,11 @@ 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, my_ispin, n_multipole, & - n_occ, n_virt, nao, nmo_mp2 + INTEGER :: handle, idir, n_multipole, n_occ, & + n_virt, nao, nmo_mp2 REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point TYPE(cp_fm_struct_type), POINTER :: fm_struct_mp_ab_trunc, fm_struct_mp_ai_trunc, & fm_struct_mp_ij_trunc, fm_struct_multipoles_ao, fm_struct_nao_nmo, fm_struct_nmo_nmo @@ -1912,9 +1740,6 @@ 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, & @@ -1923,7 +1748,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(my_ispin)%mo_coeff%matrix_struct + fm_struct_multipoles_ao => mos(1)%mo_coeff%matrix_struct ! BSE has different contexts and blacsenvs para_env_BSE => context_BSE%para_env ! Get size of multipole tensor @@ -1949,7 +1774,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(my_ispin), homo=n_occ, nao=nao) + CALL get_mo_set(mo_set=mos(1), 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 @@ -2098,32 +1923,4 @@ CONTAINS END SUBROUTINE trace_exciton_descr -! ************************************************************************************************** -!> \brief Column-concatenate per-spin ia-slabs into the joint dimen_RI x n_ov_joint slab. -!> Sigma-block of spin isp occupies columns offsets(isp)+1 .. offsets(isp)+n_ov(isp). -!> fm_S_joint must be pre-created and zeroed by the caller. -!> \param fm_S_ia per-spin ia-slabs, shape (dimen_RI, n_ov(isp)) per spin -!> \param offsets per-spin column offsets into fm_S_joint (0-based) -!> \param n_ov per-spin OV-pair counts -!> \param dimen_RI RI auxiliary basis dimension (row count) -!> \param fm_S_joint pre-created output slab (dimen_RI x n_ov_joint) -! ************************************************************************************************** - SUBROUTINE assemble_joint_ov_slab(fm_S_ia, offsets, n_ov, dimen_RI, fm_S_joint) - TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_S_ia - INTEGER, DIMENSION(:), INTENT(IN) :: offsets, n_ov - INTEGER, INTENT(IN) :: dimen_RI - TYPE(cp_fm_type), INTENT(INOUT) :: fm_S_joint - - CHARACTER(LEN=*), PARAMETER :: routineN = 'assemble_joint_ov_slab' - - INTEGER :: handle, isp - - CALL timeset(routineN, handle) - DO isp = 1, SIZE(fm_S_ia) - CALL cp_fm_to_fm_submat(fm_S_ia(isp), fm_S_joint, dimen_RI, n_ov(isp), 1, 1, 1, offsets(isp) + 1) - END DO - CALL timestop(handle) - - END SUBROUTINE assemble_joint_ov_slab - END MODULE bse_util diff --git a/src/bsse.F b/src/bsse.F index 6869888a3d..3abfc8c654 100644 --- a/src/bsse.F +++ b/src/bsse.F @@ -370,10 +370,10 @@ CONTAINS iw = cp_print_key_unit_nr(logger, bsse_section, "PRINT%PROGRAM_RUN_INFO", & extension=".log") IF (iw > 0) THEN - WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf + WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf; IF (istat /= 0) conf_s = "exceeded" CALL compress(conf_s, full=.TRUE.) - WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc + WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc; IF (istat /= 0) conf_loc_s = "exceeded" CALL compress(conf_loc_s, full=.TRUE.) @@ -429,17 +429,15 @@ 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)) THEN + IF (SIZE(glb_conf) /= SIZE(conf)) & 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)) THEN + IF (SIZE(sub_conf) /= SIZE(conf)) & CALL cp_abort(__LOCATION__, & "SUB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") - END IF IF (ALL(conf == glb_conf) .AND. ALL(conf_loc == sub_conf)) THEN CALL section_vals_val_get(configurations, "CHARGE", i_rep_section=i, & i_val=present_charge) diff --git a/src/cell_methods.F b/src/cell_methods.F index 1cb33a48c5..fc063a2c1e 100644 --- a/src/cell_methods.F +++ b/src/cell_methods.F @@ -461,12 +461,11 @@ 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) THEN + IF (tmp_comb_cell) & 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) @@ -492,11 +491,10 @@ 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) THEN + IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) & 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 @@ -506,11 +504,10 @@ 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) THEN + IF (cell_read_alpha_beta_gamma) & 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, "// & @@ -725,11 +722,10 @@ CONTAINS CPASSERT(ASSOCIATED(cell)) ! Abort, if one of the value is set to zero - IF (ANY(multiple_unit_cell <= 0)) THEN + IF (ANY(multiple_unit_cell <= 0)) & 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) @@ -782,9 +778,8 @@ 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) THEN + IF (.NOT. found) & 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") @@ -795,9 +790,8 @@ 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) THEN + IF (.NOT. found) & 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") @@ -808,9 +802,8 @@ 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) THEN + IF (.NOT. found) & 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") @@ -821,9 +814,8 @@ 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) THEN + IF (.NOT. found) & 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") @@ -834,9 +826,8 @@ 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) THEN + IF (.NOT. found) & 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") @@ -847,9 +838,8 @@ 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) THEN + IF (.NOT. found) & 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") @@ -1202,9 +1192,8 @@ CONTAINS CALL parser_search_string(parser, "CRYST1", ignore_case=.FALSE., found=found, & begin_line=.TRUE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The line was not found in PDB file! ") - END IF periodic = 1 READ (parser%input_line, *, IOSTAT=ios) cryst, cell_lengths(:), cell_angles(:) diff --git a/src/colvar_methods.F b/src/colvar_methods.F index b92eebad05..0489fefb36 100644 --- a/src/colvar_methods.F +++ b/src/colvar_methods.F @@ -618,12 +618,11 @@ 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) THEN + IF (SIZE(my_par) /= ncol) & 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) @@ -727,9 +726,8 @@ 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) THEN + IF (n_var /= 2) & 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) @@ -738,9 +736,8 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane1%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) THEN + IF (ASSOCIATED(cell)) & 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, & @@ -756,9 +753,8 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane2%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) THEN + IF (ASSOCIATED(cell)) & 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, & @@ -867,10 +863,9 @@ CONTAINS weights(ndim + 1:ndim + SIZE(wei)) = wei ndim = ndim + SIZE(wei) END DO - IF (ndim /= colvar%rmsd_param%n_atoms) THEN + IF (ndim /= colvar%rmsd_param%n_atoms) & 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) @@ -952,13 +947,11 @@ CONTAINS i_val=colvar%ring_puckering_param%iq) ! test the validity of the parameters ndim = colvar%ring_puckering_param%nring - IF (ndim <= 3) THEN + IF (ndim <= 3) & 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) THEN + IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) & CPABORT("CV Ring Puckering: Invalid coordinate number.") - END IF ELSE IF (my_subsection(23)) THEN ! Minimum Distance wrk_section => mindist_section @@ -1333,7 +1326,7 @@ CONTAINS IF (colvar%ring_puckering_param%iq == 0) THEN WRITE (iw, '( A,T40,A)') ' COLVARS| Ring Puckering >>> coordinate', & ' Total Puckering Amplitude' - ELSE IF (colvar%ring_puckering_param%iq > 0) THEN + ELSEIF (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 @@ -2196,12 +2189,11 @@ CONTAINS CALL put_derivative(colvar, iatom, fi) END DO ELSE - IF (force_env%in_use /= use_mixed_force) THEN + IF (force_env%in_use /= use_mixed_force) & 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) @@ -2691,8 +2683,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! evaluation of the angle.. - a = NORM2(xij) - b = NORM2(xkj) + a = SQRT(DOT_PRODUCT(xij, xij)) + b = SQRT(DOT_PRODUCT(xkj, 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) @@ -2842,8 +2834,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! Evaluation of the angle.. - a = NORM2(xij) - b = NORM2(xkj) + a = SQRT(DOT_PRODUCT(xij, xij)) + b = SQRT(DOT_PRODUCT(xkj, 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) @@ -3145,6 +3137,10 @@ 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 @@ -3163,6 +3159,10 @@ 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,10 +3200,11 @@ CONTAINS shift(:) = 0.0_dp shift(idim) = 1.0_dp xij_shift = MATMUL(cell%hmat, shift) - rij_shift = NORM2(xij_shift) + rij_shift = SQRT(DOT_PRODUCT(xij_shift, 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) @@ -3214,7 +3215,12 @@ CONTAINS shift(2) = REAL(bb, KIND=dp) shift(3) = REAL(cc, KIND=dp) xij = MATMUL(cell%hmat, ss0(:) + shift(:)) - rij = NORM2(xij) + rij = SQRT(DOT_PRODUCT(xij, xij)) + !IF (rij > rcut) THEN + ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " --", shift, rij + !ELSE + ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " ++", shift, rij + !ENDIF IF (rij > rcut) CYCLE ! update qlm @@ -3230,7 +3236,7 @@ CONTAINS IF (i == j) CYCLE jloop xij(:) = xpj(:) - xpi(:) - rij = NORM2(xij) + rij = SQRT(DOT_PRODUCT(xij, xij)) IF (rij > rcut) CYCLE jloop ! update qlm @@ -3245,6 +3251,11 @@ 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!") @@ -3263,6 +3274,7 @@ 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 @@ -3275,6 +3287,10 @@ 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 ! ************************************************************************************************** @@ -3307,6 +3323,7 @@ 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 @@ -3349,10 +3366,18 @@ 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 @@ -4570,7 +4595,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL rpath_dist_rmsd(colvar, my_particles) - ELSE IF (colvar%reaction_path_param%rmsd) THEN + ELSEIF (colvar%reaction_path_param%rmsd) THEN CALL rpath_rmsd(colvar, my_particles) ELSE CALL rpath_colvar(colvar, cell, my_particles) @@ -4923,7 +4948,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL dpath_dist_rmsd(colvar, my_particles) - ELSE IF (colvar%reaction_path_param%rmsd) THEN + ELSEIF (colvar%reaction_path_param%rmsd) THEN CALL dpath_rmsd(colvar, my_particles) ELSE CALL dpath_colvar(colvar, cell, my_particles) @@ -5839,12 +5864,11 @@ CONTAINS DO j = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) THEN + IF (my_end) & 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") @@ -5942,7 +5966,12 @@ 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) @@ -5959,7 +5988,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = NORM2(xv) + distance = SQRT(DOT_PRODUCT(xv, xv)) END FUNCTION distance END SUBROUTINE Wc_colvar @@ -5978,8 +6007,8 @@ CONTAINS TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & - OPTIONAL, POINTER :: particles - TYPE(qs_environment_type), OPTIONAL, POINTER :: qs_env + OPTIONAL, POINTER :: particles + TYPE(qs_environment_type), POINTER, OPTIONAL :: qs_env ! optional just because I am lazy... but I should get rid of it... INTEGER :: Od, H, Oa REAL(dp) :: rOd(3), rOa(3), rH(3), & @@ -6076,7 +6105,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = NORM2(xv) + distance = SQRT(DOT_PRODUCT(xv, xv)) END FUNCTION distance END SUBROUTINE HBP_colvar diff --git a/src/common/array_sort.fypp b/src/common/array_sort.fypp index 86ebeb1f97..2b39e3b783 100644 --- a/src/common/array_sort.fypp +++ b/src/common/array_sort.fypp @@ -97,9 +97,9 @@ ! Merge will be performed directly in arr. Need backup of first sublist. tmp_arr(1:m) = arr(1:m) tmp_idx(1:m) = indices(1:m) - i = 1 ! number of elements consumed from 1st sublist - j = 1 ! number of elements consumed from 2nd sublist - k = 1 ! number of elements already merged + i = 1; ! number of elemens consumed from 1st sublist + j = 1; ! number of elemens consumed from 2nd sublist + k = 1; ! number of elemens already merged DO WHILE (i <= m .and. j <= size(arr) - m) IF (${prefix}$_less_than(arr(m + j), tmp_arr(i))) THEN diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 2f13f2f27d..621576c26d 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -66,7 +66,7 @@ MODULE bibliography Kantorovich2008a, Wellendorff2012, Niklasson2014, Borstnik2014, & Rayson2009, Grimme2011, Fattebert2002, Andreussi2012, & Khaliullin2007, Khaliullin2008, Merlot2014, Lin2009, Lin2013, Lin2016ACE, & - Batzner2022, Batatia2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & + Batzner2022, 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, Neugebauer2023 + Chai2025a CONTAINS @@ -164,13 +164,6 @@ 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", & @@ -796,13 +789,6 @@ CONTAINS source="J. Chem. Theory Comput.", volume="15", pages="1652-1671", & year=2019, doi="10.1021/acs.jctc.8b01176") - CALL add_reference(key=Neugebauer2023, & - authors=s2a("H. Neugebauer", "B. Baedorf", "S. Ehlert", "A. Hansen", "S. Grimme"), & - title="High-throughput screening of spin states for transition metal complexes "// & - "with spin-polarized extended tight-binding methods", & - source="J. Comput. Chem.", volume="44", pages="2120-2129", & - year=2023, doi="10.1002/jcc.27185") - CALL add_reference(key=Katbashev2025, & authors=s2a("A. Katbashev", "M. Stahn", "T. Rose", "V. Alizadeh", & "M. Friede", "C. Plett", "P. Steinbach", "S. Ehlert"), & diff --git a/src/common/cp_array_utils.F b/src/common/cp_array_utils.F index a2bbe6c591..87fd4d9949 100644 --- a/src/common/cp_array_utils.F +++ b/src/common/cp_array_utils.F @@ -152,9 +152,8 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) THEN + IF (SIZE(array) > 0) & 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) @@ -164,9 +163,8 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) THEN + IF (SIZE(array) > 0) & 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) @@ -291,7 +289,8 @@ CONTAINS !> \note !> the array should be ordered in growing order ! ************************************************************************************************** - FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) result(res) + FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) & + result(res) ${type1}$, intent(in) :: array(:) ${type1}$, intent(in) :: el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index diff --git a/src/common/cp_error_handling.F b/src/common/cp_error_handling.F index e54780c0d3..2d0192f8e0 100644 --- a/src/common/cp_error_handling.F +++ b/src/common/cp_error_handling.F @@ -63,9 +63,8 @@ CONTAINS CALL delay_non_master() ! cleaner output if all ranks abort simultaneously unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) THEN - unit_nr = default_output_unit - END IF ! fall back to stdout + IF (unit_nr <= 0) & + unit_nr = default_output_unit ! fall back to stdout CALL print_abort_message(message, location, unit_nr) CALL print_stack(unit_nr) @@ -126,9 +125,8 @@ CONTAINS ! we (ab)use the logger to determine the first MPI rank unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) THEN - wait_time = wait_time + 1.0_dp - END IF ! rank-0 gets a head start of one second. + IF (unit_nr <= 0) & + wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second. !$ IF (omp_get_thread_num() /= 0) & !$ wait_time = wait_time + 1.0_dp ! master threads gets another second diff --git a/src/common/cp_log_handling.F b/src/common/cp_log_handling.F index b8ea2ea26e..be0caf7b9e 100644 --- a/src/common/cp_log_handling.F +++ b/src/common/cp_log_handling.F @@ -303,9 +303,8 @@ CONTAINS logger%ref_count = 1 IF (PRESENT(template_logger)) THEN - IF (template_logger%ref_count < 1) THEN + IF (template_logger%ref_count < 1) & 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 @@ -340,19 +339,16 @@ CONTAINS logger%suffix = "" END IF IF (PRESENT(para_env)) logger%para_env => para_env - IF (.NOT. ASSOCIATED(logger%para_env)) THEN + IF (.NOT. ASSOCIATED(logger%para_env)) & CPABORT(routineP//" para env not associated") - END IF - IF (.NOT. logger%para_env%is_valid()) THEN + IF (.NOT. logger%para_env%is_valid()) & 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)) THEN + IF (PRESENT(default_global_unit_nr)) & 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. @@ -366,9 +362,8 @@ CONTAINS END IF END IF - IF (PRESENT(default_local_unit_nr)) THEN + IF (PRESENT(default_local_unit_nr)) & 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. @@ -412,9 +407,8 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_retain', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) THEN + IF (logger%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF logger%ref_count = logger%ref_count + 1 END SUBROUTINE cp_logger_retain @@ -432,9 +426,8 @@ CONTAINS routineP = moduleN//':'//routineN IF (ASSOCIATED(logger)) THEN - IF (logger%ref_count < 1) THEN + IF (logger%ref_count < 1) & 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. & @@ -483,9 +476,8 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) THEN + IF (lggr%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF res = level >= lggr%print_level END FUNCTION cp_logger_would_log @@ -555,9 +547,8 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_set_log_level', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) THEN + IF (logger%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF logger%print_level = level END SUBROUTINE cp_logger_set_log_level @@ -593,9 +584,8 @@ CONTAINS NULLIFY (lggr) END IF IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) THEN + IF (lggr%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF IF (PRESENT(local)) loc = local IF (PRESENT(skip_not_ionode)) skip = skip_not_ionode @@ -702,9 +692,8 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) THEN + IF (lggr%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF IF (PRESENT(local)) loc = local IF (loc) THEN res = TRIM(root)//TRIM(lggr%suffix)//'_p'// & diff --git a/src/common/cp_result_methods.F b/src/common/cp_result_methods.F index 8b943915df..c62fe15576 100644 --- a/src/common/cp_result_methods.F +++ b/src/common/cp_result_methods.F @@ -178,16 +178,14 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) THEN + IF (nrep <= 0) & 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) THEN + IF (results%result_value(i)%value%type_in_use /= result_type_real) & CPABORT("Attempt to retrieve a RESULT which is not a REAL!") - END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT @@ -253,16 +251,14 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) THEN + IF (nrep <= 0) & 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) THEN + IF (results%result_value(i)%value%type_in_use /= result_type_real) & CPABORT("Attempt to retrieve a RESULT which is not a REAL!") - END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT diff --git a/src/common/cp_units.F b/src/common/cp_units.F index d398b9f92f..9677341fd4 100644 --- a/src/common/cp_units.F +++ b/src/common/cp_units.F @@ -650,11 +650,10 @@ CONTAINS CPABORT("unknown electric field unit:"//TRIM(cp_to_string(basic_unit))) END SELECT CASE (cp_ukind_none) - IF (basic_unit /= cp_units_none) THEN + IF (basic_unit /= cp_units_none) & 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 @@ -680,11 +679,10 @@ 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) THEN + IF (basic_kind /= cp_units_none) & 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) @@ -864,10 +862,9 @@ 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) THEN + IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) & 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) @@ -903,11 +900,10 @@ CONTAINS res = "K_e" CASE (cp_units_none) res = "energy" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -935,11 +931,10 @@ CONTAINS res = "au_temp" CASE (cp_units_none) res = "temperature" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -961,11 +956,10 @@ CONTAINS res = "au_p" CASE (cp_units_none) res = "pressure" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -977,11 +971,10 @@ CONTAINS res = "deg" CASE (cp_units_none) res = "angle" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -999,11 +992,10 @@ CONTAINS res = "wavenumber_t" CASE (cp_units_none) res = "time" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -1017,11 +1009,10 @@ CONTAINS res = "m_e" CASE (cp_units_none) res = "mass" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -1033,11 +1024,10 @@ CONTAINS res = "au_pot" CASE (cp_units_none) res = "potential" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -1051,11 +1041,10 @@ CONTAINS res = "au_f" CASE (cp_units_none) res = "force" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & 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 @@ -1071,11 +1060,10 @@ CONTAINS res = "au_efield" CASE (cp_units_none) res = "electric field" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown efield unit:"//TRIM(cp_to_string(basic_unit))) END SELECT diff --git a/src/common/distribution_1d_types.F b/src/common/distribution_1d_types.F index c875a3129f..8e23f4b29f 100644 --- a/src/common/distribution_1d_types.F +++ b/src/common/distribution_1d_types.F @@ -104,9 +104,8 @@ CONTAINS CALL para_env%retain() distribution_1d%listbased_distribution = .FALSE. - IF (PRESENT(listbased_distribution)) THEN + IF (PRESENT(listbased_distribution)) & distribution_1d%listbased_distribution = listbased_distribution - END IF ALLOCATE (distribution_1d%n_el(my_n_lists), distribution_1d%list(my_n_lists)) diff --git a/src/common/fparser.F b/src/common/fparser.F index 04f4f47f12..2e373db097 100644 --- a/src/common/fparser.F +++ b/src/common/fparser.F @@ -407,10 +407,10 @@ CONTAINS DO j = b, e IF (Func(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSE IF (Func(j:j) == ')') THEN + ELSEIF (Func(j:j) == ')') THEN ParCnt = ParCnt - 1 IF (ParCnt == 0) EXIT - ELSE IF (ParCnt == 1 .AND. Func(j:j) == ',') THEN + ELSEIF (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 - ELSE IF (F(j:j) == ')') THEN + ELSEIF (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 - ELSE IF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' + ELSEIF (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 - ELSE IF (SCAN(F(b:b), calpha) > 0) THEN + ELSEIF (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 - ELSE IF (F(b:b) == '-') THEN + ELSEIF (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 - ELSE IF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN + ELSEIF (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 - ELSE IF (F(j:j) == '(') THEN + ELSEIF (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 - ELSE IF (F(j:j) == ')') THEN + ELSEIF (F(j:j) == ')') THEN ParCnt = ParCnt - 1 - ELSE IF (ParCnt == 0 .AND. F(j:j) == ',') THEN + ELSEIF (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. - ELSE IF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? + ELSEIF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? res = .FALSE. - 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 + ELSEIF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? + SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN Dflag = .FALSE.; Pflag = .FALSE. k = j - 1 DO WHILE (k > 1) ! step to the left in mantissa k = k - 1 IF (SCAN(F(k:k), '0123456789') > 0) THEN Dflag = .TRUE. - ELSE IF (F(k:k) == '.') THEN + ELSEIF (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 - ELSE IF (Eflag) THEN + ELSEIF (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 - ELSE IF (Eflag) THEN + ELSEIF (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 - ELSE IF (InMan .AND. .NOT. Pflag) THEN + ELSEIF (InMan .AND. .NOT. Pflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' ELSE EXIT ! - otherwise STOP diff --git a/src/common/gfun.F b/src/common/gfun.F index 515c79098e..55c55bf64b 100644 --- a/src/common/gfun.F +++ b/src/common/gfun.F @@ -62,7 +62,7 @@ CONTAINS IF (t <= 12.0_dp) THEN ! downward recursion - g(nmax) = gfun_taylor(nmax, t) + g(nmax) = gfun_taylor(nmax, t); DO i = nmax, 1, -1 g(i - 1) = (1.0_dp - 2.0_dp*t*g(i))/(2.0_dp*i - 1.0_dp) END DO diff --git a/src/common/hash_map.fypp b/src/common/hash_map.fypp index ff5e066b74..ee755920b3 100644 --- a/src/common/hash_map.fypp +++ b/src/common/hash_map.fypp @@ -81,13 +81,11 @@ initial_capacity_ = 11 END IF - IF (initial_capacity_ < 1) THEN + IF (initial_capacity_ < 1) & CPABORT("initial_capacity < 1") - END IF - IF (ASSOCIATED(hash_map%buckets)) THEN + IF (ASSOCIATED(hash_map%buckets)) & CPABORT("hash map is already initialized.") - END IF ALLOCATE (hash_map%buckets(initial_capacity_)) hash_map%size = 0 diff --git a/src/common/list.fypp b/src/common/list.fypp index f0adb39843..37524a2570 100644 --- a/src/common/list.fypp +++ b/src/common/list.fypp @@ -87,18 +87,15 @@ initial_capacity_ = 11 If (PRESENT(initial_capacity)) initial_capacity_ = initial_capacity - IF (initial_capacity_ < 0) THEN + IF (initial_capacity_ < 0) & CPABORT("list_${valuetype}$_create: initial_capacity < 0") - END IF - IF (ASSOCIATED(list%arr)) THEN + IF (ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_create: list is already initialized.") - END IF ALLOCATE (list%arr(initial_capacity_), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_init: allocation failed") - END IF list%size = 0 END SUBROUTINE list_${valuetype}$_init @@ -115,9 +112,8 @@ SUBROUTINE list_${valuetype}$_destroy(list) TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_destroy: list is not initialized.") - END IF do i = 1, list%size deallocate (list%arr(i)%p) @@ -141,15 +137,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_in}$, intent(in) :: value INTEGER, intent(in) :: pos - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_set: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_set: pos < 1") - END IF - IF (pos > list%size) THEN + IF (pos > list%size) & CPABORT("list_${valuetype}$_set: pos > size") - END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_set @@ -166,18 +159,15 @@ ${valuetype_in}$, intent(in) :: value INTEGER :: stat - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_push: list is not initialized.") - END IF - IF (list%size == size(list%arr)) THEN - CALL change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) - END IF + if (list%size == size(list%arr)) & + call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) list%size = list%size + 1 ALLOCATE (list%arr(list%size)%p, stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_push: allocation failed") - END IF list%arr(list%size)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_push @@ -197,19 +187,15 @@ INTEGER, intent(in) :: pos INTEGER :: i, stat - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_insert: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_insert: pos < 1") - END IF - IF (pos > list%size + 1) THEN + IF (pos > list%size + 1) & CPABORT("list_${valuetype}$_insert: pos > size+1") - END IF - if (list%size == size(list%arr)) THEN + if (list%size == size(list%arr)) & call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) - END IF list%size = list%size + 1 do i = list%size, pos + 1, -1 @@ -217,9 +203,8 @@ end do ALLOCATE (list%arr(pos)%p, stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_insert: allocation failed.") - END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_insert @@ -236,12 +221,10 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_peek: list is not initialized.") - END IF - IF (list%size < 1) THEN + IF (list%size < 1) & CPABORT("list_${valuetype}$_peek: list is empty.") - END IF value ${value_assign}$list%arr(list%size)%p%value END FUNCTION list_${valuetype}$_peek @@ -262,12 +245,10 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_pop: list is not initialized.") - END IF - IF (list%size < 1) THEN + IF (list%size < 1) & CPABORT("list_${valuetype}$_pop: list is empty.") - END IF value ${value_assign}$list%arr(list%size)%p%value deallocate (list%arr(list%size)%p) @@ -285,13 +266,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & 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 @@ -310,15 +290,12 @@ INTEGER, intent(in) :: pos ${valuetype_out}$ :: value - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_get: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_get: pos < 1") - END IF - IF (pos > list%size) THEN + IF (pos > list%size) & CPABORT("list_${valuetype}$_get: pos > size") - END IF value ${value_assign}$list%arr(pos)%p%value @@ -337,20 +314,17 @@ INTEGER, intent(in) :: pos INTEGER :: i - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_del: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_det: pos < 1") - END IF - IF (pos > list%size) THEN + IF (pos > list%size) & 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 @@ -368,9 +342,8 @@ TYPE(list_${valuetype}$_type), intent(in) :: list INTEGER :: size - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_size: list is not initialized.") - END IF size = list%size END FUNCTION list_${valuetype}$_size @@ -390,34 +363,29 @@ TYPE(private_item_p_type_${valuetype}$), DIMENSION(:), POINTER :: old_arr new_cap = new_capacity - IF (new_cap < 0) THEN + IF (new_cap < 0) & CPABORT("list_${valuetype}$_change_capacity: new_capacity < 0") - END IF - IF (new_cap < list%size) THEN + IF (new_cap < list%size) & CPABORT("list_${valuetype}$_change_capacity: new_capacity < size") - END IF IF (new_cap > HUGE(i)) THEN - IF (size(list%arr) == HUGE(i)) THEN + IF (size(list%arr) == HUGE(i)) & 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) THEN + IF (stat /= 0) & 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) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_change_capacity: allocation failed") - END IF list%arr(i)%p%value ${value_assign}$old_arr(i)%p%value - DEALLOCATE (old_arr(i)%p) - END DO - DEALLOCATE (old_arr) + deallocate (old_arr(i)%p) + end do + deallocate (old_arr) END SUBROUTINE change_capacity_${valuetype}$ #:enddef diff --git a/src/common/mathlib.F b/src/common/mathlib.F index e1c5791b79..adf19a3a6e 100644 --- a/src/common/mathlib.F +++ b/src/common/mathlib.F @@ -187,8 +187,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = NORM2(a) - length_of_b = NORM2(b) + length_of_a = SQRT(DOT_PRODUCT(a, a)) + length_of_b = SQRT(DOT_PRODUCT(b, b)) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a @@ -997,9 +997,8 @@ CONTAINS ! set singular values that are too small to zero DO i = 1, n IF (sig(i) > rskip*MAXVAL(sig)) THEN - IF (PRESENT(determinant)) THEN + IF (PRESENT(determinant)) & determinant = determinant*sig(i) - END IF sig_plus(i, i) = 1._dp/sig(i) ELSE sig_plus(i, i) = 0.0_dp @@ -1976,14 +1975,12 @@ 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')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & 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')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & CPABORT("Unknown transpose character for array 2 (B).") - END IF CALL timeset(routineN, handle) @@ -2021,14 +2018,12 @@ 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')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & 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')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & CPABORT("Unknown transpose character for array 2 (B).") - END IF CALL timeset(routineN, handle) @@ -2073,19 +2068,16 @@ 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')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & 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')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & 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')) THEN + C_trans == 'C' .OR. C_trans == 'c')) & CPABORT("Unknown transpose character for array 3 (C).") - END IF CALL timeset(routineN, handle) @@ -2135,19 +2127,16 @@ 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')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & 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')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & 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')) THEN + C_trans == 'C' .OR. C_trans == 'c')) & CPABORT("Unknown transpose character for array 3 (C).") - END IF CALL timeset(routineN, handle) diff --git a/src/common/memory_utilities_unittest.F b/src/common/memory_utilities_unittest.F index 7aeb64e973..5534658c10 100644 --- a/src/common/memory_utilities_unittest.F +++ b/src/common/memory_utilities_unittest.F @@ -32,13 +32,11 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) THEN + IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) & ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values" - END IF - IF (.NOT. ALL(real_arr(11:20) == 0.)) THEN + IF (.NOT. ALL(real_arr(11:20) == 0.)) & ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -55,9 +53,8 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:20) == 0.)) THEN + IF (.NOT. ALL(real_arr(1:20) == 0.)) & ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -76,13 +73,11 @@ 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)]))) THEN + IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) & 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.))) THEN + IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) & ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -99,9 +94,8 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) THEN + IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) & ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -120,13 +114,11 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) THEN + IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) & ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values" - END IF - IF (.NOT. ALL(str_arr(11:20) == "")) THEN + IF (.NOT. ALL(str_arr(11:20) == "")) & ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." - END IF DEALLOCATE (str_arr) @@ -143,9 +135,8 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:20) == "")) THEN + IF (.NOT. ALL(str_arr(1:20) == "")) & ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." - END IF DEALLOCATE (str_arr) diff --git a/src/common/parallel_rng_types.F b/src/common/parallel_rng_types.F index e969d79b88..970e64ec22 100644 --- a/src/common/parallel_rng_types.F +++ b/src/common/parallel_rng_types.F @@ -512,9 +512,8 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision TYPE(rng_stream_type) :: rng_stream - IF (LEN_TRIM(name) > rng_name_length) THEN + IF (LEN_TRIM(name) > rng_name_length) & CPABORT("given random number generator name is too long") - END IF rng_stream%name = TRIM(name) @@ -631,16 +630,14 @@ CONTAINS LOGICAL, INTENT(OUT), OPTIONAL :: buffer_filled IF (PRESENT(name)) name = self%name - IF (PRESENT(distribution_type)) THEN + IF (PRESENT(distribution_type)) & 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)) THEN + IF (PRESENT(extended_precision)) & 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 @@ -1134,9 +1131,8 @@ CONTAINS my_write_all = .FALSE. - IF (PRESENT(write_all)) THEN + IF (PRESENT(write_all)) & my_write_all = write_all - END IF WRITE (UNIT=output_unit, FMT="(/,T2,A,/)") & "Random number stream <"//TRIM(self%name)//">:" diff --git a/src/common/parallel_rng_types_unittest.F b/src/common/parallel_rng_types_unittest.F index 142e5f2ab9..87cf2640f7 100644 --- a/src/common/parallel_rng_types_unittest.F +++ b/src/common/parallel_rng_types_unittest.F @@ -32,16 +32,14 @@ PROGRAM parallel_rng_types_TEST nsamples = 1000 nargs = command_argument_count() - IF (nargs > 1) then + IF (nargs > 1) & ERROR STOP "Usage: parallel_rng_types_TEST []" - end if IF (nargs == 1) THEN CALL get_command_argument(1, arg) READ (arg, *, iostat=stat) nsamples - IF (stat /= 0) then + IF (stat /= 0) & ERROR STOP "Usage: parallel_rng_types_TEST []" - end if END IF CALL mp_world_init(mpi_comm) @@ -62,9 +60,8 @@ PROGRAM parallel_rng_types_TEST distribution_type=UNIFORM, & extended_precision=.TRUE.) - IF (ionode) then + IF (ionode) & CALL rng_stream%write(default_output_unit) - end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -97,9 +94,8 @@ PROGRAM parallel_rng_types_TEST distribution_type=GAUSSIAN, & extended_precision=.TRUE.) - IF (ionode) then + IF (ionode) & CALL rng_stream%write(default_output_unit) - end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -166,9 +162,8 @@ 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)) then + .OR. (name /= name_orig)) & ERROR STOP "Stream dump and load roundtrip failed" - end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Roundtrip successful" @@ -190,9 +185,8 @@ CONTAINS WRITE (UNIT=default_output_unit, FMT="(T4,A10,A433)") & "GENERATED:", rng_record - IF (rng_record /= serialized_string) then + IF (rng_record /= serialized_string) & 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" @@ -220,22 +214,19 @@ CONTAINS arr = orig CALL rng_stream%shuffle(arr) - IF (ALL(arr == orig)) then + IF (ALL(arr == orig)) & ERROR STOP "shuffle failed: array was left untouched" - end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." - IF (ANY(arr /= orig(arr))) then + IF (ANY(arr /= orig(arr))) & 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)) then + IF (MINVAL(arr, mask) /= orig(idx)) & 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") "." @@ -244,9 +235,8 @@ CONTAINS CALL rng_stream%reset() CALL rng_stream%shuffle(arr2) - IF (ANY(arr2 /= arr)) then + IF (ANY(arr2 /= arr)) & ERROR STOP "shuffle failed: array was shuffled differently with same rng state" - end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." WRITE (UNIT=default_output_unit, FMT="(T4,A)") & diff --git a/src/common/reference_manager.F b/src/common/reference_manager.F index 8ba42beaff..f900554659 100644 --- a/src/common/reference_manager.F +++ b/src/common/reference_manager.F @@ -332,18 +332,14 @@ CONTAINS WRITE (unit, '(T3,A)') ''//thebib(i)%ref%source//'' ! DOI, volume, pages, year, month. - IF (ALLOCATED(thebib(i)%ref%doi)) THEN + IF (ALLOCATED(thebib(i)%ref%doi)) & WRITE (unit, '(T3,A)') ''//TRIM(substitute_special_xml_tokens(thebib(i)%ref%doi))//'' - END IF - IF (ALLOCATED(thebib(i)%ref%volume)) THEN + IF (ALLOCATED(thebib(i)%ref%volume)) & WRITE (unit, '(T3,A)') ''//thebib(i)%ref%volume//'' - END IF - IF (ALLOCATED(thebib(i)%ref%pages)) THEN + IF (ALLOCATED(thebib(i)%ref%pages)) & WRITE (unit, '(T3,A)') ''//thebib(i)%ref%pages//'' - END IF - IF (thebib(i)%ref%year > 0) THEN + IF (thebib(i)%ref%year > 0) & WRITE (unit, '(T3,A,I4.4,A)') '', thebib(i)%ref%year, '' - END IF WRITE (unit, '(T2,A)') '' END DO diff --git a/src/common/spherical_harmonics.F b/src/common/spherical_harmonics.F index 96bd808f89..52d62548c6 100644 --- a/src/common/spherical_harmonics.F +++ b/src/common/spherical_harmonics.F @@ -1805,42 +1805,30 @@ CONTAINS REAL(KIND=dp) :: sumk, t ! Check validity of the input parameters - IF (j1 < 0.0_dp) THEN + IF (j1 < 0.0_dp) & CPABORT("The angular momentum quantum number j1 has to be nonnegative") - END IF - IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) THEN + IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) & CPABORT("The angular momentum quantum number j1 has to be integer or half-integer") - END IF - IF (j2 < 0.0_dp) THEN + IF (j2 < 0.0_dp) & CPABORT("The angular momentum quantum number j2 has to be nonnegative") - END IF - IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) THEN + IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) & CPABORT("The angular momentum quantum number j2 has to be integer or half-integer") - END IF - IF (J < 0.0_dp) THEN + IF (J < 0.0_dp) & CPABORT("The angular momentum quantum number J has to be nonnegative") - END IF - IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) THEN + IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) & CPABORT("The angular momentum quantum number J has to be integer or half-integer") - END IF - IF ((ABS(m1) - j1) > EPSILON(m1)) THEN + IF ((ABS(m1) - j1) > EPSILON(m1)) & CPABORT("The angular momentum quantum number m1 has to satisfy -j1 <= m1 <= j1") - END IF - IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) THEN + IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) & CPABORT("The angular momentum quantum number m1 has to be integer or half-integer") - END IF - IF ((ABS(m2) - j2) > EPSILON(m2)) THEN + IF ((ABS(m2) - j2) > EPSILON(m2)) & CPABORT("The angular momentum quantum number m2 has to satisfy -j2 <= m1 <= j2") - END IF - IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) THEN + IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) & CPABORT("The angular momentum quantum number m2 has to be integer or half-integer") - END IF - IF ((ABS(M) - J) > EPSILON(M)) THEN + IF ((ABS(M) - J) > EPSILON(M)) & CPABORT("The angular momentum quantum number M has to satisfy -J <= M <= J") - END IF - IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) THEN + IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) & 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. & @@ -1884,8 +1872,8 @@ CONTAINS ! ************************************************************************************************** !> \brief Compute the Wigner 3-j symbol -!> ( j1 j2 j3 ) -!> ( m1 m2 m3 ) +!> / j1 j2 j3 \ +!> \ m1 m2 m3 / !> using the Clebsch-Gordon coefficients !> \param j1 Angular momentum quantum number of the first state | j1 m1 > !> \param m1 Magnetic quantum number of the first first state | j1 m1 > diff --git a/src/common/splines.F b/src/common/splines.F index bcfc9252d5..6d808dfad9 100644 --- a/src/common/splines.F +++ b/src/common/splines.F @@ -311,21 +311,21 @@ CONTAINS i1 = 1 IF (n < 2) THEN CALL stop_error("error in iix: n < 2") - ELSE IF (n == 2) THEN + ELSEIF (n == 2) THEN i1 = 1 - ELSE IF (n == 3) THEN + ELSEIF (n == 3) THEN IF (x <= xi(2)) THEN ! first element i1 = 1 ELSE i1 = 2 END IF - ELSE IF (x <= xi(1)) THEN ! left end + ELSEIF (x <= xi(1)) THEN ! left end i1 = 1 - ELSE IF (x <= xi(2)) THEN ! first element + ELSEIF (x <= xi(2)) THEN ! first element i1 = 1 - ELSE IF (x <= xi(3)) THEN ! second element + ELSEIF (x <= xi(3)) THEN ! second element i1 = 2 - ELSE IF (x >= xi(n)) THEN ! right end + ELSEIF (x >= xi(n)) THEN ! right end i1 = n - 1 ELSE ! bisection: xi(i1) <= x < xi(i2) diff --git a/src/common/timings.F b/src/common/timings.F index d327324b23..fb81e07f11 100644 --- a/src/common/timings.F +++ b/src/common/timings.F @@ -96,9 +96,8 @@ 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_)) THEN + IF (.NOT. ASSOCIATED(timer_env_)) & 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) @@ -158,12 +157,10 @@ CONTAINS SUBROUTINE timer_env_retain(timer_env) TYPE(timer_env_type), POINTER :: timer_env - IF (.NOT. ASSOCIATED(timer_env)) THEN + IF (.NOT. ASSOCIATED(timer_env)) & CPABORT("timer_env_retain: not associated") - END IF - IF (timer_env%ref_count < 0) THEN + IF (timer_env%ref_count < 0) & CPABORT("timer_env_retain: negativ ref_count") - END IF timer_env%ref_count = timer_env%ref_count + 1 END SUBROUTINE timer_env_retain @@ -179,12 +176,10 @@ CONTAINS TYPE(callgraph_item_type), DIMENSION(:), POINTER :: ct_items TYPE(routine_stat_type), POINTER :: r_stat - IF (.NOT. ASSOCIATED(timer_env)) THEN + IF (.NOT. ASSOCIATED(timer_env)) & CPABORT("timer_env_release: not associated") - END IF - IF (timer_env%ref_count < 0) THEN + IF (timer_env%ref_count < 0) & 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 @@ -442,12 +437,10 @@ 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)) THEN + IF (.NOT. list_isready(timers_stack)) & RETURN - END IF - IF (list_size(timers_stack) == 0) THEN + IF (list_size(timers_stack) == 0) & RETURN - END IF timer_env => list_peek(timers_stack) WRITE (unit_nr, '(/,A,/)') " ===== Routine Calling Stack ===== " diff --git a/src/common/timings_report.F b/src/common/timings_report.F index 03b5a4166d..eedcf3e659 100644 --- a/src/common/timings_report.F +++ b/src/common/timings_report.F @@ -77,9 +77,8 @@ CONTAINS CALL list_init(reports) CALL collect_reports_from_ranks(reports, cost_type, para_env) - IF (list_size(reports) > 0 .AND. iw > 0) THEN + IF (list_size(reports) > 0 .AND. iw > 0) & 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) @@ -112,9 +111,8 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env NULLIFY (r_stat, r_report, timer_env) - IF (.NOT. list_isready(reports)) THEN + IF (.NOT. list_isready(reports)) & CPABORT("BUG") - END IF timer_env => get_timer_env() @@ -234,9 +232,8 @@ CONTAINS TYPE(routine_report_type), POINTER :: r_report_i, r_report_j NULLIFY (r_report_i, r_report_j) - IF (.NOT. list_isready(reports)) THEN + IF (.NOT. list_isready(reports)) & CPABORT("BUG") - END IF ! are we printing timing or energy ? SELECT CASE (cost_type) diff --git a/src/common/util.F b/src/common/util.F index 1c1988135b..f20e1ebfff 100644 --- a/src/common/util.F +++ b/src/common/util.F @@ -174,7 +174,7 @@ CONTAINS IF (j == 1) THEN DO i = 1, isize INDEX(i) = i - END DO + ENDDO END IF ! Allocate scratch arrays diff --git a/src/commutator_rpnl.F b/src/commutator_rpnl.F index 669f952309..db7084cbf9 100644 --- a/src/commutator_rpnl.F +++ b/src/commutator_rpnl.F @@ -217,7 +217,7 @@ CONTAINS nprj_ppnl => gpotential(kkind)%gth_potential%nprj_ppnl ppnl_radius = gpotential(kkind)%gth_potential%ppnl_radius vprj_ppnl => gpotential(kkind)%gth_potential%vprj_ppnl - ELSE IF (spot) THEN + ELSEIF (spot) THEN CPABORT('SGP not implemented') ELSE CPABORT('PPNL unknown') @@ -868,304 +868,282 @@ 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))) - ! -yVz + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV 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))) - ! -zyV + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! -yVz 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))) - ! zVy + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -zyV 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))) + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! zVy 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))) - ! -yVz + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV 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))) - ! -zyV + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! -yVz 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))) - ! zVy + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! -zyV 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))) + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) ! zVy 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))) - ! -zVx + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zxV 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))) - ! -xzV + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! -zVx 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))) - ! xVz + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -xzV 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))) + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz 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))) - ! -zVx + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! zxV 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))) - ! -xzV + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) ! -zVx 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))) - ! xVz + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! -xzV 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))) + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz 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))) - ! -xVy + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV 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))) - ! -yxV + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! -xVy 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))) - ! zVx + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -yxV 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))) + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! zVx 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))) - ! -xVy + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV 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))) - ! -yxV + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! -xVy 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))) - ! zVx + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! -yxV 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))) + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) ! zVx 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))) - ! xyV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV 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))) - ! xzV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV 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))) - ! yyV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV 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))) - ! yzV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV 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))) - ! zzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV 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))) + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV 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))) - ! xyV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV 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))) - ! xzV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV 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))) - ! yyV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV 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))) - ! yzV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV 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))) - ! zzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV 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))) + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV 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))) - ! -Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! -Vxx 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))) - ! -Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! -Vxy 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))) - ! -Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! -Vxz 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))) - ! -Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! -Vyy 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))) - ! -Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! -Vyz 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))) + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! -Vzz 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))) - ! -Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! -Vxx 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))) - ! -Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! -Vxy 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))) - ! -Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! -Vxz 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))) - ! -Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! -Vyy 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))) - ! -Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! -Vyz 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))) + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! -Vzz 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))) - ! xVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! xVx 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))) - ! xVz + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! xVy 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))) - ! yVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz 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))) - ! yVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! yVy 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))) - ! zVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! yVz 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))) + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! zVz 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))) - ! xVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) ! xVx 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))) - ! xVz + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! xVy 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))) - ! yVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz 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))) - ! yVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) ! yVy 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))) - ! zVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! yVz 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))) + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) ! zVz 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))) - ! xyV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV 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))) - ! xzV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV 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))) - ! yyV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV 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))) - ! yzV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV 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))) - ! zzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV 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))) + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV 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))) - ! xyV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV 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))) - ! xzV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV 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))) - ! yyV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV 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))) - ! yzV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV 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))) - ! zzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV 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))) + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV 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))) - ! +Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! +Vxx 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))) - ! +Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! +Vxy 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))) - ! +Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! +Vxz 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))) - ! +Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! +Vyy 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))) - ! +Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! +Vyz 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))) + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! +Vzz 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))) - ! +Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! +Vxx 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))) - ! +Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! +Vxy 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))) - ! +Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! +Vxz 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))) - ! +Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! +Vyy 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))) - ! +Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! +Vyz 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))) + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! +Vzz END IF END IF ! The indices are stored in i_1, i_x, ..., i_zzz + ! matrix_r_rxvr(alpha, beta) + ! = sum_(gamma delta) epsilon_(alpha gamma delta) + ! (r_beta * r_gamma * V_nl * r_delta - r_beta * r_gamma * r_delta * V_nl) + ! = sum_(gamma delta) epsilon_(alpha gamma delta) r_beta * r_gamma * V_nl * r_delta ! TODO: is this set to zero before? IF (my_r_rxvr) THEN diff --git a/src/constraint.F b/src/constraint.F index c8bdc9e2fa..e6d1308ea4 100644 --- a/src/constraint.F +++ b/src/constraint.F @@ -157,51 +157,43 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL shake_3x3_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL shake_4x6_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & 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) THEN + IF (nvsitecon /= 0) & 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) THEN + IF (gci%ng3x3 /= 0) & CALL shake_3x3_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL shake_4x6_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & CALL shake_colv_ext(gci, particle_set, pos, vel, dt, ishake_ext, & cell, imass, max_sigma) - END IF ! Virtual Site - IF (gci%nvsite /= 0) THEN + IF (gci%nvsite /= 0) & 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) @@ -291,18 +283,15 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL rattle_3x3_int(molecule, particle_set, vel, dt) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL rattle_4x6_int(molecule, particle_set, vel, dt) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & 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) @@ -312,18 +301,15 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & CALL rattle_3x3_ext(gci, particle_set, vel, dt) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL rattle_4x6_ext(gci, particle_set, vel, dt) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & 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) @@ -431,20 +417,17 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & 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) THEN + IF (n4x6con /= 0) & 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) THEN + IF (ncolv%ntot /= 0) & 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) @@ -458,24 +441,20 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & 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) THEN + IF (gci%ng4x6 /= 0) & 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) THEN + IF (gci%ncolv%ntot /= 0) & 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) THEN + IF (gci%nvsite /= 0) & 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) @@ -585,20 +564,17 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL rattle_roll_3x3_int(molecule, particle_set, vel, r_rattle, dt, & veps) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL rattle_roll_4x6_int(molecule, particle_set, vel, r_rattle, dt, & veps) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & 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) @@ -608,20 +584,17 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(para_env, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & CALL rattle_roll_3x3_ext(gci, particle_set, vel, r_rattle, dt, & veps) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL rattle_roll_4x6_ext(gci, particle_set, vel, r_rattle, dt, & veps) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & 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) @@ -735,7 +708,7 @@ CONTAINS IF (log_unit > 0) THEN IF (id_type == "S") THEN label = "Shake Lagrangian Multipliers:" - ELSE IF (id_type == "R") THEN + ELSEIF (id_type == "R") THEN label = "Rattle Lagrangian Multipliers:" ELSE CPABORT("Only S for Shake or R for Rattle are supported for Lagrangian Multipliers") @@ -770,12 +743,11 @@ 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) THEN + IF (ishake_int > Max_Shake_Iter) & 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 ! ************************************************************************************************** @@ -797,11 +769,10 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_ext > Max_Shake_Iter) THEN + IF (ishake_ext > Max_Shake_Iter) & 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 ! ************************************************************************************************** @@ -823,12 +794,11 @@ 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) THEN + IF (irattle_int > Max_shake_Iter) & 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 ! ************************************************************************************************** @@ -850,11 +820,10 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_ext > Max_shake_Iter) THEN + IF (irattle_ext > Max_shake_Iter) & CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") - END IF END SUBROUTINE rattle_ext_info ! ************************************************************************************************** diff --git a/src/constraint_fxd.F b/src/constraint_fxd.F index b4f9e7b7e8..225416d12d 100644 --- a/src/constraint_fxd.F +++ b/src/constraint_fxd.F @@ -398,9 +398,8 @@ 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) THEN + IF (.NOT. fixd_list(k)%restraint%active) & colvar%dsdr(:, i) = 0.0_dp - END IF EXIT END IF END DO diff --git a/src/constraint_util.F b/src/constraint_util.F index dec377128b..0570c248f1 100644 --- a/src/constraint_util.F +++ b/src/constraint_util.F @@ -554,8 +554,8 @@ CONTAINS v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) diag = MATMUL(r_shake, v_shake) r_shake = diag - ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & - PRESENT(vector_r)) THEN + ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & + PRESENT(vector_r)) THEN DO i = 1, 3 r_shake(i, i) = vector_r(i)*vector_v(i) v_shake(i, i) = vector_v(i) @@ -569,7 +569,7 @@ CONTAINS diag(2, 2) = vector_v(2) diag(3, 3) = vector_v(3) v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) - ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN + ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN DO i = 1, 3 v_shake(i, i) = vector_v(i) END DO diff --git a/src/constraint_vsite.F b/src/constraint_vsite.F index ffdbb8ba52..12c4cd96c5 100644 --- a/src/constraint_vsite.F +++ b/src/constraint_vsite.F @@ -94,16 +94,14 @@ CONTAINS molecule_kind => molecule%molecule_kind CALL get_molecule_kind(molecule_kind, nconstraint=nconstraint, nvsite=nvsitecon) IF (nconstraint == 0) CYCLE - IF (nvsitecon /= 0) THEN + IF (nvsitecon /= 0) & 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) THEN + IF (gci%nvsite /= 0) & CALL force_vsite_ext(gci, particle_set) - END IF END IF END SUBROUTINE vsite_force_control diff --git a/src/core_ppl.F b/src/core_ppl.F index e47510449d..c1041e16d2 100644 --- a/src/core_ppl.F +++ b/src/core_ppl.F @@ -448,7 +448,7 @@ CONTAINS IF (ecp_semi_local) THEN CALL get_potential(potential=sgp_potential, sl_lmax=slmax, & npot=npot, nrpot=nrpot, apot=apot, bpot=bpot) - ELSE IF (ecp_local) THEN + ELSEIF (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) - ELSE IF (libgrpp_local) THEN + ELSEIF (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 - ELSE IF (do_dR) THEN + ELSEIF (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) - ELSE IF (libgrpp_local) THEN + ELSEIF (libgrpp_local) THEN !If the local part of the potential is more complex, we need libgrpp !$OMP CRITICAL(type1) CALL libgrpp_local_integrals(la_max(iset), la_min(iset), npgfa(iset), & diff --git a/src/core_ppnl.F b/src/core_ppnl.F index 7fc2104d7e..906658762a 100644 --- a/src/core_ppnl.F +++ b/src/core_ppnl.F @@ -667,7 +667,7 @@ CONTAINS END IF IF (do_dR) THEN - i = 1; j = 2 + i = 1; j = 2; katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + & @@ -686,7 +686,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 2; j = 3 + i = 2; j = 3; katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_2block(1:na, 1:nb) = r_2block(1:na, 1:nb) + & @@ -705,7 +705,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 3; j = 4 + i = 3; j = 4; katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_3block(1:na, 1:nb) = r_3block(1:na, 1:nb) + & diff --git a/src/cp2k_debug.F b/src/cp2k_debug.F index 73184d0fb2..3d288eeb82 100644 --- a/src/cp2k_debug.F +++ b/src/cp2k_debug.F @@ -98,7 +98,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(3) :: dipole_moment, dipole_numer, err, & my_maxerr, poldir REAL(KIND=dp), DIMENSION(3, 2) :: dipn - REAL(KIND=dp), DIMENSION(3, 3) :: polar_analytic, polar_numeric, polerr + REAL(KIND=dp), DIMENSION(3, 3) :: polar_analytic, polar_numeric REAL(KIND=dp), DIMENSION(9) :: pvals REAL(KIND=dp), DIMENSION(:, :), POINTER :: analyt_forces, numer_forces TYPE(cell_type), POINTER :: cell @@ -569,7 +569,6 @@ 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 [%]" @@ -580,7 +579,6 @@ 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 @@ -590,16 +588,6 @@ 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") @@ -624,7 +612,7 @@ CONTAINS IF (dft_control%apply_efield) THEN dft_control%efield_fields(1)%efield%strength = amplitude dft_control%efield_fields(1)%efield%polarisation(1:3) = poldir(1:3) - ELSE IF (dft_control%apply_period_efield) THEN + ELSEIF (dft_control%apply_period_efield) THEN dft_control%period_efield%strength = amplitude dft_control%period_efield%polarisation(1:3) = poldir(1:3) ELSE diff --git a/src/cp2k_info.F b/src/cp2k_info.F index cc90bc1d31..872951cffd 100644 --- a/src/cp2k_info.F +++ b/src/cp2k_info.F @@ -46,7 +46,7 @@ MODULE cp2k_info #endif !!! Keep version in sync with CMakeLists.txt !!! - CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.2 (Development Version)" + CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.2" CHARACTER(LEN=*), PARAMETER :: cp2k_year = "2026" CHARACTER(LEN=*), PARAMETER :: cp2k_home = "https://www.cp2k.org/" diff --git a/src/cp_control_types.F b/src/cp_control_types.F index ff28629fb2..47d3cb3bf7 100644 --- a/src/cp_control_types.F +++ b/src/cp_control_types.F @@ -278,7 +278,6 @@ 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 @@ -297,7 +296,6 @@ 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. @@ -312,11 +310,7 @@ MODULE cp_control_types DIMENSION(:, :), POINTER :: kab_param => NULL() INTEGER, DIMENSION(:, :), POINTER :: kab_types => NULL() INTEGER :: kab_nval = 0 - REAL(KIND=dp), DIMENSION(:), POINTER :: kab_vals => NULL() - ! - INTEGER, DIMENSION(:), POINTER :: spinpol_type => NULL() - REAL(KIND=dp), DIMENSION(:, :), & - POINTER :: spinpol_vals => NULL() + REAL, DIMENSION(:), POINTER :: kab_vals => NULL() ! TYPE(pair_potential_p_type), POINTER :: nonbonded => NULL() REAL(KIND=dp) :: eps_pair = 0.0_dp @@ -897,9 +891,8 @@ CONTAINS SUBROUTINE mulliken_control_release(mulliken_restraint_control) TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken_restraint_control - IF (ASSOCIATED(mulliken_restraint_control%atoms)) THEN + IF (ASSOCIATED(mulliken_restraint_control%atoms)) & 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 @@ -934,12 +927,10 @@ CONTAINS SUBROUTINE ddapc_control_release(ddapc_restraint_control) TYPE(ddapc_restraint_type), INTENT(INOUT) :: ddapc_restraint_control - IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN + IF (ASSOCIATED(ddapc_restraint_control%atoms)) & DEALLOCATE (ddapc_restraint_control%atoms) - END IF - IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN + IF (ASSOCIATED(ddapc_restraint_control%coeff)) & 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 @@ -1216,21 +1207,18 @@ 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)) THEN + IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) & 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)) THEN + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) & DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_index) - END IF - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) THEN + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) & DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_occ) - END IF DEALLOCATE (proj_mo_list(i)%proj_mo) END IF END DO @@ -1256,9 +1244,8 @@ 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)) THEN + IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) & DEALLOCATE (efield_fields(i)%efield%polarisation) - END IF DEALLOCATE (efield_fields(i)%efield) END IF END DO @@ -1309,8 +1296,6 @@ 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 @@ -1337,12 +1322,6 @@ CONTAINS IF (ASSOCIATED(xtb_control%nonbonded)) THEN CALL pair_potential_p_release(xtb_control%nonbonded) END IF - IF (ASSOCIATED(xtb_control%spinpol_type)) THEN - DEALLOCATE (xtb_control%spinpol_type) - END IF - IF (ASSOCIATED(xtb_control%spinpol_vals)) THEN - DEALLOCATE (xtb_control%spinpol_vals) - END IF DEALLOCATE (xtb_control) END IF END SUBROUTINE xtb_control_release diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index e98ef32ade..3a2478e19e 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -56,16 +56,16 @@ MODULE cp_control_utils do_se_is_slater, do_se_lr_ewald, do_se_lr_ewald_gks, do_se_lr_ewald_r3, do_se_lr_none, & gapw_1c_large, gapw_1c_medium, gapw_1c_orb, gapw_1c_small, gapw_1c_very_large, & gaussian_env, gfn1xtb, gfn_tblite, kg_tnadd_embed, kg_tnadd_embed_ri, no_admm_type, & - numerical, ramp_env, real_time_propagation, rtp_method_bse, rtp_method_bse_linearized, & - sccs_andreussi, sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, & - sccs_derivative_fft, sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, & - sic_list_all, sic_list_unpaired, sic_mauri_spz, sic_mauri_us, sic_none, slater, & - tblite_cli_born_kernel_auto, tblite_cli_solution_state_gsolv, tblite_cli_solvation_alpb, & - tblite_cli_solvation_cpcm, tblite_cli_solvation_gb, tblite_cli_solvation_gbe, & - tblite_cli_solvation_gbsa, tblite_guess_ceh, tblite_mixer_memory_inherit, & - tblite_scc_mixer_auto, tblite_scc_mixer_cp2k, tblite_scc_mixer_none, & - tblite_scc_mixer_tblite, tblite_solver_gvd, tblite_solver_gvr, tddfpt_dipole_length, & - tddfpt_kernel_stda, use_mom_ref_user, xtb_vdw_type_d3, xtb_vdw_type_d4, xtb_vdw_type_none + numerical, ramp_env, real_time_propagation, rtp_method_bse, sccs_andreussi, & + sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, sccs_derivative_fft, & + sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, sic_list_all, sic_list_unpaired, & + sic_mauri_spz, sic_mauri_us, sic_none, slater, tblite_cli_born_kernel_auto, & + tblite_cli_solution_state_gsolv, tblite_cli_solvation_alpb, tblite_cli_solvation_cpcm, & + tblite_cli_solvation_gb, tblite_cli_solvation_gbe, tblite_cli_solvation_gbsa, & + tblite_guess_ceh, tblite_mixer_memory_inherit, tblite_scc_mixer_auto, & + tblite_scc_mixer_cp2k, tblite_scc_mixer_none, tblite_scc_mixer_tblite, tblite_solver_gvd, & + tblite_solver_gvr, tddfpt_dipole_length, tddfpt_kernel_stda, use_mom_ref_user, & + xtb_vdw_type_d3, xtb_vdw_type_d4, xtb_vdw_type_none USE input_cp2k_check, ONLY: xc_functionals_expand USE input_cp2k_dft, ONLY: create_dft_section USE input_enumeration_types, ONLY: enum_i2c,& @@ -164,23 +164,20 @@ 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) THEN + IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) & 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) THEN + IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) & 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) THEN + IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) & 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) @@ -245,18 +242,7 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - SELECT CASE (tmpstringlist(1)) - CASE ("X") - ! Do nothing - CASE DEFAULT - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS: the size is invalid for the "// & - "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & - "use one of SMALL, MEDIUM, LARGE, HUGE for "// & - "the size. The syntax AUTO_BASIS X X is a "// & - "reserved case for using NO automatically "// & - "generated basis sets.") - END SELECT + isize = -1 CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -419,9 +405,8 @@ 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) THEN + IF (dft_control%admm_control%method /= do_admm_basis_projection) & CPABORT("ADMM: Chosen purification requires BASIS_PROJECTION") - END IF IF (.NOT. do_ot) CPABORT("ADMM: MO-based purification requires OT.") END IF @@ -444,10 +429,9 @@ 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) THEN + IF (.NOT. dft_control%uks) & 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 @@ -566,8 +550,7 @@ 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. & - dft_control%rtp_control%rtp_method == rtp_method_bse_linearized) .OR. & + local_moment_possible = (dft_control%rtp_control%rtp_method == rtp_method_bse) .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") @@ -584,9 +567,8 @@ 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)) THEN + IF (ASSOCIATED(cell)) & 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) @@ -666,12 +648,7 @@ CONTAINS END IF ! periodic fields don't work with 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 + CPASSERT(.NOT. do_rtp) IF (dft_control%period_efield%displacement_field) THEN CALL cite_reference(Stengel2009) ELSE @@ -986,12 +963,11 @@ 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, znum + ngauss, ngp, nrep 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, & @@ -1241,9 +1217,8 @@ CONTAINS jj = jj + SIZE(tmplist) END DO qs_control%mulliken_restraint_control%natoms = jj - IF (qs_control%mulliken_restraint_control%natoms < 1) THEN + IF (qs_control%mulliken_restraint_control%natoms < 1) & 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 @@ -1291,11 +1266,10 @@ 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) THEN + IF (qs_control%se_control%integral_screening /= do_se_IS_slater) & 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 @@ -1360,23 +1334,21 @@ 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) THEN + IF (qs_control%method_id /= do_method_pnnl) & 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) THEN + IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) & 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 @@ -1440,21 +1412,18 @@ 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) THEN + qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & CALL cp_warn(__LOCATION__, & "DFTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - END IF - IF (dftb_tblite_mixer_explicit) THEN + IF (dftb_tblite_mixer_explicit) & 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) THEN + IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) & 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) @@ -1514,9 +1483,8 @@ 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) THEN + IF (.NOT. tblite_section_active) & 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 @@ -1537,43 +1505,37 @@ 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) THEN + IF (xtb_tblite_mixer_explicit) & 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) THEN + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") - END IF - IF (xtb_tblite_mixer_explicit) THEN + IF (xtb_tblite_mixer_explicit) & 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) THEN + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - END IF - IF (xtb_tblite_mixer_explicit) THEN + IF (xtb_tblite_mixer_explicit) & 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) THEN + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & 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", & @@ -1581,9 +1543,6 @@ 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 @@ -1635,9 +1594,6 @@ 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) @@ -1861,26 +1817,6 @@ 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) @@ -1919,17 +1855,14 @@ 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) THEN + IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) & CPABORT("XTB/TBLITE/ACCURACY must be positive") - END IF - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & 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)) THEN + IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) & 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. @@ -1993,9 +1926,8 @@ 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) THEN + IF (max_weight < min_weight) & 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 @@ -2044,13 +1976,11 @@ 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) THEN + IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) & 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) THEN + ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) & 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) @@ -2062,21 +1992,18 @@ 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) THEN + IF (ref_cli%electronic_temperature_guess < 0.0_dp) & CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") - END IF - IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) THEN + IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) & 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) THEN + IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) & 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 @@ -2107,12 +2034,10 @@ 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) THEN + IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) & CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs PARAM_FILE") - END IF - IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) THEN + IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) & 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) @@ -2120,12 +2045,10 @@ 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) THEN + IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) & CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs ACTUAL") - END IF - IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) THEN + IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) & 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) @@ -2199,18 +2122,7 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - SELECT CASE (tmpstringlist(1)) - CASE ("X") - ! Do nothing - CASE DEFAULT - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS: the size is invalid for the "// & - "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & - "use one of SMALL, MEDIUM, LARGE, HUGE for "// & - "the size. The syntax AUTO_BASIS X X is a "// & - "reserved case for using NO automatically "// & - "generated basis sets.") - END SELECT + isize = -1 CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -2236,9 +2148,8 @@ CONTAINS END IF END DO - IF (t_control%conv < 0) THEN + IF (t_control%conv < 0) & t_control%conv = ABS(t_control%conv) - END IF ! DIPOLE_MOMENTS subsection dipole_section => section_vals_get_subs_vals(t_section, "DIPOLE_MOMENTS") @@ -2280,10 +2191,9 @@ 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) THEN + IF (t_control%mgrid_progression_factor <= 1.0_dp) & 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 @@ -2317,9 +2227,8 @@ 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) THEN + IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) & 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 @@ -2334,9 +2243,8 @@ 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) THEN + IF (explicit) & CALL xc_functionals_expand(xc_func, xc_section) - END IF ! sTDA subsection stda_section => section_vals_get_subs_vals(t_section, "STDA") @@ -2556,7 +2464,8 @@ CONTAINS dft_control%period_efield%strength END IF - IF (NORM2(dft_control%period_efield%polarisation) < EPSILON(0.0_dp)) THEN + IF (SQRT(DOT_PRODUCT(dft_control%period_efield%polarisation, & + dft_control%period_efield%polarisation)) < EPSILON(0.0_dp)) THEN CPABORT("Invalid (too small) polarisation vector specified for PERIODIC_EFIELD") END IF END IF @@ -2965,9 +2874,8 @@ 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) THEN + IF (qs_control%commensurate_mgrids) & 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)") & @@ -3097,10 +3005,9 @@ 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) THEN + IF (SIZE(qs_control%ddapc_restraint_control) > 1) & WRITE (UNIT=output_unit, FMT="(T2,A,T3,I8)") & - "QS| parameters for DDAPC restraint number", i - END IF + "QS| parameters for DDAPC restraint number", i 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)") & @@ -3171,9 +3078,8 @@ CONTAINS IF (PRESENT(ddapc_restraint_section)) THEN IF (ASSOCIATED(qs_control%ddapc_restraint_control)) THEN - IF (SIZE(qs_control%ddapc_restraint_control) >= 2) THEN + IF (SIZE(qs_control%ddapc_restraint_control) >= 2) & 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)) @@ -3212,9 +3118,8 @@ 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)) THEN + IF (ASSOCIATED(ddapc_restraint_control%atoms)) & DEALLOCATE (ddapc_restraint_control%atoms) - END IF ALLOCATE (ddapc_restraint_control%atoms(ddapc_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -3226,9 +3131,8 @@ CONTAINS END DO END DO - IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN + IF (ASSOCIATED(ddapc_restraint_control%coeff)) & DEALLOCATE (ddapc_restraint_control%coeff) - END IF ALLOCATE (ddapc_restraint_control%coeff(ddapc_restraint_control%natoms)) ddapc_restraint_control%coeff = 1.0_dp @@ -3240,15 +3144,13 @@ CONTAINS i_rep_val=k, r_vals=rtmplist) DO j = 1, SIZE(rtmplist) jj = jj + 1 - IF (jj > ddapc_restraint_control%natoms) THEN + IF (jj > ddapc_restraint_control%natoms) & 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) THEN + IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) & 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) @@ -3383,8 +3285,7 @@ CONTAINS INTEGER :: i, j, n_elems INTEGER, DIMENSION(:), POINTER :: tmp - LOGICAL :: is_present, linearize_bse_propagation, & - local_moment_possible + LOGICAL :: is_present, local_moment_possible TYPE(section_vals_type), POINTER :: proj_mo_section, subsection ALLOCATE (dft_control%rtp_control) @@ -3400,20 +3301,6 @@ 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", & @@ -3452,20 +3339,18 @@ 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) THEN + IF (dft_control%rtp_control%linear_scaling) & 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. & - dft_control%rtp_control%rtp_method == rtp_method_bse_linearized) .OR. & + local_moment_possible = (dft_control%rtp_control%rtp_method == rtp_method_bse) .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") @@ -3544,9 +3429,8 @@ 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) THEN + dft_control%rtp_control%print_pol_elements(i, j) < 1) & CPABORT("Polarisation tensor element not 1,2 or 3 in at least one index") - END IF END DO END DO END IF @@ -3669,9 +3553,8 @@ CONTAINS END DO dft_control%probe(i)%natoms = jj - IF (dft_control%probe(i)%natoms < 1) THEN + IF (dft_control%probe(i)%natoms < 1) & CPABORT("Need at least 1 atom to use hair probes formalism") - END IF ALLOCATE (dft_control%probe(i)%atom_ids(dft_control%probe(i)%natoms)) jj = 0 diff --git a/src/cp_dbcsr_cholesky.F b/src/cp_dbcsr_cholesky.F index 8fdcc256cc..5ba00f221a 100644 --- a/src/cp_dbcsr_cholesky.F +++ b/src/cp_dbcsr_cholesky.F @@ -214,9 +214,8 @@ CONTAINS CALL copy_dbcsr_to_fm(matrixb, fm_matrixb) !CALL copy_dbcsr_to_fm(matrixout, fm_matrixout) - IF (op /= "SOLVE" .AND. op /= "MULTIPLY") THEN + IF (op /= "SOLVE" .AND. op /= "MULTIPLY") & CPABORT("wrong argument op") - END IF IF (PRESENT(pos)) THEN SELECT CASE (pos) diff --git a/src/cp_dbcsr_operations.F b/src/cp_dbcsr_operations.F index bb6ba62a78..46f66297ec 100644 --- a/src/cp_dbcsr_operations.F +++ b/src/cp_dbcsr_operations.F @@ -611,9 +611,8 @@ 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) THEN + IF (ncol /= k_out .OR. my_beta /= 0.0_dp) & 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, & @@ -649,9 +648,8 @@ CONTAINS n1 = SIZE(sizes1) n2 = SIZE(sizes2) - IF (n1 /= n2) THEN + IF (n1 /= n2) & 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 @@ -725,9 +723,8 @@ CONTAINS NULLIFY (col_dist_left) IF (ncol > 0) THEN - IF (.NOT. dbcsr_valid_index(sparse_matrix)) THEN + IF (.NOT. dbcsr_valid_index(sparse_matrix)) & CPABORT("sparse_matrix must pre-exist") - END IF ! ! Setup matrix_v CALL cp_fm_get_info(matrix_v, ncol_global=k) @@ -833,6 +830,25 @@ 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) @@ -1009,13 +1025,11 @@ CONTAINS estimated_blocks = max_blocks_per_bin*nbins ALLOCATE (blk_dist(estimated_blocks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_dist") - END IF ALLOCATE (blk_sizes(estimated_blocks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_sizes") - END IF element_stack = 0 nblks = 0 DO blk_layer = 1, max_blocks_per_bin @@ -1037,27 +1051,23 @@ CONTAINS block_size => blk_sizes ELSE ALLOCATE (block_distribution(nblks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_dist") - END IF block_distribution(:) = blk_dist(1:nblks) DEALLOCATE (blk_dist) ALLOCATE (block_size(nblks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & 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) THEN + IF (stat /= 0) & CPABORT("blk_dist") - END IF ALLOCATE (block_size(0), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_sizes") - END IF END IF 1579 FORMAT(I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5) IF (debug_mod) THEN diff --git a/src/cp_ddapc_forces.F b/src/cp_ddapc_forces.F index 7c30a8d718..979571da7f 100644 --- a/src/cp_ddapc_forces.F +++ b/src/cp_ddapc_forces.F @@ -217,7 +217,7 @@ CONTAINS END IF IF (iparticle1 /= iparticle2) THEN ra = rvec - r = NORM2(ra) + r = SQRT(DOT_PRODUCT(ra, ra)) t2 = -1.0_dp/(r*r)*factor drvec = ra/r*q1t*q2t d_el(1:3, iparticle1) = d_el(1:3, iparticle1) + t2*drvec diff --git a/src/cp_ddapc_methods.F b/src/cp_ddapc_methods.F index c8630ca686..5265a249ed 100644 --- a/src/cp_ddapc_methods.F +++ b/src/cp_ddapc_methods.F @@ -204,7 +204,7 @@ CONTAINS iparticle2, istart_g, s_dim REAL(KIND=dp) :: g2, gcut2, tmp REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: my_Am, my_Amw - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq(:, :, :) !NB precalculate as many things outside of the innermost loop as possible, in particular w(ig)*gfunc(ig,igauus1)*gfunc(ig,igauss2) @@ -766,7 +766,7 @@ CONTAINS ! IF (iparticle1 /= iparticle2) THEN ra = rvec - r = NORM2(ra) + r = SQRT(DOT_PRODUCT(ra, ra)) my_val = factor/r END IF EwM(idim) = my_val - factor*g_ewald diff --git a/src/cp_ddapc_util.F b/src/cp_ddapc_util.F index d9ff69876d..7fe0888cdc 100644 --- a/src/cp_ddapc_util.F +++ b/src/cp_ddapc_util.F @@ -355,8 +355,7 @@ CONTAINS bv(:) = 0.0_dp cv(:) = 1.0_dp/Vol CALL build_b_vector(bv, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut) - bv(:) = bv(:)/Vol + particle_set, radii, rho_tot_g, gcut); bv(:) = bv(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv) c1 = DOT_PRODUCT(cv, MATMUL(cp_ddapc_env%AmI, bv)) - ch_dens c1 = c1/cp_ddapc_env%c0 @@ -719,13 +718,11 @@ CONTAINS bv2(:) = 0.0_dp particle_set(iparticle)%r(i) = rvec(i) + dx CALL build_b_vector(bv1, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut) - bv1(:) = bv1(:)/Vol + particle_set, radii, rho_tot_g, gcut); bv1(:) = bv1(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv1) particle_set(iparticle)%r(i) = rvec(i) - dx CALL build_b_vector(bv2, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut) - bv2(:) = bv2(:)/Vol + particle_set, radii, rho_tot_g, gcut); bv2(:) = bv2(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv2) ddbv(:) = (bv1(:) - bv2(:))/(2.0_dp*dx) DO kk = 1, SIZE(ddbv) diff --git a/src/cp_eri_mme_interface.F b/src/cp_eri_mme_interface.F index d7e45fb6dc..b94212c6d3 100644 --- a/src/cp_eri_mme_interface.F +++ b/src/cp_eri_mme_interface.F @@ -563,9 +563,8 @@ CONTAINS WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Cutoff error:", param%par%err_c WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Total error (minimax + cutoff):", param%par%err_mm + param%par%err_c END IF - IF (param%par%print_calib) THEN + IF (param%par%print_calib) & WRITE (unit_nr, '(T2, A, T68, F13.10)') "ERI_MME| Minimax scaling constant in AM-GM estimate:", param%par%C_mm - END IF END IF END IF @@ -787,9 +786,8 @@ CONTAINS CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL", i_val=potential) CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL_PARAM", r_val=pot_par) - IF (nzet <= 0) THEN + IF (nzet <= 0) & CPABORT("Number of exponents NZET must be greater than 0.") - END IF CALL init_orbital_pointers(l_max) diff --git a/src/cp_external_control.F b/src/cp_external_control.F index 3ae0189fef..4b32395cde 100644 --- a/src/cp_external_control.F +++ b/src/cp_external_control.F @@ -63,9 +63,8 @@ CONTAINS external_comm = comm external_master_id = in_external_master_id - IF (PRESENT(in_scf_energy_message_tag)) THEN + IF (PRESENT(in_scf_energy_message_tag)) & scf_energy_message_tag = in_scf_energy_message_tag - END IF IF (PRESENT(in_exit_tag)) THEN ! the exit tag should be different from the mpi_probe tag default CPASSERT(in_exit_tag /= -1) @@ -204,7 +203,7 @@ CONTAINS IF (PRESENT(target_time)) THEN my_target_time = target_time my_start_time = start_time - ELSE IF (PRESENT(globenv)) THEN + ELSEIF (PRESENT(globenv)) THEN my_target_time = globenv%cp2k_target_time my_start_time = globenv%cp2k_start_time ELSE diff --git a/src/cp_subsys_methods.F b/src/cp_subsys_methods.F index 73ce1a9e0a..e85b894a4c 100644 --- a/src/cp_subsys_methods.F +++ b/src/cp_subsys_methods.F @@ -128,19 +128,16 @@ CONTAINS subsys%para_env => para_env my_use_motion_section = .FALSE. - IF (PRESENT(use_motion_section)) THEN + IF (PRESENT(use_motion_section)) & my_use_motion_section = use_motion_section - END IF my_force_env_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL") - IF (PRESENT(force_env_section)) THEN + IF (PRESENT(force_env_section)) & my_force_env_section => force_env_section - END IF my_subsys_section => section_vals_get_subs_vals(my_force_env_section, "SUBSYS") - IF (PRESENT(subsys_section)) THEN + IF (PRESENT(subsys_section)) & my_subsys_section => subsys_section - END IF CALL section_vals_val_get(my_subsys_section, "SEED", i_vals=seed_vals) IF (SIZE(seed_vals) == 1) THEN @@ -291,9 +288,8 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(small_subsys)) CPASSERT(ASSOCIATED(big_subsys)) - IF (big_subsys%para_env /= small_para_env) THEN + IF (big_subsys%para_env /= small_para_env) & CPABORT("big_subsys%para_env==small_para_env") - END IF !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- diff --git a/src/cryssym.F b/src/cryssym.F index 5f8c7e52e5..4c28f5b550 100644 --- a/src/cryssym.F +++ b/src/cryssym.F @@ -1755,7 +1755,7 @@ CONTAINS csym%kplink(1, j) = i wkp(i) = wkp(i) + 1.0_dp kpop(j) = kr - ELSE IF (csym%kplink(1, j) /= i) THEN + ELSEIF (csym%kplink(1, j) /= i) THEN ! Approximate K290 operation sets need not be closed for structures whose ! coordinates lie close to several symmetry tolerances. Keep the existing ! disjoint orbit instead of aborting or double-counting this mesh point. diff --git a/src/csvr_system_types.F b/src/csvr_system_types.F index 4095fc67c4..e4e349bce2 100644 --- a/src/csvr_system_types.F +++ b/src/csvr_system_types.F @@ -148,9 +148,8 @@ CONTAINS SUBROUTINE csvr_thermo_dealloc(nvt) TYPE(csvr_thermo_type), DIMENSION(:), POINTER :: nvt - IF (ASSOCIATED(nvt)) THEN + IF (ASSOCIATED(nvt)) & DEALLOCATE (nvt) - END IF END SUBROUTINE csvr_thermo_dealloc END MODULE csvr_system_types diff --git a/src/ct_methods.F b/src/ct_methods.F index 22bc2f77a4..2aa855445a 100644 --- a/src/ct_methods.F +++ b/src/ct_methods.F @@ -39,7 +39,6 @@ MODULE ct_methods USE iterate_matrix, ONLY: matrix_sqrt_Newton_Schulz USE kinds, ONLY: dp USE machine, ONLY: m_walltime - USE mathconstants, ONLY: pi #include "./base/base_uses.f90" IMPLICIT NONE @@ -1379,12 +1378,14 @@ CONTAINS INTEGER, INTENT(OUT) :: nmins INTEGER :: i, nroots - REAL(KIND=dp) :: DD, der, p, phi, q, temp1, temp2, u, v, & - y1, y2, y2i, y2r, y3 + REAL(KIND=dp) :: DD, der, p, phi, pi, q, temp1, temp2, u, & + v, y1, y2, y2i, y2r, y3 REAL(KIND=dp), DIMENSION(3) :: x ! CALL timeset(routineN,handle) + pi = ACOS(-1.0_dp) + ! Step 0: Check coefficients and find the true order of the eq IF (a == 0.0_dp) THEN IF (b == 0.0_dp) THEN @@ -1519,9 +1520,8 @@ CONTAINS ! create a matrix for eigenvectors CALL dbcsr_work_create(c, work_mutable=.TRUE.) - IF (do_eigenvalues) THEN + IF (do_eigenvalues) & CALL dbcsr_work_create(e, work_mutable=.TRUE.) - END IF CALL dbcsr_iterator_readonly_start(iter, matrix) diff --git a/src/ct_types.F b/src/ct_types.F index 120685b60b..2d93d0acc8 100644 --- a/src/ct_types.F +++ b/src/ct_types.F @@ -66,6 +66,31 @@ MODULE ct_types REAL(KIND=dp) :: energy_correction = 0.0_dp +!SPIN!!! ! metric matrices for covariant to contravariant transformations +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_up=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_down=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_up=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_down=>NULL() +!SPIN!!! +!SPIN!!! ! kohn-sham, covariant-covariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_ks=>NULL() +!SPIN!!! ! density, contravariant-contravariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_p=>NULL() +!SPIN!!! ! occ orbitals, contravariant-covariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_t=>NULL() +!SPIN!!! ! virt orbitals, contravariant-covariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_v=>NULL() +!SPIN!!! +!SPIN!!! ! to avoid building Occ-by-N and Virt-vy-N matrices inside +!SPIN!!! ! the ct routines get them from the external code +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_qp_template=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_pq_template=>NULL() +!SPIN!!! +!SPIN!!! ! single excitation amplitudes +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_x +!SPIN!!! ! residuals +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_res + ! metric matrices for covariant to contravariant transformations TYPE(dbcsr_type), POINTER :: p_index_up => NULL() TYPE(dbcsr_type), POINTER :: p_index_down => NULL() @@ -129,6 +154,7 @@ CONTAINS env%order_lanczos = 3 env%eps_lancsoz = 1.0E-4_dp env%max_iter_lanczos = 40 + !env%nspins = -1 env%converged = .FALSE. env%conjugator = cg_polak_ribiere @@ -205,6 +231,22 @@ CONTAINS qq_preconditioner_full, & pp_preconditioner_full +!INTEGER , OPTIONAL :: nspins +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_up +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_down +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_up +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_down +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_ks +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_p +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_t +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_v +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_qp_template +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_pq_template +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_x +!SPIN!!! +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), OPTIONAL :: copy_matrix_x +!INTEGER :: ispin + IF (PRESENT(use_occ_orbs)) use_occ_orbs = env%use_occ_orbs IF (PRESENT(use_virt_orbs)) use_virt_orbs = env%use_virt_orbs IF (PRESENT(occ_orbs_orthogonal)) occ_orbs_orthogonal = & @@ -225,6 +267,7 @@ CONTAINS IF (PRESENT(eps_convergence)) eps_convergence = env%eps_convergence IF (PRESENT(eps_filter)) eps_filter = env%eps_filter IF (PRESENT(max_iter)) max_iter = env%max_iter + !IF (PRESENT(nspins)) nspins = env%nspins IF (PRESENT(matrix_ks)) matrix_ks => env%matrix_ks IF (PRESENT(matrix_p)) matrix_p => env%matrix_p IF (PRESENT(matrix_t)) matrix_t => env%matrix_t @@ -238,8 +281,12 @@ CONTAINS IF (PRESENT(p_index_down)) p_index_down => env%p_index_down IF (PRESENT(q_index_down)) q_index_down => env%q_index_down IF (PRESENT(copy_matrix_x)) THEN + !DO ispin=1,env%nspins + !CALL dbcsr_copy(copy_matrix_x(ispin),env%matrix_x(ispin)) CALL dbcsr_copy(copy_matrix_x, env%matrix_x) + !ENDDO END IF + !IF (PRESENT(matrix_x)) matrix_x => env%matrix_x IF (PRESENT(energy_correction)) energy_correction = env%energy_correction IF (PRESENT(converged)) converged = env%converged @@ -305,6 +352,20 @@ CONTAINS LOGICAL, OPTIONAL :: qq_preconditioner_full, & pp_preconditioner_full +!INTEGER , OPTIONAL :: nspins +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_up +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_down +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_up +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_down +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_ks +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_p +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_t +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_v +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_qp_template +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_pq_template +! set para_env and blacs_env which are needed to operate with full matrices +! it would be nice to have everything with cp_dbcsr matrices, well maybe later + env%para_env => para_env env%blacs_env => blacs_env @@ -328,6 +389,7 @@ CONTAINS IF (PRESENT(eps_convergence)) env%eps_convergence = eps_convergence IF (PRESENT(eps_filter)) env%eps_filter = eps_filter IF (PRESENT(max_iter)) env%max_iter = max_iter + !IF (PRESENT(nspins)) env%nspins = nspins IF (PRESENT(conjugator)) env%conjugator = conjugator IF (PRESENT(matrix_ks)) env%matrix_ks => matrix_ks IF (PRESENT(matrix_p)) env%matrix_p => matrix_p @@ -353,12 +415,18 @@ CONTAINS TYPE(ct_step_env_type) :: env +!INTEGER :: ispin + NULLIFY (env%para_env) NULLIFY (env%blacs_env) !DO ispin=1,env%nspins CALL dbcsr_release(env%matrix_x) CALL dbcsr_release(env%matrix_res) + !CALL dbcsr_release(env%matrix_x(ispin)) + !CALL dbcsr_release(env%matrix_res(ispin)) + !ENDDO + !DEALLOCATE(env%matrix_x,env%matrix_res) NULLIFY (env%p_index_up) NULLIFY (env%p_index_down) diff --git a/src/dbm/dbm_api.F b/src/dbm/dbm_api.F index af1f6bc705..7cb521797f 100644 --- a/src/dbm/dbm_api.F +++ b/src/dbm/dbm_api.F @@ -182,9 +182,8 @@ CONTAINS num_blocks_diff = ABS(num_blocks - num_blocks_dbcsr) IF (num_blocks_diff /= 0) THEN WRITE (*, *) "num_blocks mismatch dbcsr:", num_blocks_dbcsr, "new:", num_blocks - IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN + IF (DBM_VALIDATE_NBLOCKS_MATCH) & CPABORT("num_blocks mismatch") - END IF END IF IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN diff --git a/src/dbm/dbm_tests.F b/src/dbm/dbm_tests.F index ee10d2ee4d..ed7e5efcd3 100644 --- a/src/dbm/dbm_tests.F +++ b/src/dbm/dbm_tests.F @@ -439,7 +439,7 @@ CONTAINS INTEGER(KIND=int_8) :: map map = ((irow - 1 + icol*INT(nrow, int_8))*(1 + MODULO(ival, 2**16)))*2 + 1 + 0*ncol ! ncol used - iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12 ! keep odd + iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12; ! keep odd iseed(3) = INT(MODULO(IEOR(map, 3541_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(2) = INT(MODULO(IEOR(map, 1153_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(1) = INT(MODULO(IEOR(map, 2029_int_8), 2_int_8**12)); map = map/2_int_8**12 diff --git a/src/dbt/dbt_allocate_wrap.F b/src/dbt/dbt_allocate_wrap.F index 19e02c8664..a4e10a477b 100644 --- a/src/dbt/dbt_allocate_wrap.F +++ b/src/dbt/dbt_allocate_wrap.F @@ -56,7 +56,7 @@ CONTAINS ELSE shape_prv = shape_spec END IF - ELSE IF (PRESENT(source)) THEN + ELSEIF (PRESENT(source)) THEN IF (PRESENT(order)) THEN shape_prv(order) = SHAPE(source) ELSE diff --git a/src/dbt/dbt_array_list_methods.F b/src/dbt/dbt_array_list_methods.F index 8b24135672..e607940865 100644 --- a/src/dbt/dbt_array_list_methods.F +++ b/src/dbt/dbt_array_list_methods.F @@ -51,7 +51,7 @@ MODULE dbt_array_list_methods TYPE array_list INTEGER, DIMENSION(:), ALLOCATABLE :: col_data INTEGER, DIMENSION(:), ALLOCATABLE :: ptr - END TYPE array_list + END TYPE INTERFACE get_ith_array MODULE PROCEDURE allocate_and_get_ith_array @@ -128,7 +128,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE create_array_list + END SUBROUTINE ! ************************************************************************************************** !> \brief extract a subset of arrays @@ -151,7 +151,7 @@ CONTAINS CALL create_array_list(array_sublist, ndata, ${varlist("data", nmax=dim)}$) END IF #:endfor - END FUNCTION array_sublist + END FUNCTION ! ************************************************************************************************** !> \brief destroy array list. @@ -161,7 +161,7 @@ CONTAINS TYPE(array_list), INTENT(INOUT) :: list DEALLOCATE (list%ptr, list%col_data) - END SUBROUTINE destroy_array_list + END SUBROUTINE ! ************************************************************************************************** !> \brief Get all arrays contained in list @@ -185,7 +185,7 @@ CONTAINS o(1:ndata) = i_selected(:) ELSE ndata = number_of_arrays(list) - o(1:ndata) = [(i, i=1, ndata)] + o(1:ndata) = (/(i, i=1, ndata)/) END IF ASSOCIATE (ptr => list%ptr, col_data => list%col_data) @@ -215,7 +215,7 @@ CONTAINS END ASSOCIATE - END SUBROUTINE get_ith_array + END SUBROUTINE ! ************************************************************************************************** !> \brief get ith array @@ -231,7 +231,7 @@ CONTAINS ALLOCATE (array, source=col_data(ptr(i):ptr(i + 1) - 1)) END ASSOCIATE - END SUBROUTINE allocate_and_get_ith_array + END SUBROUTINE ! ************************************************************************************************** !> \brief sizes of arrays stored in list @@ -288,7 +288,7 @@ CONTAINS partial_sum = partial_sum + list_in%col_data(i_ptr) END DO END DO - END SUBROUTINE array_offsets + END SUBROUTINE ! ************************************************************************************************** !> \brief reorder array list. @@ -309,7 +309,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE reorder_arrays + END SUBROUTINE ! ************************************************************************************************** !> \brief check whether two array lists are equal @@ -320,7 +320,7 @@ CONTAINS LOGICAL :: check_equal check_equal = array_eq_i(list1%col_data, list2%col_data) .AND. array_eq_i(list1%ptr, list2%ptr) - END FUNCTION check_equal + END FUNCTION ! ************************************************************************************************** !> \brief check whether two arrays are equal @@ -337,6 +337,6 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION array_eq_i + END FUNCTION END MODULE dbt_array_list_methods diff --git a/src/dbt/dbt_methods.F b/src/dbt/dbt_methods.F index 13cc921049..1acfd36763 100644 --- a/src/dbt/dbt_methods.F +++ b/src/dbt/dbt_methods.F @@ -231,7 +231,7 @@ CONTAINS IF (.NOT. PRESENT(order)) THEN IF (array_eq_i(map1_in_1, map2_in_1) .AND. array_eq_i(map1_in_2, map2_in_2)) THEN dist_compatible_tas = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) - ELSE IF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN + ELSEIF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN dist_compatible_tensor = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) END IF END IF @@ -239,7 +239,7 @@ CONTAINS IF (dist_compatible_tas) THEN CALL dbt_tas_copy(out_tmp_1%matrix_rep, in_tmp_3%matrix_rep, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) - ELSE IF (dist_compatible_tensor) THEN + ELSEIF (dist_compatible_tensor) THEN CALL dbt_copy_nocomm(in_tmp_3, out_tmp_1, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) ELSE @@ -1274,7 +1274,7 @@ CONTAINS ALLOCATE (tensor2_out) CALL dbt_remap(tensor2, ind2_linked, ind2_free, tensor2_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata2, move_data=move_data_2) - ELSE IF (compat1 == 2) THEN ! linked index is second 2d dimension + ELSEIF (compat1 == 2) THEN ! linked index is second 2d dimension ! get distribution of linked index, tensor 2 must adopt this distribution ! get grid dimensions of linked index ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) @@ -1315,7 +1315,7 @@ CONTAINS ALLOCATE (tensor1_out) CALL dbt_remap(tensor1, ind1_linked, ind1_free, tensor1_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata1, move_data=move_data_1) - ELSE IF (compat2 == 2) THEN + ELSEIF (compat2 == 2) THEN ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) CALL dbt_get_mapping_info(dist_in%pgrid%nd_index_grid, dims2_2d=mp_dims) ALLOCATE (tensor1_out) @@ -1419,7 +1419,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_in%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN + ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1442,7 +1442,7 @@ CONTAINS IF (compat1 == 1 .AND. compat2 == 2) THEN trans = .FALSE. - ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN + ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN trans = .TRUE. ELSE CPABORT("this should not happen") @@ -1453,7 +1453,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_out%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN + ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1526,7 +1526,7 @@ CONTAINS compat_map = 0 IF (array_eq_i(map1, compat_ind)) THEN compat_map = 1 - ELSE IF (array_eq_i(map2, compat_ind)) THEN + ELSEIF (array_eq_i(map2, compat_ind)) THEN compat_map = 2 END IF diff --git a/src/dbt/dbt_split.F b/src/dbt/dbt_split.F index e3ac768476..20cd9d4d81 100644 --- a/src/dbt/dbt_split.F +++ b/src/dbt/dbt_split.F @@ -272,7 +272,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE dbt_split_blocks_generic + END SUBROUTINE ! ************************************************************************************************** !> \brief Split tensor blocks into smaller blocks of maximum size PRODUCT(block_sizes). @@ -331,7 +331,7 @@ CONTAINS nodata=nodata) #:endfor - END SUBROUTINE dbt_split_blocks + END SUBROUTINE ! ************************************************************************************************** !> \brief Copy tensor with split blocks to tensor with original block sizes. @@ -480,7 +480,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE dbt_split_copyback + END SUBROUTINE ! ************************************************************************************************** !> \brief split two tensors with same total sizes but different block sizes such that they have @@ -503,8 +503,7 @@ CONTAINS INTEGER, DIMENSION(ndims_tensor(tensor1)), & INTENT(IN), OPTIONAL :: order LOGICAL, INTENT(IN), OPTIONAL :: nodata1, nodata2, move_data - INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, & - ${varlist("blk_size_split_2")}$, & + INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, ${varlist("blk_size_split_2")}$, & blk_size_d_1, blk_size_d_2, blk_size_d_split INTEGER :: size_sum_1, size_sum_2, size_sum, bind_1, bind_2, isplit, bs, idim, i LOGICAL :: move_prv, nodata1_prv, nodata2_prv @@ -552,7 +551,7 @@ CONTAINS size_sum = size_sum + bs isplit = isplit + 1 blk_size_d_split(isplit) = bs - ELSE IF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN + ELSEIF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN bind_2 = bind_2 + 1 bs = blk_size_d_2(bind_2) blk_size_d_1(bind_1 + 1) = blk_size_d_1(bind_1 + 1) - bs @@ -609,7 +608,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE dbt_make_compatible_blocks + END SUBROUTINE ! ************************************************************************************************** !> \author Patrick Seewald @@ -699,6 +698,6 @@ CONTAINS CALL dbt_copy_contraction_storage(tensor_in, tensor_out) CALL timestop(handle) - END SUBROUTINE dbt_crop + END SUBROUTINE - END MODULE dbt_split + END MODULE diff --git a/src/dbt/dbt_types.F b/src/dbt/dbt_types.F index 1a7d1b14ba..a7aa6929ad 100644 --- a/src/dbt/dbt_types.F +++ b/src/dbt/dbt_types.F @@ -211,7 +211,7 @@ CONTAINS CALL dbt_get_mapping_info(map_grid, & dims_2d=grid_dims, & dims1_2d=new_dbt_tas_dist_t%dims_grid) - ELSE IF (which_dim == 2) THEN + ELSEIF (which_dim == 2) THEN ALLOCATE (new_dbt_tas_dist_t%dims(ndims_mapping_column(map_blks))) ALLOCATE (index_map(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -335,7 +335,7 @@ CONTAINS dims_2d_i8=matrix_dims, & map1_2d=index_map, & dims1_2d=new_dbt_tas_blk_size_t%dims) - ELSE IF (which_dim == 2) THEN + ELSEIF (which_dim == 2) THEN ALLOCATE (index_map(ndims_mapping_column(map_blks))) ALLOCATE (new_dbt_tas_blk_size_t%dims(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -455,7 +455,7 @@ CONTAINS IF (idim /= SIZE(tensor_dims_sorted)) THEN dims(idim + 1:) = 0 CALL mp_dims_create(pdims_rem, dims(idim + 1:)) - ELSE IF (lb_ratio_prv < 0.5_dp) THEN + ELSEIF (lb_ratio_prv < 0.5_dp) THEN ! resort to a less strict load imbalance factor dims(:) = dims_store CALL dbt_mp_dims_create(nodes, dims, tensor_dims, 0.5_dp) @@ -836,7 +836,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(dist%refcount)) THEN abort = .TRUE. - ELSE IF (dist%refcount < 1) THEN + ELSEIF (dist%refcount < 1) THEN abort = .TRUE. END IF @@ -1264,7 +1264,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(tensor%refcount)) THEN abort = .TRUE. - ELSE IF (tensor%refcount < 1) THEN + ELSEIF (tensor%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_mm.F b/src/dbt/tas/dbt_tas_mm.F index 1050765b34..12d8654603 100644 --- a/src/dbt/tas/dbt_tas_mm.F +++ b/src/dbt/tas/dbt_tas_mm.F @@ -276,7 +276,7 @@ CONTAINS WRITE (unit_nr_prv, "(T4,A,T68,I13)") "Est. optimal split factor:", nsplit END IF - ELSE IF (batched_repl > 0) THEN + ELSEIF (batched_repl > 0) THEN nsplit = nsplit_batched nsplit_opt = nsplit max_mm_dim = max_mm_dim_batched @@ -342,7 +342,7 @@ CONTAINS IF (matrix_c%do_batched == 1) THEN matrix_c%mm_storage%batched_beta = beta - ELSE IF (matrix_c%do_batched > 1) THEN + ELSEIF (matrix_c%do_batched > 1) THEN matrix_c%mm_storage%batched_beta = matrix_c%mm_storage%batched_beta*beta END IF @@ -355,7 +355,7 @@ CONTAINS IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rs%matrix) IF (matrix_c%do_batched >= 1) matrix_c%mm_storage%store_batched => matrix_c_rs - ELSE IF (matrix_c%do_batched == 3) THEN + ELSEIF (matrix_c%do_batched == 3) THEN matrix_c_rs => matrix_c%mm_storage%store_batched END IF @@ -446,7 +446,7 @@ CONTAINS matrix_b%mm_storage%store_batched_repl => matrix_b_rep CALL dbt_tas_set_batched_state(matrix_b, state=3) END IF - ELSE IF (matrix_b%do_batched == 3) THEN + ELSEIF (matrix_b%do_batched == 3) THEN matrix_b_rep => matrix_b%mm_storage%store_batched_repl END IF @@ -532,14 +532,14 @@ CONTAINS matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) END IF - ELSE IF (matrix_c%do_batched == 2) THEN + ELSEIF (matrix_c%do_batched == 2) THEN ALLOCATE (matrix_c_rep) CALL dbt_tas_replicate(matrix_c_rs%matrix, dbt_tas_info(matrix_a_rs), matrix_c_rep, nodata=nodata_3) ! just leave sparsity structure for retain sparsity but no values IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rep%matrix) matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) - ELSE IF (matrix_c%do_batched == 3) THEN + ELSEIF (matrix_c%do_batched == 3) THEN matrix_c_rep => matrix_c%mm_storage%store_batched_repl END IF @@ -625,7 +625,7 @@ CONTAINS matrix_a%mm_storage%store_batched_repl => matrix_a_rep CALL dbt_tas_set_batched_state(matrix_a, state=3) END IF - ELSE IF (matrix_a%do_batched == 3) THEN + ELSEIF (matrix_a%do_batched == 3) THEN matrix_a_rep => matrix_a%mm_storage%store_batched_repl END IF @@ -740,7 +740,7 @@ CONTAINS CALL dbt_tas_destroy(matrix_c_rs) DEALLOCATE (matrix_c_rs) IF (PRESENT(filter_eps)) CALL dbt_tas_filter(matrix_c, filter_eps) - ELSE IF (matrix_c%do_batched > 0) THEN + ELSEIF (matrix_c%do_batched > 0) THEN IF (matrix_c%mm_storage%batched_out) THEN matrix_c%mm_storage%batched_trans = (transc_prv .NEQV. transc) END IF diff --git a/src/dbt/tas/dbt_tas_split.F b/src/dbt/tas/dbt_tas_split.F index c9e7d8fb28..aa7522631e 100644 --- a/src/dbt/tas/dbt_tas_split.F +++ b/src/dbt/tas/dbt_tas_split.F @@ -266,7 +266,7 @@ CONTAINS nsplit_list_square(count_square) = split count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split - ELSE IF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN + ELSEIF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split END IF @@ -277,10 +277,10 @@ CONTAINS IF (count_square > 0) THEN minpos = MINLOC(ABS(nsplit_list_square(1:count_square) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_square(minpos) - ELSE IF (count_accept > 0) THEN + ELSEIF (count_accept > 0) THEN minpos = MINLOC(ABS(nsplit_list_accept(1:count_accept) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_accept(minpos) - ELSE IF (count > 0) THEN + ELSEIF (count > 0) THEN minpos = MINLOC(ABS(nsplit_list(1:count) - nsplit), DIM=1) get_opt_nsplit = nsplit_list(minpos) ELSE @@ -462,7 +462,7 @@ CONTAINS IF (.NOT. ASSOCIATED(split_info%refcount)) THEN abort = .TRUE. - ELSE IF (split_info%refcount < 1) THEN + ELSEIF (split_info%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_util.F b/src/dbt/tas/dbt_tas_util.F index 60f323a9d1..0f8d27acd9 100644 --- a/src/dbt/tas/dbt_tas_util.F +++ b/src/dbt/tas/dbt_tas_util.F @@ -53,7 +53,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE swap_i8 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -68,7 +68,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE swap_i + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -87,7 +87,7 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION array_eq_i + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -106,6 +106,6 @@ CONTAINS array_eq_i8 = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i8 = ALL(arr1 == arr2) #endif - END FUNCTION array_eq_i8 + END FUNCTION END MODULE diff --git a/src/dbx/cp_dbcsr_api.F b/src/dbx/cp_dbcsr_api.F index bd02f16ab1..cdd57dca4e 100644 --- a/src/dbx/cp_dbcsr_api.F +++ b/src/dbx/cp_dbcsr_api.F @@ -235,11 +235,10 @@ CONTAINS TYPE(dbcsr_type), POINTER :: matrix CALL dbcsr_release(matrix) - IF (dbcsr_valid_index(matrix)) THEN + IF (dbcsr_valid_index(matrix)) & CALL cp_abort(__LOCATION__, & 'You should not "deallocate" a referenced matrix. '// & 'Avoid pointers to DBCSR matrices.') - END IF DEALLOCATE (matrix) END SUBROUTINE dbcsr_deallocate_matrix diff --git a/src/debug_os_integrals.F b/src/debug_os_integrals.F index 19c1160f8f..49887cda40 100644 --- a/src/debug_os_integrals.F +++ b/src/debug_os_integrals.F @@ -75,7 +75,7 @@ CONTAINS ALLOCATE (swork(lds, lds, 1)) sab = 0._dp rab(:) = B(:) - A(:) - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) xa_work(1) = xa xb_work(1) = xb rpgfa = 20._dp @@ -219,11 +219,11 @@ CONTAINS !--------------------------------------- rab(:) = B(:) - A(:) - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) rac(:) = C(:) - A(:) - dac = NORM2(rac) + dac = SQRT(DOT_PRODUCT(rac, rac)) rbc(:) = C(:) - B(:) - dbc = NORM2(rbc) + dbc = SQRT(DOT_PRODUCT(rbc, rbc)) ALLOCATE (sabc(ncoset(la_max), ncoset(lb_max), ncoset(lc_max))) xa_work(1) = xa xb_work(1) = xb @@ -422,7 +422,7 @@ CONTAINS ALLOCATE (swork(lds, lds)) saabb = 0._dp rab(:) = B(:) - A(:) - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) xa_work1(1) = xa1 xa_work2(1) = xa2 xb_work1(1) = xb1 diff --git a/src/dft_plus_u.F b/src/dft_plus_u.F index 0337c70cd1..de3bec26f0 100644 --- a/src/dft_plus_u.F +++ b/src/dft_plus_u.F @@ -189,7 +189,7 @@ CONTAINS !> \date 02.07.2008 !> \par !> \f{eqnarray*}{ -!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U} +!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U}\\\ !> & = & E^{\rm DFT} + \frac{1}{2}(U - J)\sum_\mu (q_\mu - q_\mu^2)\\[1ex] !> V_{\mu\nu}^{\rm DFT+U} & = & V_{\mu\nu}^{\rm DFT} + V_{\mu\nu}^{\rm U}\\\ !> & = & \frac{\partial E^{\rm DFT}} @@ -766,11 +766,10 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) THEN + IF (energy%dft_plus_u < 0.0_dp) & CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Lowdin charges!") - END IF ! Release (local) full matrices NULLIFY (fm_s_half) @@ -1992,11 +1991,10 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) THEN + IF (energy%dft_plus_u < 0.0_dp) & CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Mulliken charges!") - END IF ! Release local work storage diff --git a/src/distribution_2d_types.F b/src/distribution_2d_types.F index a02fb10510..8473cd37f5 100644 --- a/src/distribution_2d_types.F +++ b/src/distribution_2d_types.F @@ -132,9 +132,8 @@ CONTAINS END IF IF (PRESENT(n_col_distribution)) THEN IF (ASSOCIATED(distribution_2d%col_distribution)) THEN - IF (n_col_distribution > distribution_2d%n_col_distribution) THEN + IF (n_col_distribution > distribution_2d%n_col_distribution) & CPABORT("n_col_distribution<=distribution_2d%n_col_distribution") - END IF ! else alloc col_distribution? END IF distribution_2d%n_col_distribution = n_col_distribution @@ -146,17 +145,15 @@ CONTAINS END IF IF (PRESENT(n_row_distribution)) THEN IF (ASSOCIATED(distribution_2d%row_distribution)) THEN - IF (n_row_distribution > distribution_2d%n_row_distribution) THEN + IF (n_row_distribution > distribution_2d%n_row_distribution) & CPABORT("n_row_distribution<=distribution_2d%n_row_distribution") - END IF ! else alloc row_distribution? END IF distribution_2d%n_row_distribution = n_row_distribution END IF - IF (PRESENT(local_rows_ptr)) THEN + IF (PRESENT(local_rows_ptr)) & distribution_2d%local_rows => local_rows_ptr - END IF IF (.NOT. ASSOCIATED(distribution_2d%local_rows)) THEN CPASSERT(PRESENT(n_local_rows)) ALLOCATE (distribution_2d%local_rows(SIZE(n_local_rows))) @@ -167,13 +164,11 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_rows(SIZE(distribution_2d%local_rows))) IF (PRESENT(n_local_rows)) THEN - IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) THEN + IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) & CPABORT("SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows)") - END IF DO i = 1, SIZE(distribution_2d%n_local_rows) - IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) THEN + IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) & CPABORT("SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i)") - END IF distribution_2d%n_local_rows(i) = n_local_rows(i) END DO ELSE @@ -183,9 +178,8 @@ CONTAINS END DO END IF - IF (PRESENT(local_cols_ptr)) THEN + IF (PRESENT(local_cols_ptr)) & distribution_2d%local_cols => local_cols_ptr - END IF IF (.NOT. ASSOCIATED(distribution_2d%local_cols)) THEN CPASSERT(PRESENT(n_local_cols)) ALLOCATE (distribution_2d%local_cols(SIZE(n_local_cols))) @@ -196,13 +190,11 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_cols(SIZE(distribution_2d%local_cols))) IF (PRESENT(n_local_cols)) THEN - IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) THEN + IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) & CPABORT("SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols)") - END IF DO i = 1, SIZE(distribution_2d%n_local_cols) - IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) THEN + IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) & CPABORT("SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i)") - END IF distribution_2d%n_local_cols(i) = n_local_cols(i) END DO ELSE @@ -323,9 +315,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%row_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%row_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) THEN + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -345,9 +336,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%col_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%col_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) THEN + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -365,9 +355,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_rows) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_rows(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) THEN + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -406,9 +395,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_cols) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_cols(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) THEN + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE diff --git a/src/distribution_methods.F b/src/distribution_methods.F index 6442052837..c2a143497c 100644 --- a/src/distribution_methods.F +++ b/src/distribution_methods.F @@ -207,14 +207,12 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_count, bin, bin_price, found) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("No topmost heap element found.") - END IF ipe = bin - IF (bin_price /= workload_count(ipe)) THEN + IF (bin_price /= workload_count(ipe)) & CPABORT("inconsistent heap") - END IF workload_count(ipe) = workload_count(ipe) + nload IF (ipe == mype) THEN @@ -247,14 +245,12 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_fill, bin, bin_price, found) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("No topmost heap element found.") - END IF ipe = bin - IF (bin_price /= workload_fill(ipe)) THEN + IF (bin_price /= workload_fill(ipe)) & CPABORT("inconsistent heap") - END IF workload_fill(ipe) = workload_fill(ipe) + nload is_local = (ipe == mype) @@ -279,9 +275,8 @@ CONTAINS END DO - IF (ANY(workload_fill /= workload_count)) THEN + IF (ANY(workload_fill /= workload_count)) & CPABORT("Inconsistent heaps encountered") - END IF CALL cp_heap_release(bin_heap_count) CALL cp_heap_release(bin_heap_fill) @@ -568,9 +563,8 @@ CONTAINS CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model) IF (.NOT. molecular_distribution) THEN DO iatom = 1, natom - IF (iatom > nclusters) THEN + IF (iatom > nclusters) & CPABORT("Bounds error") - END IF CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) cluster_list(iatom) = iatom SELECT CASE (cost_model) @@ -625,9 +619,8 @@ CONTAINS nprow, cluster_row_distribution(:, 1), npcol, cluster_col_distribution(:, 1)) ELSE IF (basic_cluster_optimization) THEN - IF (molecular_distribution) THEN + IF (molecular_distribution) & CPABORT("clustering and molecular blocking NYI") - END IF ALLOCATE (pbc_scaled_coords(3, natom), coords(3, natom)) DO iatom = 1, natom CALL real_to_scaled(pbc_scaled_coords(:, iatom), pbc(particle_set(iatom)%r(:), cell), cell) @@ -871,18 +864,15 @@ CONTAINS DO cluster_index = nclusters, 1, -1 cluster = cluster_list(cluster_index) CALL cp_heap_get_first(bin_heap, bin, bin_price, found) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("No topmost heap element found.") - END IF ! prow = INT((bin - 1)*pgrid_gcd/npcols) - IF (prow >= nprows) THEN + IF (prow >= nprows) & CPABORT("Invalid process row.") - END IF pcol = INT((bin - 1)*pgrid_gcd/nprows) - IF (pcol >= npcols) THEN + IF (pcol >= npcols) & CPABORT("Invalid process column.") - END IF row_distribution(cluster) = prow + 1 col_distribution(cluster) = pcol + 1 ! @@ -1207,7 +1197,7 @@ CONTAINS balance_new = MAXVAL(REAL(nat_cluster, KIND=dp))/MINVAL(REAL(nat_cluster, KIND=dp)) IF (balance_new < balance) THEN balance = balance_new - min_seed = seed + i*40 + min_seed = seed + i*40; END IF ELSE found = .TRUE. @@ -1324,7 +1314,7 @@ CONTAINS devi = HUGE(1.0_dp) DO j = 1, i - 1 dvec = pbc(cent_coord(:, j), cent_coord(:, i), cell) - dist = NORM2(dvec) + dist = SQRT(DOT_PRODUCT(dvec, dvec)) IF (dist < devi) devi = dist END DO rn = rng_stream%next() diff --git a/src/dm_ls_chebyshev.F b/src/dm_ls_chebyshev.F index ea57800af1..0b707213c6 100644 --- a/src/dm_ls_chebyshev.F +++ b/src/dm_ls_chebyshev.F @@ -263,33 +263,27 @@ CONTAINS DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp1) - !matrix_dummy2= - CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) - !first term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) - !second term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) + CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) !matrix_dummy2= + CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) !first term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) !second term of chebyshev poly(matrix) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) END DO DO icheb = 2, ncheb - 1 t1 = m_walltime() - !matrix multiplication(Recursion) CALL dbcsr_multiply("N", "N", 2.0_dp, matrix_F, matrix_tmp2, & - -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) + -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) !matrix multiplication(Recursion) CALL dbcsr_copy(matrix_tmp3, matrix_tmp1) CALL dbcsr_copy(matrix_tmp1, matrix_tmp2) CALL dbcsr_copy(matrix_tmp2, matrix_tmp3) - !icheb+1 th coefficient - CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) + CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) !icheb+1 th coefficient CALL kernel(kernel_g(icheb + 1), icheb + 1, ncheb) DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp2) - !second term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) + CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) !second term of chebyshev poly(matrix) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) CALL dbcsr_trace(matrix_dummy2(iwindow), trace=trace_dm(iwindow)) !icheb+1 th coefficient diff --git a/src/dm_ls_scf.F b/src/dm_ls_scf.F index 97b662fb2b..e5d9d07e2c 100644 --- a/src/dm_ls_scf.F +++ b/src/dm_ls_scf.F @@ -588,7 +588,7 @@ CONTAINS DO ispin = 1, nspin IF (nonscf) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) - ELSE IF (ls_scf_env%do_rho_mixing) THEN + ELSEIF (ls_scf_env%do_rho_mixing) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (iscf == 1) THEN @@ -657,12 +657,10 @@ CONTAINS IF (ls_scf_env%nspins == 1) nelectron_spin_real = nelectron_spin_real/2 IF (do_transport) THEN - IF (ls_scf_env%has_s_preconditioner) THEN + IF (ls_scf_env%has_s_preconditioner) & CPABORT("NOT YET IMPLEMENTED with S preconditioner. ") - END IF - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & CPABORT("NOT YET IMPLEMENTED with molecular clustering. ") - END IF extra_scf = maxscf_reached .OR. scf_converged ! get the current Kohn-Sham matrix (ks) and return matrix_p evaluated using an external C routine @@ -693,13 +691,11 @@ CONTAINS eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos, & iounit=-1) CASE (ls_scf_pexsi) - IF (ls_scf_env%has_s_preconditioner) THEN + IF (ls_scf_env%has_s_preconditioner) & CPABORT("S preconditioning not implemented in combination with the PEXSI library. ") - END IF - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & CALL cp_abort(__LOCATION__, & "Molecular clustering not implemented in combination with the PEXSI library. ") - END IF CALL density_matrix_pexsi(ls_scf_env%pexsi, ls_scf_env%matrix_p(ispin), ls_scf_env%pexsi%matrix_w(ispin), & ls_scf_env%pexsi%kTS(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s, & nelectron_spin_real, ls_scf_env%mu_spin(ispin), iscf, ispin) @@ -838,9 +834,8 @@ CONTAINS END IF ! store the matrix for a next scf run - IF (.NOT. ls_scf_env%do_pao) THEN + IF (.NOT. ls_scf_env%do_pao) & CALL ls_scf_store_result(ls_scf_env) - END IF ! write homo and lumo energy and occupation (if not already part of the output) IF (ls_scf_env%curvy_steps) THEN @@ -913,9 +908,8 @@ CONTAINS END DO DEALLOCATE (ls_scf_env%matrix_ks) - IF (ls_scf_env%do_pexsi) THEN + IF (ls_scf_env%do_pexsi) & CALL pexsi_finalize_scf(ls_scf_env%pexsi, ls_scf_env%mu_spin) - END IF CALL timestop(handle) diff --git a/src/dm_ls_scf_create.F b/src/dm_ls_scf_create.F index 2ae4abd5c4..f094e7e7d6 100644 --- a/src/dm_ls_scf_create.F +++ b/src/dm_ls_scf_create.F @@ -155,9 +155,8 @@ CONTAINS ! initialize PEXSI IF (ls_scf_env%do_pexsi) THEN - IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) THEN + IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) & CPABORT("EPS_FILTER_MATRIX must be set to 0 for PEXSI.") - END IF CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env, ls_scf_env%nspins) END IF @@ -264,9 +263,8 @@ CONTAINS CALL section_vals_get(mixing_section, explicit=ls_scf_env%do_rho_mixing) CALL section_vals_val_get(mixing_section, "METHOD", i_val=ls_scf_env%density_mixing_method) - IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) THEN + IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) & CPABORT("LS_DIIS and RHO_MIXING are not compatible.") - END IF pexsi_section => section_vals_get_subs_vals(input, "DFT%LS_SCF%PEXSI") CALL section_vals_get(pexsi_section) @@ -315,18 +313,14 @@ CONTAINS END SELECT ! verify some requirements for the curvy steps - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) THEN + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) & CPABORT("CURVY_STEPS cannot be used together with PEXSI.") - END IF - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) THEN + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) & CPABORT("CURVY_STEPS cannot be used together with TRANSPORT.") - END IF - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) THEN + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) & CPABORT("S Preconditioning not implemented in combination with CURVY_STEPS.") - END IF - IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) THEN + IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) & CPABORT("CURVY_STEPS requires the use of the sqrt inversion.") - END IF ! verify requirements for direct submatrix sign methods IF (ls_scf_env%sign_method == ls_scf_sign_submatrix & @@ -334,9 +328,8 @@ CONTAINS ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & - ) .AND. .NOT. ls_scf_env%sign_symmetric) THEN + ) .AND. .NOT. ls_scf_env%sign_symmetric) & CPABORT("DIRECT submatrix sign methods require SIGN_SYMMETRIC being set.") - END IF IF (ls_scf_env%fixed_mu .AND. ( & ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & diff --git a/src/dm_ls_scf_curvy.F b/src/dm_ls_scf_curvy.F index e1c9375c9b..1548418d0d 100644 --- a/src/dm_ls_scf_curvy.F +++ b/src/dm_ls_scf_curvy.F @@ -95,10 +95,9 @@ CONTAINS ! If new search direction has to be computed transform H into the orthnormal basis - IF (ls_scf_env%curvy_data%line_search_step == 1) THEN + IF (ls_scf_env%curvy_data%line_search_step == 1) & CALL transform_matrix_orth(ls_scf_env%matrix_ks, ls_scf_env%matrix_s_sqrt_inv, & ls_scf_env%eps_filter) - END IF ! Set the energies for the line search and make sure to give the correct energy back to scf_main ls_scf_env%curvy_data%energies(lsstep) = energy diff --git a/src/dm_ls_scf_methods.F b/src/dm_ls_scf_methods.F index b51f08d513..e74da48ab7 100644 --- a/src/dm_ls_scf_methods.F +++ b/src/dm_ls_scf_methods.F @@ -516,9 +516,8 @@ CONTAINS IF (sign_symmetric) THEN - IF (.NOT. PRESENT(matrix_s_sqrt_inv)) THEN + IF (.NOT. PRESENT(matrix_s_sqrt_inv)) & CPABORT("Argument matrix_s_sqrt_inv required if sign_symmetric is set") - END IF CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv2, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) @@ -578,9 +577,8 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix - END IF IF (sign_symmetric) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & @@ -690,9 +688,8 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix - END IF CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & 0.0_dp, matrix_tmp, filter_eps=threshold) @@ -945,9 +942,8 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(trace_gx)) THEN + IF (abnormal_value(trace_gx)) & CPABORT("trace_gx is an abnormal value (NaN/Inf).") - END IF ! a branch of 1 or 2 appears to lead to a less accurate electron number count and premature exit ! if it turns out this does not exit because we get stuck in branch 1/2 for a reason we need to refine further @@ -973,15 +969,13 @@ CONTAINS CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_x_nosym, & 0.0_dp, matrix_p, filter_eps=threshold) - ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, - ! where fk is evaluated using the stored values for gamma + ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, where fk is evaluated using the stored values for gamma ! E. Rubensson et al., Chem Phys Lett 432, 2006, 591-594 - mu_a = 0.0_dp; mu_b = 1.0_dp + mu_a = 0.0_dp; mu_b = 1.0_dp; mu_fa = evaluate_trs4_polynomial(mu_a, gamma_values, i - 1) - 0.5_dp DO j = 1, 40 mu_c = 0.5*(mu_a + mu_b) - ! i-1 because in the last iteration, only convergence is checked - mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp + mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp ! i-1 because in the last iteration, only convergence is checked IF (ABS(mu_fc) < 1.0E-6_dp .OR. (mu_b - mu_a)/2 < 1.0E-6_dp) EXIT !TODO: define threshold values IF (mu_fc*mu_fa > 0) THEN diff --git a/src/dm_ls_scf_qs.F b/src/dm_ls_scf_qs.F index 5ae581f005..7fc0b72aca 100644 --- a/src/dm_ls_scf_qs.F +++ b/src/dm_ls_scf_qs.F @@ -322,9 +322,8 @@ CONTAINS CALL timeset(routineN, handle) my_keep_sparsity = .TRUE. - IF (PRESENT(keep_sparsity)) THEN + IF (PRESENT(keep_sparsity)) & my_keep_sparsity = keep_sparsity - END IF IF (.NOT. ls_mstruct%do_pao) THEN CALL dbcsr_create(matrix_declustered, template=matrix_qs) @@ -584,9 +583,8 @@ CONTAINS ! compute the corresponding KS matrix and new energy, mix density if requested CALL qs_rho_update_rho(rho, qs_env=qs_env) IF (ls_scf_env%do_rho_mixing) THEN - IF (ls_scf_env%density_mixing_method == direct_mixing_nr) THEN + IF (ls_scf_env%density_mixing_method == direct_mixing_nr) & CPABORT("Direct P mixing not implemented in linear scaling SCF. ") - END IF IF (ls_scf_env%density_mixing_method >= gspace_mixing_nr) THEN IF (iscf > MAX(ls_scf_env%mixing_store%nskip_mixing, 1)) THEN CALL gspace_mixing(qs_env, ls_scf_env%density_mixing_method, & @@ -841,9 +839,9 @@ CONTAINS CALL get_qs_env(qs_env, rho_atom_set=rho_atom) CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & ls_scf_env%para_env, rho_atom=rho_atom) - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(ls_scf_env%mixing_store) - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & diff --git a/src/dm_ls_scf_types.F b/src/dm_ls_scf_types.F index 1d26e1d570..07123e6801 100644 --- a/src/dm_ls_scf_types.F +++ b/src/dm_ls_scf_types.F @@ -208,12 +208,10 @@ CONTAINS DEALLOCATE (ls_scf_env%matrix_p) END IF - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) THEN + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) & CALL section_vals_release(ls_scf_env%chebyshev%print_key_dos) - END IF - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) THEN + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) & CALL section_vals_release(ls_scf_env%chebyshev%print_key_cube) - END IF IF (ASSOCIATED(ls_scf_env%chebyshev%min_energy)) THEN DEALLOCATE (ls_scf_env%chebyshev%min_energy) END IF @@ -230,9 +228,8 @@ CONTAINS CALL lib_pexsi_finalize(ls_scf_env%pexsi) END IF - IF (ls_scf_env%do_pao) THEN + IF (ls_scf_env%do_pao) & CALL pao_finalize(ls_scf_env%pao_env) - END IF DEALLOCATE (ls_scf_env) diff --git a/src/domain_submatrix_methods.F b/src/domain_submatrix_methods.F index ac020751c0..b70d9fc507 100644 --- a/src/domain_submatrix_methods.F +++ b/src/domain_submatrix_methods.F @@ -937,6 +937,33 @@ CONTAINS END DO + ! simple but quadratically scaling procedure + ! loop over local blocks + !CALL dbcsr_iterator_start(iter,matrix) + !DO WHILE (dbcsr_iterator_blocks_left(iter)) + ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& + ! row_size=row_size,col_size=col_size) + ! DO idomain = 1, ndomains + ! IF (job_type==select_row_col) THEN + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ELSE + ! domain_needs_block=(idomain==col& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ENDIF + ! IF (domain_needs_block) THEN + ! transp=.FALSE. + ! dest_node=node_of_domain(idomain) + ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& + ! ! idomain, idomain, transp, dest_node) + ! send_descriptor(1,dest_node+1)=send_descriptor(1,dest_node+1)+1 + ! send_descriptor(2,dest_node+1)=send_descriptor(2,dest_node+1)+& + ! row_size*col_size + ! ENDIF + ! ENDDO + !ENDDO + !CALL dbcsr_iterator_stop(iter) + ! communicate number of blocks and their sizes to the other nodes CALL group%alltoall(send_descriptor, recv_descriptor, ldesc) @@ -1031,6 +1058,15 @@ CONTAINS IF (block_node == myNode) THEN CALL dbcsr_get_block_p(matrix, row, col, block_p, found, row_size, col_size) IF (found) THEN + !col_offset=0 + !DO icol=1,col_size + ! start_data=send_offset_cpu(dest_node+1)+& + ! offset_block(dest_node+1)+& + ! col_offset + ! send_data(start_data+1:start_data+row_size)=& + ! data_p(1:row_size,icol) + ! col_offset=col_offset+row_size + !ENDDO col_offset = row_size*col_size start_data = send_offset_cpu(dest_node + 1) + & offset_block(dest_node + 1) @@ -1050,6 +1086,45 @@ CONTAINS END DO ! loop over rows END DO + ! more simple but quadratically scaling version + !CALL dbcsr_iterator_start(iter,matrix) + !DO WHILE (dbcsr_iterator_blocks_left(iter)) + ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& + ! row_size=row_size,col_size=col_size) + ! DO idomain = 1, ndomains + ! IF (job_type==select_row_col) THEN + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ELSE + ! domain_needs_block=(idomain==col& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ENDIF + ! IF (domain_needs_block) THEN + ! transp=.FALSE. + ! dest_node=node_of_domain(idomain) + ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& + ! ! idomain, idomain, transp, dest_node) + ! ! place the data appropriately + ! col_offset=0 + ! DO icol=1,col_size + ! start_data=send_offset_cpu(dest_node+1)+& + ! offset_block(dest_node+1)+& + ! col_offset + ! send_data(start_data+1:start_data+row_size)=& + ! data_p(1:row_size,icol) + ! col_offset=col_offset+row_size + ! ENDDO + ! offset_block(dest_node+1)=offset_block(dest_node+1)+col_size*row_size + ! ! fill out row,col information + ! send_data2(send_offset2_cpu(dest_node+1)+& + ! offset2_block(dest_node+1)+1)=row + ! send_data2(send_offset2_cpu(dest_node+1)+& + ! offset2_block(dest_node+1)+2)=col + ! offset2_block(dest_node+1)=offset2_block(dest_node+1)+2 + ! ENDIF + ! ENDDO + !ENDDO + !CALL dbcsr_iterator_stop(iter) ! send-receive all blocks CALL group%alltoall(send_data, send_size_cpu, send_offset_cpu, & @@ -1067,6 +1142,9 @@ CONTAINS ! copy blocks into submatrices CALL dbcsr_get_info(matrix, col_blk_size=col_blk_size, row_blk_size=row_blk_size) +! ALLOCATE(subm_row_size(ndomains),subm_col_size(ndomains)) +! subm_row_size(:)=0 +! subm_col_size(:)=0 ndomains2 = SIZE(submatrix) IF (ndomains2 /= ndomains) THEN CPABORT("wrong submatrix size") @@ -1081,6 +1159,9 @@ CONTAINS submatrix(:)%domain = -1 DO idomain = 1, ndomains dest_node = node_of_domain(idomain) + !transp=.FALSE. + !CALL dbcsr_get_stored_coordinates(distr_pattern,& + ! idomain, idomain, transp, dest_node) IF (dest_node == mynode) THEN submatrix(idomain)%domain = idomain submatrix(idomain)%nbrows = 0 @@ -1093,9 +1174,12 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) + !DO row = 1, nblkrows_tot + ! IF (qblk_exists(domain_map,row,idomain)) THEN first_row(row) = submatrix(idomain)%nrows + 1 submatrix(idomain)%nrows = submatrix(idomain)%nrows + row_blk_size(row) submatrix(idomain)%nbrows = submatrix(idomain)%nbrows + 1 + ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_row(submatrix(idomain)%nbrows)) ALLOCATE (submatrix(idomain)%size_brow(submatrix(idomain)%nbrows)) @@ -1106,9 +1190,12 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) + !DO row = 1, nblkrows_tot + ! IF (first_row(row).ne.-1) THEN submatrix(idomain)%dbcsr_row(smrow) = row submatrix(idomain)%size_brow(smrow) = row_blk_size(row) smrow = smrow + 1 + ! ENDIF END DO ! loop over the necessary columns @@ -1129,9 +1216,17 @@ CONTAINS ELSE col = idomain END IF + !DO col = 1, nblkcols_tot + ! IF (job_type==select_row_col) THEN + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)) + ! ELSE + ! domain_needs_block=(col==idomain) ! RZK-warning col belongs to the domain + ! ENDIF + ! IF (domain_needs_block) THEN first_col(col) = submatrix(idomain)%ncols + 1 submatrix(idomain)%ncols = submatrix(idomain)%ncols + col_blk_size(col) submatrix(idomain)%nbcols = submatrix(idomain)%nbcols + 1 + ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_col(submatrix(idomain)%nbcols)) @@ -1155,9 +1250,12 @@ CONTAINS ELSE col = idomain END IF + !DO col = 1, nblkcols_tot + ! IF (first_col(col).ne.-1) THEN submatrix(idomain)%dbcsr_col(smcol) = col submatrix(idomain)%size_bcol(smcol) = col_blk_size(col) smcol = smcol + 1 + ! ENDIF END DO ALLOCATE (submatrix(idomain)%mdata( & diff --git a/src/ec_orth_solver.F b/src/ec_orth_solver.F index 65e07cfaf7..1a8a904a72 100644 --- a/src/ec_orth_solver.F +++ b/src/ec_orth_solver.F @@ -241,9 +241,8 @@ CONTAINS ! Tr(r_0 * r_0) CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, norm_rr(ispin)) - IF (abnormal_value(norm_rr(ispin))) THEN + IF (abnormal_value(norm_rr(ispin))) & CPABORT("Preconditioner: Tr[r_j*r_j] is an abnormal value (NaN/Inf)") - END IF IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0") norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp))) @@ -273,9 +272,8 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) THEN + IF (abnormal_value(new_norm(ispin))) & CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") - END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps*0.001_dp & @@ -712,9 +710,8 @@ CONTAINS CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin)) CPABORT("tr(Ap_j*p_j) < 0") - IF (abnormal_value(norm_cA(ispin))) THEN + IF (abnormal_value(norm_cA(ispin))) & CPABORT("Preconditioner: Tr[Ap_j*p_j] is an abnormal value (NaN/Inf)") - END IF END IF @@ -793,9 +790,8 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_z0(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) THEN + IF (abnormal_value(new_norm(ispin))) & CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") - END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps .OR. new_norm(ispin) < linres_control%eps) THEN diff --git a/src/eeq_data.F b/src/eeq_data.F index b030a0bde8..dc1bdef0d6 100644 --- a/src/eeq_data.F +++ b/src/eeq_data.F @@ -247,7 +247,7 @@ CONTAINS IF (PRESENT(eta)) eta = eeqGam(za) IF (PRESENT(kcn)) kcn = eeqkCN(za) IF (PRESENT(rad)) rad = eeqAlp(za) - ELSE IF (model == 2) THEN + ELSEIF (model == 2) THEN CPASSERT(za <= max_elem) IF (PRESENT(chi)) chi = eeq_chi(za) IF (PRESENT(eta)) eta = eeq_eta(za) diff --git a/src/eeq_method.F b/src/eeq_method.F index 7e4c0f94f4..7e86e08ea0 100644 --- a/src/eeq_method.F +++ b/src/eeq_method.F @@ -1611,7 +1611,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1693,7 +1693,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1764,7 +1764,7 @@ CONTAINS dfilter(1:3) = dft_control%period_efield%d_filter(1:3) fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi omega = cell%deth @@ -1882,7 +1882,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) diff --git a/src/efield_tb_methods.F b/src/efield_tb_methods.F index a7395d9325..11fbabcaf5 100644 --- a/src/efield_tb_methods.F +++ b/src/efield_tb_methods.F @@ -281,7 +281,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'efield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi + COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) INTEGER :: atom_a, atom_b, handle, ia, iac, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, & @@ -334,7 +334,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -452,7 +452,7 @@ CONTAINS NULLIFY (sap_int) IF (dft_control%qs_control%dftb) THEN CPABORT("DFTB stress tensor for periodic efield not implemented") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL xtb_dsint_list(qs_env, sap_int) ELSE CPABORT("TB method unknown") @@ -612,7 +612,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'dfield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi + COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) INTEGER :: atom_a, atom_b, handle, i, ia, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, nspin @@ -674,7 +674,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/efield_utils.F b/src/efield_utils.F index 59efeb61bc..352369cdca 100644 --- a/src/efield_utils.F +++ b/src/efield_utils.F @@ -140,7 +140,7 @@ CONTAINS IF (DOT_PRODUCT(efield%polarisation, efield%polarisation) == 0) THEN pol(:) = 1.0_dp/3.0_dp ELSE - pol(:) = efield%polarisation(:)/NORM2(efield%polarisation) + pol(:) = efield%polarisation(:)/(SQRT(DOT_PRODUCT(efield%polarisation, efield%polarisation))) END IF SELECT CASE (efield%envelop_id) @@ -151,12 +151,10 @@ CONTAINS efield%phase_offset*pi)*pol(:) END IF CASE (ramp_env) - IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) THEN + IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) & strength = E_0*(sim_step - efield%envelop_i_vars(1))/(efield%envelop_i_vars(2) - efield%envelop_i_vars(1)) - END IF - IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) THEN + IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) & strength = E_0*(efield%envelop_i_vars(4) - sim_step)/(efield%envelop_i_vars(4) - efield%envelop_i_vars(3)) - END IF IF (sim_step > efield%envelop_i_vars(4) .AND. efield%envelop_i_vars(4) > 0) strength = 0.0_dp IF (sim_step <= efield%envelop_i_vars(1)) strength = 0.0_dp field = field + strength*COS(sim_time*nu*twopi + & diff --git a/src/eip_silicon.F b/src/eip_silicon.F index 0d611e56c8..1e5bf4d308 100644 --- a/src/eip_silicon.F +++ b/src/eip_silicon.F @@ -34,7 +34,6 @@ MODULE eip_silicon USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_para_env_type USE particle_types, ONLY: particle_type USE physcon, ONLY: angstrom,& @@ -927,17 +926,25 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & - ener, coord, ener_var, coord_var, count + REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & + ener_var, coord_var, count - INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & - laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, myspaceout, ncx, nn, nnbrx, npr - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb, num2, num3, numz - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, & - rlc3i, tcoord, tcoord2, tener, tener2 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz, s2, s3, sz, txyz + DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: s2, s3, sz + INTEGER, ALLOCATABLE, DIMENSION(:) :: num2, num3, numz + + REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, rlc3i, tcoord, & + tcoord2, tener, tener2 + INTEGER :: iam, iat, iat1, iat2, ii, i, il, in, indlst, indlstx, istop, & + istopg, l2, l3, laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, & + l1, myspaceout, ncx, nn, nnbrx, npr ! cut=par_a cut = 3.1213820e0_dp + 1.e-14_dp @@ -1557,6 +1564,8 @@ CONTAINS END IF !$OMP END PARALLEL +! write(*,*) 'ener,norm force', & +! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2012,13 +2021,16 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) - INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rxyz + INTEGER :: icell, lstb, lay + REAL(KIND=dp) :: rel, cut2 INTEGER :: indlst - INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & + lstb(0:myspace - 1), rel(5, 0:myspace - 1) + + INTEGER :: jat, k1, k2, k3, jj + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -2079,18 +2091,25 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & - ener, coord, ener_var, coord_var, count + REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & + ener_var, coord_var, count - INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & - laymx, ll1, ll2, ll3, lot, myspace, myspaceout, ncx, nn, nnbrx, npjkx, npjx, npr, rlc1i, & - rlc2i, rlc3i - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & - tcoord2, tener, tener2 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik, rel, rxyz, txyz + DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik + + REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & + tcoord2, tener, tener2 + INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, & + istop, istopg, l1, l2, l3, ll1, ll2, ll3, lot, ncx, nn, & + nnbrx, npjkx, npjx, laymx, npr, rlc1i, rlc2i, rlc3i, & + myspace, myspaceout ! tmax_phi= 0.4500000e+01_dp ! cut=tmax_phi @@ -2701,6 +2720,8 @@ CONTAINS END IF !$OMP END PARALLEL +! write(*,*) 'ener,norm force', & +! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2738,78 +2759,115 @@ CONTAINS ! with them and their contribution to the energy (tener). ! In addition the coordination number tcoord and the second moment of the ! local energy tener2 and coordination number tcoord2 are returned - INTEGER :: iat1, iat2, nat, lsta(2, nat) - REAL(KIND=dp) :: tener, tener2, tcoord, tcoord2 + INTEGER :: iat1, iat2, nat, lsta, lstb + REAL(KIND=dp) :: rel, tener, tener2, tcoord, tcoord2 INTEGER :: nnbrx - REAL(KIND=dp) :: rel(5, nnbrx*nat) - INTEGER :: lstb(nnbrx*nat) - REAL(KIND=dp) :: txyz(3, nat) + REAL(KIND=dp) :: txyz, f2ij INTEGER :: npjx - REAL(KIND=dp) :: f2ij(3, npjx) + REAL(KIND=dp) :: f3ij INTEGER :: npjkx - REAL(KIND=dp) :: f3ij(3, npjkx), f3ik(3, npjkx) + REAL(KIND=dp) :: f3ik INTEGER :: istop - REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: cof_rho = [0.13747000000000e+00_dp, & - -0.14831000000000e+00_dp, -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & - -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, -0.66620000000000e+00_dp, & - -0.57328000000000e+00_dp, -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & - 0.00000000000000e+00_dp] - REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: dof_rho = [-0.32275496741918e+01_dp, & - -0.64119006516165e+01_dp, 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & - 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, 0.47189016693543e+00_dp, & - 0.20569572748420e+01_dp, 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & - -0.12371959895186e+02_dp] - REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: cof_ggg = [0.52541600000000e+01_dp, & - 0.23591500000000e+01_dp, 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & - 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, 0.49485900000000e+01_dp, & - 0.56179900000000e+01_dp], cof_uuu = [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & - 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, 0.12668900000000e+01_dp, & - 0.16299800000000e+01_dp, 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] - REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: dof_ggg = [0.15826876132396e+02_dp, & - 0.31176239377907e+02_dp, 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & - 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, -0.18823313223755e+02_dp, & - -0.77183416481005e+01_dp], dof_uuu = [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & - -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, -0.15815242579643e-01_dp, & - 0.26112640061855e-01_dp, -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] - REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: cof_fff = [0.12503100000000e+01_dp, & - 0.86821000000000e+00_dp, 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & - 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, 0.27145000000000e+00_dp, & - 0.14814000000000e+00_dp, 0.48550000000000e-01_dp, 0.00000000000000e+00_dp], cof_phi = [ & - 0.69299400000000e+01_dp, -0.43995000000000e+00_dp, -0.17012300000000e+01_dp, & - -0.16247300000000e+01_dp, -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & - -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, -0.96100000000000e-02_dp, & - 0.00000000000000e+00_dp] - REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: dof_fff = [0.27904652711432e+02_dp, & - -0.45230754228635e+01_dp, 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & - -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, -0.50891685571587e+00_dp, & - 0.66278396115427e+00_dp, 0.73976101109878e+00_dp, 0.25795319944506e+01_dp], dof_phi = [ & - 0.16533229480429e+03_dp, 0.39415410391417e+02_dp, 0.68710036300407e+01_dp, & - 0.53406950884203e+01_dp, 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & - -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, -0.40087646318907e-01_dp, & - -0.23942617684055e+00_dp] - REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp, & - h2sixth_ggg = 1.10221225156463e-002_dp, h2sixth_phi = 1.85185185185185e-002_dp, & - h2sixth_rho = 6.66666666666667e-003_dp, h2sixth_uuu = 0.318679429600340e0_dp, & - hi_fff = 4.50000000000e0_dp, hi_ggg = 3.88858644327663e0_dp, hi_phi = 3.00000000000e0_dp, & - hi_rho = 5.00000000000e0_dp, hi_uuu = 0.723181585730594e0_dp, & - hsixth_fff = 3.70370370370370e-002_dp, hsixth_ggg = 4.28604761904762e-002_dp, & - hsixth_phi = 5.55555555555556e-002_dp, hsixth_rho = 3.33333333333333e-002_dp, & - hsixth_uuu = 0.230463095238095e0_dp - REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp, tmax_ggg = 0.8001400e+00_dp, & - tmax_phi = 0.4500000e+01_dp, tmax_rho = 0.3500000e+01_dp, tmax_uuu = 0.7908520e+01_dp, & - tmin_fff = 0.1500000e+01_dp, tmin_ggg = -0.1000000e+01_dp, tmin_phi = 0.1500000e+01_dp, & - tmin_rho = 0.1500000e+01_dp, tmin_uuu = -0.1770930e+01_dp + DIMENSION lsta(2, nat), lstb(nnbrx*nat), rel(5, nnbrx*nat), txyz(3, nat) + DIMENSION f2ij(3, npjx), f3ij(3, npjkx), f3ik(3, npjkx) + REAL(KIND=dp), PARAMETER :: tmin_phi = 0.1500000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_phi = 0.4500000e+01_dp + REAL(KIND=dp), PARAMETER :: hi_phi = 3.00000000000e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_phi = 5.55555555555556e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_phi = 1.85185185185185e-002_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_phi = & + [0.69299400000000e+01_dp, -0.43995000000000e+00_dp, & + -0.17012300000000e+01_dp, -0.16247300000000e+01_dp, & + -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & + -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, & + -0.96100000000000e-02_dp, 0.00000000000000e+00_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_phi = & + [0.16533229480429e+03_dp, 0.39415410391417e+02_dp, & + 0.68710036300407e+01_dp, 0.53406950884203e+01_dp, & + 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & + -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, & + -0.40087646318907e-01_dp, -0.23942617684055e+00_dp] + REAL(KIND=dp), PARAMETER :: tmin_rho = 0.1500000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_rho = 0.3500000e+01_dp + REAL(KIND=dp), PARAMETER :: hi_rho = 5.00000000000e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_rho = 3.33333333333333e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_rho = 6.66666666666667e-003_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: cof_rho = & + [0.13747000000000e+00_dp, -0.14831000000000e+00_dp, & + -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & + -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, & + -0.66620000000000e+00_dp, -0.57328000000000e+00_dp, & + -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & + 0.00000000000000e+00_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: dof_rho = & + [-0.32275496741918e+01_dp, -0.64119006516165e+01_dp, & + 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & + 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, & + 0.47189016693543e+00_dp, 0.20569572748420e+01_dp, & + 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & + -0.12371959895186e+02_dp] + REAL(KIND=dp), PARAMETER :: tmin_fff = 0.1500000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp + REAL(KIND=dp), PARAMETER :: hi_fff = 4.50000000000e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_fff = 3.70370370370370e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_fff = & + [0.12503100000000e+01_dp, 0.86821000000000e+00_dp, & + 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & + 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, & + 0.27145000000000e+00_dp, 0.14814000000000e+00_dp, & + 0.48550000000000e-01_dp, 0.00000000000000e+00_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_fff = & + [0.27904652711432e+02_dp, -0.45230754228635e+01_dp, & + 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & + -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, & + -0.50891685571587e+00_dp, 0.66278396115427e+00_dp, & + 0.73976101109878e+00_dp, 0.25795319944506e+01_dp] + REAL(KIND=dp), PARAMETER :: tmin_uuu = -0.1770930e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_uuu = 0.7908520e+01_dp + REAL(KIND=dp), PARAMETER :: hi_uuu = 0.723181585730594e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_uuu = 0.230463095238095e0_dp + REAL(KIND=dp), PARAMETER :: h2sixth_uuu = 0.318679429600340e0_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_uuu = & + [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & + 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, & + 0.12668900000000e+01_dp, 0.16299800000000e+01_dp, & + 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_uuu = & + [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & + -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, & + -0.15815242579643e-01_dp, 0.26112640061855e-01_dp, & + -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] + REAL(KIND=dp), PARAMETER :: tmin_ggg = -0.1000000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_ggg = 0.8001400e+00_dp + REAL(KIND=dp), PARAMETER :: hi_ggg = 3.88858644327663e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_ggg = 4.28604761904762e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_ggg = 1.10221225156463e-002_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_ggg = & + [0.52541600000000e+01_dp, 0.23591500000000e+01_dp, & + 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & + 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, & + 0.49485900000000e+01_dp, 0.56179900000000e+01_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_ggg = & + [0.15826876132396e+02_dp, 0.31176239377907e+02_dp, & + 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & + 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, & + -0.18823313223755e+02_dp, -0.77183416481005e+01_dp] - INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, & - khi_fff, khi_ggg, klo_fff, klo_ggg - REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, b_ggg, cof1_fff, & - cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, & - cof_fff_klo, cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, dens2, dens3, & - dof_fff_khi, dof_fff_klo, dof_ggg_khi, dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, & - ep_uuu, fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, gjik, gjikp, rho, rhop, & - rij, rik, sij, sik, t1, t2, t3, t4, tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, & - ypt2_fff, ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg + REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, & + b_ggg, cof1_fff, cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, & + cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, cof_fff_klo, & + cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, & + dens2, dens3, dof_fff_khi, dof_fff_klo, dof_ggg_khi, & + dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, ep_uuu, & + fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, & + gjik, gjikp, rho, rhop, rij, rik, sij, sik, t1, t2, t3, t4, & + tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, ypt2_fff, & + ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg + + INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, khi_fff, khi_ggg, & + klo_fff, klo_ggg ! initialize temporary private scalars for reduction sum on energies and ! private workarray txyz for forces forces @@ -3153,13 +3211,16 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) - INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rxyz + INTEGER :: icell, lstb, lay + REAL(KIND=dp) :: rel, cut2 INTEGER :: indlst - INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & + lstb(0:myspace - 1), rel(5, 0:myspace - 1) + + INTEGER :: jat, jj, k1, k2, k3 + REAL(KIND=dp) :: rr2, tt, xrel, yrel, zrel, tti loop_k3: DO k3 = l3 - 1, l3 + 1 loop_k2: DO k2 = l2 - 1, l2 + 1 @@ -3207,14 +3268,14 @@ CONTAINS !> \param yp ... ! ************************************************************************************************** SUBROUTINE splint(ya, y2a, tmin, tmax, hsixth, h2sixth, hi, n, x, y, yp) - REAL(KIND=dp) :: tmin, tmax, hsixth, h2sixth, hi + REAL(KIND=dp) :: ya, y2a, tmin, tmax, hsixth, h2sixth, hi INTEGER :: n - REAL(KIND=dp) :: y2a(0:n - 1), ya(0:n - 1), x, y, yp + REAL(KIND=dp) :: x, y, yp - INTEGER :: khi, klo - REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, & - tt, y2a_khi, y2a_klo, ya_khi, ya_klo, & - ypt1, ypt2, yt1, yt2 + DIMENSION y2a(0:n - 1), ya(0:n - 1) + REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, tt, & + y2a_khi, ya_klo, y2a_klo, ya_khi, ypt1, ypt2, yt1, yt2 + INTEGER :: klo, khi ! interpolate if the argument is outside the cubic spline interval [tmin,tmax] tt = (x - tmin)*hi @@ -3295,15 +3356,15 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV -! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, -! needs to be initialized to 0._dp before calling this routine for the first time +! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, real(8) : total potential energy, 2-body and 3-body, in eV +! count, real(8) : increased by 1.d0 at each call of this subroutine, +! needs to be initialized to 0.d0 before calling this routine for the first time ! ! Other variables: ! p: the 2-body potential energy @@ -3316,12 +3377,9 @@ CONTAINS !***************************************************************************************** INTEGER :: nat - REAL(dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + REAL(8) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & etot, count - REAL(KIND=dp), PARAMETER :: eps = 2.167239428587_dp, ra = 1.8_dp, & - sigma = 2.0951_dp - INTEGER :: i, iam, iat, ii, il, in, indlst, & indlstx, ipb, l1, l2, l3, laymx, ll1, & ll2, ll3, myspace, myspaceout, ncx, & @@ -3329,14 +3387,18 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(dp) :: cut, cut2, esigma, fx(nat), fx3(nat), & - fy(nat), fy3(nat), fz(nat), fz3(nat), & - isigma, p, p3, pv3, rlc1i, rlc2i, rlc3i - REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(8) :: cut, cut2, eps, esigma, fx(nat), & + fx3(nat), fy(nat), fy3(nat), fz(nat), & + fz3(nat), isigma, p, p3, pv3, ra, & + rlc1i, rlc2i, rlc3i, sigma + REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - count = count + 1._dp - cut = sigma*ra*2._dp - isigma = 1._dp/sigma + PARAMETER(ra=1.8d0) + PARAMETER(sigma=2.0951d0, eps=2.167239428587d0) + + count = count + 1.d0 + cut = sigma*ra*2.d0 + isigma = 1.d0/sigma esigma = eps*isigma ! linear scaling calculation of verlet list, only serial @@ -3810,15 +3872,15 @@ CONTAINS !start energy and force calculation------------------------------------------------------- !set all variables to zero - p = 0.0_dp - p3 = 0.0_dp - pv3 = 0.0_dp - fx(:) = 0.0_dp - fy(:) = 0.0_dp - fz(:) = 0.0_dp - fx3(:) = 0.0_dp - fy3(:) = 0.0_dp - fz3(:) = 0.0_dp + p = 0.0d0 + p3 = 0.0d0 + pv3 = 0.0d0 + fx(:) = 0.0d0 + fy(:) = 0.0d0 + fz(:) = 0.0d0 + fx3(:) = 0.0d0 + fy3(:) = 0.0d0 + fz3(:) = 0.0d0 !----------------------------------------------------------------------------------------- ! triple loop for the 2 and 3-body forces ! do 20 i @@ -3854,22 +3916,23 @@ CONTAINS !> \param c ... !> \return ... ! ************************************************************************************************** - REAL(KIND=dp) FUNCTION f(c) - REAL(KIND=dp) :: c + REAL(8) FUNCTION f(c) + REAL(8) :: c - REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & - bb = 0.6022245584_dp, ra = 1.8_dp + REAL(8) :: aa, bb, c4, crainv, ra - REAL(KIND=dp) :: c4, crainv + PARAMETER(aa=7.049556277d0) + PARAMETER(ra=1.8d0, bb=0.6022245584d0) - IF ((c - ra) < 0._dp) THEN - crainv = 1.0_dp/(c - ra) + IF ((c - ra) < 0.d0) THEN + crainv = 1.0d0/(c - ra) c4 = c*c*c*c - f = aa*bb*4.0_dp/(c4*c)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv + f = aa*bb*4.0d0/(c4*c)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv ELSE - f = 0._dp + f = 0.d0 END IF + RETURN END FUNCTION f ! ************************************************************************************************** @@ -3877,17 +3940,18 @@ CONTAINS !> \param d ... !> \return ... ! ************************************************************************************************** - REAL(KIND=dp) FUNCTION pe(d) - REAL(KIND=dp) :: d + REAL(8) FUNCTION pe(d) + REAL(8) :: d - REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & - bb = 0.6022245584_dp, ra = 1.8_dp + REAL(8), PARAMETER :: aa = 7.049556277d0, bb = 0.6022245584d0, & + ra = 1.8d0 - IF ((d - ra) < 0._dp) THEN - pe = aa*(bb/(d*d*d*d) - 1.0_dp)*EXP(1.0_dp/(d - ra)) + IF ((d - ra) < 0.d0) THEN + pe = aa*(bb/(d*d*d*d) - 1.0d0)*dexp(1.0d0/(d - ra)) ELSE - pe = 0._dp + pe = 0.d0 END IF + RETURN END FUNCTION pe !------------------------------------------------------------------------------------------ @@ -3917,13 +3981,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) + REAL(8) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(8) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + REAL(8) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -3940,7 +4004,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1._dp/tt + tti = 1.d0/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -3977,25 +4041,24 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE sw_subfeniat_l(i, nat, nnbrx, rel, p, p3, fx, fy, fz, fx3, fy3, fz3, lstb, lsta, isigma, sigma) INTEGER, INTENT(IN) :: i, nat, nnbrx - REAL(KIND=dp), INTENT(IN) :: rel(5, nnbrx*nat) - REAL(KIND=dp), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & + REAL(8), INTENT(IN) :: rel(5, nnbrx*nat) + REAL(8), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & fx3(nat), fy3(nat), fz3(nat) INTEGER, INTENT(IN) :: lstb(nnbrx*nat), lsta(2, nat) - REAL(KIND=dp), INTENT(IN) :: isigma, sigma - - REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & - bb = 0.6022245584_dp, gam = 1.2_dp, & - ra = 1.8_dp, ramda = 21.0_dp + REAL(8), INTENT(IN) :: isigma, sigma INTEGER :: Ipb, Ipe, j, k, l, m, nij - REAL(KIND=dp) :: c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, hi, & - hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, hiyik0, & - hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, hjxjk, & - hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, HJZIJ1, & - HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, hkyik0, & - hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, invrij, & - invrija, invrik, invrika, invrjk, invrjka, refi, refj, refk, rij, rija, rik - REAL(KIND=dp) :: rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk + REAL(8) :: aa, bb, c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, & + gam, hi, hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, & + hiyik0, hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, & + hjxjk, hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, & + HJZIJ1, HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, & + hkyik0, hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, & + invrij, invrija, invrik, invrika, invrjk, invrjka, ra, ramda, refi, refj + REAL(8) :: refk, rij, rija, rik, rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk + + PARAMETER(gam=1.2d0, ramda=21.0d0, aa=7.049556277d0) + PARAMETER(ra=1.8d0, bb=0.6022245584d0) Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -4010,11 +4073,11 @@ CONTAINS yij = rel(2, l)*rij zij = rel(3, l)*rij - IF (rij >= 2._dp*ra) CYCLE + IF (rij >= 2.d0*ra) CYCLE IF (rij < ra) THEN - crainv = 1.0_dp/(rij - ra) + crainv = 1.0d0/(rij - ra) c4 = rij*rij*rij*rij - force = aa*bb*4.0_dp/(c4*rij)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv + force = aa*bb*4.0d0/(c4*rij)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv fx(i) = force*xij*invrij + fx(i) fy(i) = force*yij*invrij + fy(i) @@ -4024,7 +4087,7 @@ CONTAINS fy(j) = -force*yij*invrij + fy(j) fz(j) = -force*zij*invrij + fz(j) - p = p + aa*(bb/(rij*rij*rij*rij) - 1.0_dp)*EXP(1.0_dp/(rij - ra)) + p = p + aa*(bb/(rij*rij*rij*rij) - 1.0d0)*dexp(1.0d0/(rij - ra)) nij = 1 END IF @@ -4045,42 +4108,42 @@ CONTAINS zjk = zik - zij rjk = SQRT(xjk*xjk + yjk*yjk + zjk*zjk) - invrjk = 1._dp/rjk + invrjk = 1.d0/rjk IF ((rjk >= ra) .AND. (nij == 0)) CYCLE cosjik = (xij*xik + yij*yik + zij*zik)*(invrij*invrik) cosijk = (-xij*xjk - yij*yjk - zij*zjk)*(invrij*invrjk) cosikj = (xik*xjk + yik*yjk + zik*zjk)*(invrik*invrjk) - cosjik3 = cosjik + 1.0_dp/3.0_dp - cosijk3 = cosijk + 1.0_dp/3.0_dp - cosikj3 = cosikj + 1.0_dp/3.0_dp + cosjik3 = cosjik + 1.0d0/3.0d0 + cosijk3 = cosijk + 1.0d0/3.0d0 + cosikj3 = cosikj + 1.0d0/3.0d0 rija = rij - ra rika = rik - ra rjka = rjk - ra - invrija = 1._dp/rija - invrika = 1._dp/rika - invrjka = 1._dp/rjka + invrija = 1.d0/rija + invrika = 1.d0/rika + invrjka = 1.d0/rjka - IF (rija >= 0.0_dp) THEN - refi = 0.0_dp - refj = 0.0_dp + IF (rija >= 0.0d0) THEN + refi = 0.0d0 + refj = 0.0d0 refk = ramda*EXP(gam*invrika + gam*invrjka) - ELSE IF ((rija < 0.0_dp) .AND. (rika < 0.0_dp)) THEN - IF (rjka < 0.0_dp) THEN + ELSE IF ((rija < 0.0d0) .AND. (rika < 0.0d0)) THEN + IF (rjka < 0.0d0) THEN refi = ramda*EXP(gam*invrija + gam*invrika) refj = ramda*EXP(gam*invrija + gam*invrjka) refk = ramda*EXP(gam*invrika + gam*invrjka) ELSE refi = ramda*EXP(gam*invrija + gam*invrika) - refj = 0.0_dp - refk = 0.0_dp + refj = 0.0d0 + refk = 0.0d0 END IF - ELSE IF ((rija < 0.0_dp) .AND. (rjka < 0.0_dp)) THEN - refi = 0.0_dp + ELSE IF ((rija < 0.0d0) .AND. (rjka < 0.0d0)) THEN + refi = 0.0d0 refj = ramda*EXP(gam*invrija + gam*invrjka) - refk = 0.0_dp + refk = 0.0d0 ELSE CYCLE END IF @@ -4090,60 +4153,60 @@ CONTAINS hk = refk*cosikj3*cosikj3 p3 = p3 + hi + hj + hk - hixij0 = 2.0_dp*(xik*invrik - xij*cosjik*invrij) + hixij0 = 2.0d0*(xik*invrik - xij*cosjik*invrij) hixij1 = gam*xij*cosjik3*(invrija*invrija) hixij = refi*cosjik3*(hixij0 - hixij1)*invrij - hixik0 = 2.0_dp*(xij*invrij - xik*cosjik*invrik) + hixik0 = 2.0d0*(xij*invrij - xik*cosjik*invrik) hixik1 = gam*xik*cosjik3*(invrika*invrika) hixik = refi*cosjik3*(hixik0 - hixik1)*invrik - hjxij0 = 2.0_dp*(-xjk*invrjk - xij*cosijk*invrij) + hjxij0 = 2.0d0*(-xjk*invrjk - xij*cosijk*invrij) hjxij1 = gam*xij*cosijk3*(invrija*invrija) hjxij = refj*cosijk3*(hjxij0 - hjxij1)*invrij - hkxik0 = 2.0_dp*(xjk*invrjk - xik*cosikj*invrik) + hkxik0 = 2.0d0*(xjk*invrjk - xik*cosikj*invrik) hkxik1 = gam*xik*cosikj3*(invrika*invrika) hkxik = refk*cosikj3*(hkxik0 - hkxik1)*invrik - hjxjk0 = 2.0_dp*(-xij*invrij - xjk*cosijk*invrjk) + hjxjk0 = 2.0d0*(-xij*invrij - xjk*cosijk*invrjk) hjxjk1 = gam*xjk*cosijk3*(invrjka*invrjka) hjxjk = refj*cosijk3*(hjxjk0 - hjxjk1)*invrjk - hkxkj0 = 2.0_dp*(-xik*invrik + xjk*cosikj*invrjk) + hkxkj0 = 2.0d0*(-xik*invrik + xjk*cosikj*invrjk) hkxkj1 = gam*xjk*cosikj3*(invrjka*invrjka) hkxkj = refk*cosikj3*(hkxkj0 + hkxkj1)*invrjk - hiyij0 = 2.0_dp*(yik*invrik - yij*cosjik*invrij) + hiyij0 = 2.0d0*(yik*invrik - yij*cosjik*invrij) hiyij1 = gam*yij*cosjik3*(invrija*invrija) hiyij = refi*cosjik3*(hiyij0 - hiyij1)*invrij - hiyik0 = 2.0_dp*(yij*invrij - yik*cosjik*invrik) + hiyik0 = 2.0d0*(yij*invrij - yik*cosjik*invrik) hiyik1 = gam*yik*cosjik3*(invrika*invrika) hiyik = refi*cosjik3*(hiyik0 - hiyik1)*invrik - hjyij0 = 2.0_dp*(-yjk*invrjk - yij*cosijk*invrij) + hjyij0 = 2.0d0*(-yjk*invrjk - yij*cosijk*invrij) hjyij1 = gam*yij*cosijk3*(invrija*invrija) hjyij = refj*cosijk3*(hjyij0 - hjyij1)*invrij - hkyik0 = 2.0_dp*(yjk*invrjk - yik*cosikj*invrik) + hkyik0 = 2.0d0*(yjk*invrjk - yik*cosikj*invrik) hkyik1 = gam*yik*cosikj3*(invrika*invrika) hkyik = refk*cosikj3*(hkyik0 - hkyik1)*invrik - hjyjk0 = 2.0_dp*(-yij*invrij - yjk*cosijk*invrjk) + hjyjk0 = 2.0d0*(-yij*invrij - yjk*cosijk*invrjk) hjyjk1 = gam*yjk*cosijk3*(invrjka*invrjka) hjyjk = refj*cosijk3*(hjyjk0 - hjyjk1)*invrjk - hkykj0 = 2.0_dp*(-yik*invrik + yjk*cosikj*invrjk) + hkykj0 = 2.0d0*(-yik*invrik + yjk*cosikj*invrjk) hkykj1 = gam*yjk*cosikj3*(invrjka*invrjka) hkykj = refk*cosikj3*(hkykj0 + hkykj1)*invrjk - hizij0 = 2.0_dp*(zik*invrik - zij*cosjik*invrij) + hizij0 = 2.0d0*(zik*invrik - zij*cosjik*invrij) hizij1 = gam*zij*cosjik3*(invrija*invrija) hizij = refi*cosjik3*(hizij0 - hizij1)*invrij - hizik0 = 2.0_dp*(zij*invrij - zik*cosjik*invrik) + hizik0 = 2.0d0*(zij*invrij - zik*cosjik*invrik) hizik1 = gam*zik*cosjik3*(invrika*invrika) hizik = refi*cosjik3*(hizik0 - hizik1)*invrik - hjzij0 = 2.0_dp*(-zjk*invrjk - zij*cosijk*invrij) + hjzij0 = 2.0d0*(-zjk*invrjk - zij*cosijk*invrij) hjzij1 = gam*zij*cosijk3*(invrija*invrija) hjzij = refj*cosijk3*(hjzij0 - hjzij1)*invrij - hkzik0 = 2.0_dp*(zjk*invrjk - zik*cosikj*invrik) + hkzik0 = 2.0d0*(zjk*invrjk - zik*cosikj*invrik) hkzik1 = gam*zik*cosikj3*(invrika*invrika) hkzik = refk*cosikj3*(hkzik0 - hkzik1)*invrik - hjzjk0 = 2.0_dp*(-zij*invrij - zjk*cosijk*invrjk) + hjzjk0 = 2.0d0*(-zij*invrij - zjk*cosijk*invrjk) hjzjk1 = gam*zjk*cosijk3*(invrjka*invrjka) hjzjk = refj*cosijk3*(hjzjk0 - hjzjk1)*invrjk - hkzkj0 = 2.0_dp*(-zik*invrik + zjk*cosikj*invrjk) + hkzkj0 = 2.0d0*(-zik*invrik + zjk*cosikj*invrjk) hkzkj1 = gam*zjk*cosikj3*(invrjka*invrjka) hkzkj = refk*cosikj3*(hkzkj0 + hkzkj1)*invrjk @@ -4188,32 +4251,32 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV -! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, -! needs to be initialized to 0._dp before calling this routine for the first time +! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, real(8) : total potential energy, 2-body and 3-body, in eV +! count, real(8) : increased by 1.d0 at each call of this subroutine, +! needs to be initialized to 0.d0 before calling this routine for the first time !***************************************************************************************** INTEGER :: nat - REAL(KIND=dp) :: alat(3), rxyz(3, nat), fxyz(3, nat), & + REAL(8) :: alat(3), rxyz(3, nat), fxyz(3, nat), & etot, count INTEGER :: iat, NNmax, Npmax INTEGER, ALLOCATABLE, DIMENSION(:) :: Kinds, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - REAL(KIND=dp) :: Uatot, Urtot, xbox, ybox, zbox - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf - REAL(KIND=dp), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn - REAL(KIND=dp), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X + REAL(8) :: Uatot, Urtot, xbox, ybox, zbox + REAL(8), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf + REAL(8), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn + REAL(8), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X INTEGER:: nnbrx, nnbrxt INTEGER :: i - count = count + 1._dp + count = count + 1.d0 DO iat = 1, nat rxyz(1, iat) = MODULO(MODULO(rxyz(1, iat), alat(1)), alat(1)) @@ -4233,7 +4296,7 @@ CONTAINS DO i = 1, nat kinds(i) = 2 !Since all atoms are Si, all of kind 2 END DO - fxyz = 0.0_dp + fxyz = 0.0d0 xbox = alat(1); ybox = alat(2); zbox = alat(3) CALL tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) CALL tersoff_pairlist_energy_forces(nat, Npmax, NNmax, xbox, ybox, zbox, Kinds, rxyz, R1, R2, Cr, & @@ -4261,15 +4324,14 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) - REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X - REAL(KIND=dp), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass + REAL(8), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X + REAL(8), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass - REAL(KIND=dp), PARAMETER :: C_ala = 2.2119_dp, C_alr = 3.4879_dp, C_b = 1.5724e-7_dp, & - C_c = 3.8049e4_dp, C_Ca = 3.4674e2_dp, C_Cr = 1.3936e3_dp, C_d = 4.3484_dp, & - C_h = -5.7058e-1_dp, C_mass = 12.0_dp, C_n = 7.2751e-1_dp, C_R1 = 1.8_dp, C_R2 = 2.1_dp, & - Si_ala = 1.7322_dp, Si_alr = 2.4799_dp, Si_b = 1.1000e-6_dp, Si_c = 1.0039e5_dp, & - Si_Ca = 4.7118e2_dp, Si_Cr = 1.8308e3_dp, Si_d = 1.6217e1_dp, Si_h = -5.9825e-1_dp, & - Si_mass = 28.0855_dp, Si_n = 7.8734e-1_dp, Si_R1 = 2.7_dp, Si_R2 = 3.3_dp + REAL(8), PARAMETER :: C_ala = 2.2119d0, C_alr = 3.4879d0, C_b = 1.5724d-7, C_c = 3.8049d4, & + C_Ca = 3.4674d2, C_Cr = 1.3936d3, C_d = 4.3484d0, C_h = -5.7058d-1, C_mass = 12.0d0, & + C_n = 7.2751d-1, C_R1 = 1.8d0, C_R2 = 2.1d0, Si_ala = 1.7322d0, Si_alr = 2.4799d0, & + Si_b = 1.1000d-6, Si_c = 1.0039d5, Si_Ca = 4.7118d2, Si_Cr = 1.8308d3, Si_d = 1.6217d1, & + Si_h = -5.9825d-1, Si_mass = 28.0855d0, Si_n = 7.8734d-1, Si_R1 = 2.7d0, Si_R2 = 3.3d0 !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version @@ -4283,48 +4345,48 @@ CONTAINS !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version -!Increased Cutoff, originally 3.0_dp +!Increased Cutoff, originally 3.0d0 Cr(1, 1) = C_Cr Cr(2, 2) = Si_Cr - Cr(1, 2) = SQRT(Cr(1, 1)*Cr(2, 2)) + Cr(1, 2) = dsqrt(Cr(1, 1)*Cr(2, 2)) Cr(2, 1) = Cr(1, 2) Ca(1, 1) = C_Ca Ca(2, 2) = Si_Ca - Ca(1, 2) = SQRT(Ca(1, 1)*Ca(2, 2)) + Ca(1, 2) = dsqrt(Ca(1, 1)*Ca(2, 2)) Ca(2, 1) = Ca(1, 2) R1(1, 1) = C_R1 R1(2, 2) = Si_R1 - R1(1, 2) = SQRT(R1(1, 1)*R1(2, 2)) + R1(1, 2) = dsqrt(R1(1, 1)*R1(2, 2)) R1(2, 1) = R1(1, 2) R2(1, 1) = C_R2 R2(2, 2) = Si_R2 - R2(1, 2) = SQRT(R2(1, 1)*R2(2, 2)) + R2(1, 2) = dsqrt(R2(1, 1)*R2(2, 2)) R2(2, 1) = R2(1, 2) - X(1, 1) = 1.0_dp - X(2, 2) = 1.0_dp - X(1, 2) = 0.9776_dp - X(2, 1) = 0.9776_dp + X(1, 1) = 1.0d0 + X(2, 2) = 1.0d0 + X(1, 2) = 0.9776d0 + X(2, 1) = 0.9776d0 alr(1, 1) = C_alr alr(2, 2) = Si_alr - alr(1, 2) = 0.5_dp*(alr(1, 1) + alr(2, 2)) + alr(1, 2) = 0.5d0*(alr(1, 1) + alr(2, 2)) alr(2, 1) = alr(1, 2) ala(1, 1) = C_ala ala(2, 2) = Si_ala - ala(1, 2) = 0.5_dp*(ala(1, 1) + ala(2, 2)) + ala(1, 2) = 0.5d0*(ala(1, 1) + ala(2, 2)) ala(2, 1) = ala(1, 2) Pn(1) = C_n Pn(2) = Si_n - Co_bcd(1) = C_b*(1.0_dp + C_c*C_c/(C_d*C_d)) - Co_bcd(2) = Si_b*(1.0_dp + Si_c*Si_c/(Si_d*Si_d)) + Co_bcd(1) = C_b*(1.0d0 + C_c*C_c/(C_d*C_d)) + Co_bcd(2) = Si_b*(1.0d0 + Si_c*Si_c/(Si_d*Si_d)) bcsq(1) = C_b*C_c*C_c bcsq(2) = Si_b*Si_c*Si_c @@ -4377,32 +4439,35 @@ CONTAINS XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, & Pn, Co_bcd, bcsq, dsq, h, F, Uatot, dkEij) INTEGER, INTENT(in) :: Nmol, Npmax, NNmax - REAL(KIND=dp), INTENT(in) :: xbox, ybox, zbox + REAL(8), INTENT(in) :: xbox, ybox, zbox INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(in) :: R - REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X - REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf - REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf - REAL(KIND=dp), INTENT(out) :: Urtot + REAL(8), DIMENSION(1:3*Nmol), INTENT(in) :: R + REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X + REAL(8), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf + REAL(8), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf + REAL(8), INTENT(out) :: Urtot INTEGER :: lsta(2, Nmol) INTEGER, INTENT(inout) :: nnbrx INTEGER :: lstb(nnbrx*Nmol) - REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(out) :: F - REAL(KIND=dp), INTENT(out) :: Uatot - REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij + REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(8), DIMENSION(1:3*Nmol), INTENT(out) :: F + REAL(8), INTENT(out) :: Uatot + REAL(8), DIMENSION(1:3*NNmax) :: dkEij INTEGER :: i, iam, iat, ii, il, in, indlst, indlstx, Ipb, istopg, jat, l1, l2, l3, laymx, & ll1, ll2, ll3, myspace, myspaceout, nat, ncx, ndat, nn, npjkx, npjx, npr, Nptot INTEGER, ALLOCATABLE, DIMENSION(:) :: lay INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp) :: alat(3), cut, cut2, rlc1i, rlc2i, rlc3i, & - rxyz0(3, Nmol), xhalf, yhalf, zhalf - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(8) :: alat(3), cut, cut2, pi, rlc1i, rlc2i, & + rlc3i, rxyz0(3, Nmol), xhalf, yhalf, & + zhalf + REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - xhalf = 0.5_dp*xbox - yhalf = 0.5_dp*ybox - zhalf = 0.5_dp*zbox + pi = dacos(-1.0d0) + + xhalf = 0.5d0*xbox + yhalf = 0.5d0*ybox + zhalf = 0.5d0*zbox nat = Nmol @@ -4885,28 +4950,29 @@ CONTAINS istopg = 0 !end of creating pairlist part------------------------------------------------------------ !Energy----------------------------------------------------------------------------------- - Urtot = 0.0_dp + Urtot = 0.0d0 Nptot = 0 - F = 0.0_dp - Uatot = 0.0_dp + F = 0.0d0 + Uatot = 0.0d0 DO_I: DO i = 1, Nmol - CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) + CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel, pi) END DO DO_I - Urtot = 0.5_dp*Urtot + Urtot = 0.5d0*Urtot !Force------------------------------------------------------------------------------------ - F = 0.0_dp - Uatot = 0.0_dp + F = 0.0d0 + Uatot = 0.0d0 DO_If: DO i = 1, Nmol CALL tersoff_subfiat_l(i,Nmol,Npmax,NNmax,Kinds,Pn,Co_bcd,bcsq,dsq,h,XYZRrefdf,UadUrdf,F,Uatot,dkEij,lsta,lstb,nnbrx) END DO DO_If - F = 0.5_dp*F - Uatot = 0.5_dp*Uatot + F = 0.5d0*F + Uatot = 0.5d0*Uatot !----------------------------------------------------------------------------------------- DEALLOCATE (rxyz, icell, lay, rel) + RETURN END SUBROUTINE tersoff_pairlist_energy_forces !----------------------------------------------------------------------------------------- @@ -4936,13 +5002,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) + REAL(8) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(8) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + REAL(8) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -4959,7 +5025,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1._dp/tt + tti = 1.d0/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -4995,20 +5061,22 @@ CONTAINS !> \param lstb ... !> \param nnbrx ... !> \param rel ... +!> \param pi ... ! ************************************************************************************************** -SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) + SUBROUTINE tersoff_subeniat_l(i,Nmol,Npmax,Kinds,X,R1,R2,Cr,Ca,alr,ala,XYZRrefdf,UadUrdf,Urtot,lsta,lstb,nnbrx,rel,pi) INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala - REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf - REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf - REAL(KIND=dp), INTENT(inout) :: Urtot + REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala + REAL(8), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf + REAL(8), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf + REAL(8), INTENT(inout) :: Urtot INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) - REAL(KIND=dp), INTENT(in) :: rel(5, nnbrx*Nmol) + REAL(8), INTENT(in) :: rel(5, nnbrx*Nmol) + REAL(8) :: pi INTEGER :: j, Ki, Kj, l, Nppt3, Nppt6, Nptot - REAL(KIND=dp) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & + REAL(8) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & R2ij, Rij, Rreij, Ua, Ur, Xij, Yij, Zij ! ####################################### @@ -5039,13 +5107,13 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala alrij = alr(Ki, Kj) alaij = ala(Ki, Kj) - Ur = Cr(Ki, Kj)*EXP(-alrij*Rij) - Ua = -Ca(Ki, Kj)*EXP(-alaij*Rij)*X(Ki, Kj) + Ur = Cr(Ki, Kj)*dexp(-alrij*Rij) + Ua = -Ca(Ki, Kj)*dexp(-alaij*Rij)*X(Ki, Kj) R1ij = R1(Ki, Kj) IF (Rij <= R1ij) THEN - XYZRrefdf(Nppt6 + 5) = 1.0_dp - XYZRrefdf(Nppt6 + 6) = 0.0_dp + XYZRrefdf(Nppt6 + 5) = 1.0d0 + XYZRrefdf(Nppt6 + 6) = 0.0d0 Urtot = Urtot + Ur UadUrdf(Nppt3 + 1) = Ua UadUrdf(Nppt3 + 2) = -alrij*Ur @@ -5053,8 +5121,8 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala ELSE PL1 = pi/(R2ij - R1ij) PL2 = PL1*(Rij - R1ij) - fij = 0.5_dp + 0.5_dp*COS(PL2) - dfij = -0.5_dp*PL1*SIN(PL2) + fij = 0.5d0 + 0.5d0*dcos(PL2) + dfij = -0.5d0*PL1*dsin(PL2) XYZRrefdf(Nppt6 + 5) = fij XYZRrefdf(Nppt6 + 6) = dfij Urtot = Urtot + fij*Ur @@ -5090,20 +5158,20 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax, NNmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf - REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf - REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(inout) :: F - REAL(KIND=dp), INTENT(inout) :: Uatot - REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij + REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(8), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf + REAL(8), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf + REAL(8), DIMENSION(1:3*Nmol), INTENT(inout) :: F + REAL(8), INTENT(inout) :: Uatot + REAL(8), DIMENSION(1:3*NNmax) :: dkEij INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) INTEGER :: ij, ijpt3, ijpt6, ik, ikpt6, Ipb, Ipe, & Ipt3, Jpt3, Ki, Kpt3, Nkpt3 - REAL(KIND=dp) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, & - Co_mb2, Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, & - dGi, djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, & - Rreij, Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik + REAL(8) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, Co_mb2, & + Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, dGi, & + djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, Rreij, & + Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -5116,9 +5184,9 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala Co_cdi = Co_bcd(Ki) - dFxi = 0.0_dp - dFyi = 0.0_dp - dFzi = 0.0_dp + dFxi = 0.0d0 + dFyi = 0.0d0 + dFzi = 0.0d0 DO_J: DO ij = Ipb, Ipe, +1 @@ -5132,11 +5200,11 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala fij = XYZRrefdf(IJpt6 + 5) dfij = XYZRrefdf(IJpt6 + 6) - Eij = 0.0_dp - djEij = 0.0_dp - dXjEij2 = 0.0_dp - dYjEij2 = 0.0_dp - dZjEij2 = 0.0_dp + Eij = 0.0d0 + djEij = 0.0d0 + dXjEij2 = 0.0d0 + dYjEij2 = 0.0d0 + dZjEij2 = 0.0d0 Nkpt3 = -3 DO_K: DO ik = Ipb, Ipe, +1 @@ -5157,9 +5225,9 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala COSijk = XRreij*XRreik + YRreij*YRreik + ZRreij*ZRreik Co_hcosi = hi - COSijk - Co_dhcosi = 1.0_dp/(dsqi + Co_hcosi*Co_hcosi) + Co_dhcosi = 1.0d0/(dsqi + Co_hcosi*Co_hcosi) Gi = -bcsqi*Co_dhcosi - dGi = 2.0_dp*Co_hcosi*Co_dhcosi*Gi + dGi = 2.0d0*Co_hcosi*Co_dhcosi*Gi Gi = Gi + Co_cdi Eij = Eij + fik*Gi @@ -5181,22 +5249,22 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala dkEij(Nkpt3 + 3) = Co1_dkEij*ZRreik + Co2_dkEij*ZRreij ELSE - dkEij(Nkpt3 + 1) = 0.0_dp - dkEij(Nkpt3 + 2) = 0.0_dp - dkEij(Nkpt3 + 3) = 0.0_dp + dkEij(Nkpt3 + 1) = 0.0d0 + dkEij(Nkpt3 + 2) = 0.0d0 + dkEij(Nkpt3 + 3) = 0.0d0 END IF IKIJ END DO DO_K - Bij = 1.0_dp + Eij**Pni - Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5_dp/Pni) + Bij = 1.0d0 + Eij**Pni + Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5d0/Pni) Uatot = Uatot + Ua - Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5_dp/Pni) + Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5d0/Pni) CEij: IF (Nkpt3 > 0) THEN - Co_mb1 = Ua*0.5_dp*Eij**(Pni - 1.0_dp)/Bij + Co_mb1 = Ua*0.5d0*Eij**(Pni - 1.0d0)/Bij Co_mb2 = Co_mb1*Rreij Nkpt3 = -3 diff --git a/src/emd/rt_bse.F b/src/emd/rt_bse.F index 74727a6666..c3df81dd4b 100644 --- a/src/emd/rt_bse.F +++ b/src/emd/rt_bse.F @@ -14,7 +14,8 @@ MODULE rt_bse USE bibliography, ONLY: Marek2025, & cite_reference - USE qs_environment_types, ONLY: get_qs_env + USE qs_environment_types, ONLY: get_qs_env, & + qs_environment_type USE force_env_types, ONLY: force_env_type USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type USE cp_fm_types, ONLY: cp_fm_type, & @@ -86,11 +87,10 @@ MODULE rt_bse create_rtbse_env, & release_rtbse_env, & multiply_fm_cfm - USE rt_bse_ri_rs, ONLY: compute_sigma_ri_rs_complex USE rt_bse_io, ONLY: output_moments, & + read_field, & output_field, & output_mos_contravariant, & - read_field, & read_restart, & output_restart, & print_timestep_info, & @@ -117,18 +117,7 @@ MODULE rt_bse PUBLIC :: run_propagation_bse, & get_hartree, & - get_sigma, & - initialize_rtbse_env, & - initialize_singleparticle_hamiltonian, & - initialize_hartree_potential, & - initialize_cohsex_selfenergy, & - get_idempotence_deviation, & - antiherm_metric, & - init_hartree, & - rho_metric, & - propagate_density, & - cp_cfm_gexp, & - get_electron_number + get_sigma INTERFACE get_sigma MODULE PROCEDURE get_sigma_complex, & @@ -145,9 +134,11 @@ CONTAINS ! ************************************************************************************************** !> \brief Runs the electron-only real time BSE propagation +!> \param qs_env Quickstep environment data, containing the config from input files !> \param force_env Force environment data, entry point of the calculation ! ************************************************************************************************** - SUBROUTINE run_propagation_bse(force_env) + SUBROUTINE run_propagation_bse(qs_env, force_env) + TYPE(qs_environment_type), POINTER :: qs_env TYPE(force_env_type), POINTER :: force_env CHARACTER(len=*), PARAMETER :: routineN = 'run_propagation_bse' TYPE(rtbse_env_type), POINTER :: rtbse_env @@ -168,7 +159,7 @@ CONTAINS CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., consistent_energies=.FALSE.) ! Allocate all persistant storage and read input that does not need further processing - CALL create_rtbse_env(rtbse_env, force_env) + CALL create_rtbse_env(rtbse_env, qs_env, force_env) CALL print_rtbse_header_info(rtbse_env) @@ -176,23 +167,15 @@ CONTAINS CALL cp_add_iter_level(logger%iter_info, "MD") ! Initialize non-trivial values ! - calculates the moment operators - CALL initialize_moments(rtbse_env) - ! - populates overlap and inverse overlap matrices - CALL initialize_rtbse_env(rtbse_env) - ! - populates the initial density matrix ! - reads the restart density if requested - CALL initialize_density_matrix(rtbse_env) - ! - reads the moment and field traces from previous runs (no-op if the files are absent) - CALL read_moments(rtbse_env%moments_section, rtbse_env%sim_start_orig, & - rtbse_env%sim_start, rtbse_env%moments_trace, rtbse_env%time_trace) - CALL read_field(rtbse_env) + ! - reads the field and moment trace from previous runs + ! - populates overlap and inverse overlap matrices ! - calculates/populates the G0W0/KS Hamiltonian, respectively - CALL initialize_singleparticle_hamiltonian(rtbse_env) ! - calculates the Hartree reference potential - CALL initialize_hartree_potential(rtbse_env) ! - calculates the COHSEX reference self-energy - CALL initialize_cohsex_selfenergy(rtbse_env) + ! - prints some info about loaded files into the output + CALL initialize_rtbse_env(rtbse_env) ! Setup the time based on the starting step ! Assumes identical dt between two runs @@ -230,7 +213,7 @@ CONTAINS workspace=rtbse_env%rho_workspace, metric=a_metric_2) END DO END IF - CALL print_timestep_info(rtbse_env, i, [enum_re], metric, k) + CALL print_timestep_info(rtbse_env, i, metric, enum_re, k) IF (.NOT. converged) CPABORT("ETRS did not converge") CALL cp_iterate(logger%iter_info, iter_nr=i, last=(i == rtbse_env%sim_nsteps)) DO j = 1, rtbse_env%n_spin @@ -266,45 +249,21 @@ CONTAINS ! ************************************************************************************************** !> \brief Calculates the initial values, based on restart/scf density, and other non-trivial values !> \param rtbse_env RT-BSE environment +!> \param qs_env Quickstep environment (needed for reference to previous calculations) !> \author Stepan Marek (09.24) ! ************************************************************************************************** SUBROUTINE initialize_rtbse_env(rtbse_env) TYPE(rtbse_env_type), POINTER :: rtbse_env CHARACTER(len=*), PARAMETER :: routineN = "initialize_rtbse_env" TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s - INTEGER :: handle - - CALL timeset(routineN, handle) - - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env, matrix_s=matrix_s) - - ! ****** START OVERLAP + INVERSE OVERLAP CALCULATION - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, rtbse_env%S_fm) - CALL cp_fm_to_cfm(msourcer=rtbse_env%S_fm, mtarget=rtbse_env%S_cfm) - CALL cp_fm_invert(rtbse_env%S_fm, rtbse_env%S_inv_fm) - ! ****** END OVERLAP + INVERSE OVERLAP CALCULATION - - CALL timestop(handle) - END SUBROUTINE initialize_rtbse_env - -! ************************************************************************************************** -!> \brief Calculates the moment operators -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_moments(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - CHARACTER(len=*), PARAMETER :: routineN = "initialize_moments" - TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: moments_dbcsr_p - INTEGER :: i, k, handle TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s + REAL(kind=dp), DIMENSION(:), POINTER :: occupations REAL(kind=dp), DIMENSION(3) :: rpoint + INTEGER :: i, k, handle CALL timeset(routineN, handle) + ! Get pointers to parameters from qs_env CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env, matrix_s=matrix_s) @@ -327,20 +286,16 @@ CONTAINS reference=rtbse_env%moment_ref_type, ref_point=rtbse_env%user_moment_ref_point) CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) ! Copy to full matrix - DO i = 1, rtbse_env%n_spin - DO k = 1, 3 - ! AO dipole is spin-independent; replicate into each spin slot - CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments(k, i)) - END DO + DO k = 1, 3 + ! Again, matrices are created from overlap template + CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments(k)) END DO ! Now, repeat without reference point to get the moments for field CALL get_reference_point(rpoint, qs_env=rtbse_env%qs_env, & reference=use_mom_ref_zero) CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) - DO i = 1, rtbse_env%n_spin - DO k = 1, 3 - CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments_field(k, i)) - END DO + DO k = 1, 3 + CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, rtbse_env%moments_field(k)) END DO ! Now can deallocate dbcsr matrices @@ -351,26 +306,6 @@ CONTAINS DEALLOCATE (moments_dbcsr_p) ! ****** END MOMENTS OPERATOR CALCULATION - CALL timestop(handle) - END SUBROUTINE initialize_moments - -! ************************************************************************************************** -!> \brief Calculates the initial density matrix, based on the SCF density or restart density if requested -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_density_matrix(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - CHARACTER(len=*), PARAMETER :: routineN = "initialize_density_matrix" - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(kind=dp), DIMENSION(:), POINTER :: occupations - INTEGER :: i, handle - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) - ! ****** START INITIAL DENSITY MATRIX CALCULATION ! Get the rho from fm_MOS ! Uses real orbitals only - no kpoints @@ -396,25 +331,22 @@ CONTAINS CALL read_restart(rtbse_env) END IF ! ****** END INITIAL DENSITY MATRIX CALCULATION + ! ****** START MOMENTS TRACE LOAD + ! The moments are only loaded if the consistent save files exist + CALL read_moments(rtbse_env%moments_section, rtbse_env%sim_start_orig, & + rtbse_env%sim_start, rtbse_env%moments_trace, rtbse_env%time_trace) + ! ****** END MOMENTS TRACE LOAD - CALL timestop(handle) - END SUBROUTINE initialize_density_matrix + ! ****** START FIELD TRACE LOAD + ! The moments are only loaded if the consistent save files exist + CALL read_field(rtbse_env) + ! ****** END FIELD TRACE LOAD -! ************************************************************************************************** -!> \brief Calculates the single particle Hamiltonian -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_singleparticle_hamiltonian(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - CHARACTER(len=*), PARAMETER :: routineN = "initialize_singleparticle_hamiltonian" - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - INTEGER :: i, handle - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + ! ****** START OVERLAP + INVERSE OVERLAP CALCULATION + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, rtbse_env%S_fm) + CALL cp_fm_to_cfm(msourcer=rtbse_env%S_fm, mtarget=rtbse_env%S_cfm) + CALL cp_fm_invert(rtbse_env%S_fm, rtbse_env%S_inv_fm) + ! ****** END OVERLAP + INVERSE OVERLAP CALCULATION ! ****** START SINGLE PARTICLE HAMILTONIAN CALCULATION DO i = 1, rtbse_env%n_spin @@ -444,28 +376,19 @@ CONTAINS END DO ! ****** END SINGLE PARTICLE HAMILTONIAN CALCULATION - CALL timestop(handle) - END SUBROUTINE initialize_singleparticle_hamiltonian - -! ************************************************************************************************** -!> \brief Calculates the Hartree potential -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_hartree_potential(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - CHARACTER(len=*), PARAMETER :: routineN = "initialize_hartree_potential" - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - INTEGER :: i, handle - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) - ! ****** START HARTREE POTENTIAL REFERENCE CALCULATION ! Calculate Coulomb RI elements, necessary for Hartree calculation CALL init_hartree(rtbse_env, rtbse_env%v_dbcsr) + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ! In a non-HF calculation, copy the actual correlation part of the interaction + CALL copy_fm_to_dbcsr(bs_env%fm_W_MIC_freq_zero, rtbse_env%w_dbcsr) + ELSE + ! In HF, correlation is set to zero + CALL dbcsr_set(rtbse_env%w_dbcsr, 0.0_dp) + END IF + ! Add the Hartree to the screened_dbt tensor - now W = V + W^c + CALL dbcsr_add(rtbse_env%w_dbcsr, rtbse_env%v_dbcsr, 1.0_dp, 1.0_dp) + CALL dbt_copy_matrix_to_tensor(rtbse_env%w_dbcsr, rtbse_env%screened_dbt) ! Calculate the original Hartree potential ! Uses rho_orig - same as rho for initial run but different for continued run DO i = 1, rtbse_env%n_spin @@ -479,60 +402,37 @@ CONTAINS END DO ! ****** END HARTREE POTENTIAL REFERENCE CALCULATION - CALL timestop(handle) - END SUBROUTINE initialize_hartree_potential - -! ************************************************************************************************** -!> \brief Calculates the COHSEX reference self-energy -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_cohsex_selfenergy(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - CHARACTER(len=*), PARAMETER :: routineN = "initialize_cohsex_selfenergy" - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - INTEGER :: i, handle - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) - ! ****** START COHSEX REFERENCE CALCULATION - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! In a non-HF calculation, copy the actual correlation part of the interaction - CALL copy_fm_to_dbcsr(bs_env%fm_W_MIC_freq_zero, rtbse_env%w_dbcsr) - ELSE - ! In HF, correlation is set to zero - CALL dbcsr_set(rtbse_env%w_dbcsr, 0.0_dp) - END IF - ! Add the Hartree to the screened_dbt tensor - now W = V + W^c - CALL dbcsr_add(rtbse_env%w_dbcsr, rtbse_env%v_dbcsr, 1.0_dp, 1.0_dp) - CALL dbt_copy_matrix_to_tensor(rtbse_env%w_dbcsr, rtbse_env%screened_dbt) ! Calculate the COHSEX starting energies - DO i = 1, rtbse_env%n_spin - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! Subtract the v_xc from COH part of the self-energy, as V_xc is also not updated during the timestepping + IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN + ! Subtract the v_xc from COH part of the self-energy, as V_xc is also not updated during the timestepping + DO i = 1, rtbse_env%n_spin ! TODO : Allow no COH calculation for static screening CALL get_sigma(rtbse_env, rtbse_env%sigma_COH(i), -0.5_dp, rtbse_env%S_inv_fm) ! Copy and subtract from the complex reference hamiltonian CALL cp_fm_to_cfm(msourcer=rtbse_env%sigma_COH(i), mtarget=rtbse_env%ham_workspace(1)) CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & CMPLX(-1.0, 0.0, kind=dp), rtbse_env%ham_workspace(1)) - END IF - ! Calculate exchange part - TODO : should this be applied for different spins? - TEST with O2 HF propagation? - ! So far only closed shell tested - ! Uses rho_orig - same as rho for initial run but different for continued run - ! For KS reference this is the time-dependent Fock exchange (w_dbcsr = v only). - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX(i), -1.0_dp, rtbse_env%rho_orig(i)) - ! Subtract from the complex reference Hamiltonian - CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & - CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) - END DO + ! Calculate exchange part - TODO : should this be applied for different spins? - TEST with O2 HF propagation? + ! So far only closed shell tested + ! Uses rho_orig - same as rho for initial run but different for continued run + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX(i), -1.0_dp, rtbse_env%rho_orig(i)) + ! Subtract from the complex reference Hamiltonian + CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & + CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) + END DO + ELSE + ! KS Hamiltonian - use time-dependent Fock exchange + DO i = 1, rtbse_env%n_spin + CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX(i), -1.0_dp, rtbse_env%rho_orig(i)) + CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & + CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) + END DO + END IF ! ****** END COHSEX REFERENCE CALCULATION CALL timestop(handle) - END SUBROUTINE initialize_cohsex_selfenergy + END SUBROUTINE initialize_rtbse_env ! ************************************************************************************************** !> \brief Custom reimplementation of the delta pulse routines @@ -560,7 +460,7 @@ CONTAINS CALL cp_fm_set_all(rtbse_env%real_workspace(1), 0.0_dp) DO k = 1, 3 CALL cp_fm_scale_and_add(1.0_dp, rtbse_env%real_workspace(1), & - kvec(k), rtbse_env%moments_field(k, 1)) + kvec(k), rtbse_env%moments_field(k)) END DO ! enforce hermiticity of the effective Hamiltonian CALL cp_fm_transpose(rtbse_env%real_workspace(1), rtbse_env%real_workspace(2)) @@ -732,12 +632,12 @@ CONTAINS DO j = 1, nspin DO k = 1, 3 ! Minus sign due to charge of electrons - CALL cp_fm_to_cfm(msourcer=rtbse_env%moments_field(k, 1), mtarget=rtbse_env%ham_workspace(1)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%moments_field(k), mtarget=rtbse_env%ham_workspace(1)) CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_effective(j), & CMPLX(rtbse_env%field(k), 0.0, kind=dp), rtbse_env%ham_workspace(1)) END DO IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! Add the COH part - so far static but can be dynamic in principle through the W updates + ! Add the COH part - so far static but can be dynamic in principle throught the W updates CALL get_sigma(rtbse_env, rtbse_env%sigma_COH(j), -0.5_dp, rtbse_env%S_inv_fm) CALL cp_fm_to_cfm(msourcer=rtbse_env%sigma_COH(j), mtarget=rtbse_env%ham_workspace(1)) CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_effective(j), & @@ -954,7 +854,7 @@ CONTAINS CMPLX(1.0, 0.0, kind=dp), exponential(j), rtbse_env%rho_workspace(1), & CMPLX(0.0, 0.0, kind=dp), rho_new(j)) END DO - ELSE IF (rtbse_env%mat_exp_method == do_bch .OR. rtbse_env%linearized) THEN + ELSE IF (rtbse_env%mat_exp_method == do_bch) THEN ! Same number of iterations as ETRS CALL bch_propagate(exponential, rho_old, rho_new, rtbse_env%rho_workspace, threshold_opt=rtbse_env%exp_accuracy, & max_iter_opt=rtbse_env%etrs_max_iter) @@ -1038,48 +938,32 @@ CONTAINS !> \note Can be used for both the Coulomb hole part and screened exchange part !> \param rtbse_env Quickstep environment data, entry point of the calculation !> \param sigma_cfm Pointer to the self-energy full matrix, which is overwritten by this routine -!> \param prefactor_opt Optional scaling factor applied to the contraction, defaults to 1.0 !> \param greens_cfm Pointer to the Green's function matrix, which is used as input data -!> \param grid_diag_re_accum Optional accumulator for the real part of the RI-RS grid diagonal -!> \param grid_diag_im_accum Optional accumulator for the imaginary part of the RI-RS grid diagonal !> \author Stepan Marek !> \date 09.2024 ! ************************************************************************************************** - SUBROUTINE get_sigma_complex(rtbse_env, sigma_cfm, prefactor_opt, greens_cfm, & - grid_diag_re_accum, grid_diag_im_accum) + SUBROUTINE get_sigma_complex(rtbse_env, sigma_cfm, prefactor_opt, greens_cfm) TYPE(rtbse_env_type), POINTER :: rtbse_env TYPE(cp_cfm_type) :: sigma_cfm ! resulting self energy REAL(kind=dp), INTENT(IN), OPTIONAL :: prefactor_opt TYPE(cp_cfm_type), INTENT(IN) :: greens_cfm ! matrix to contract with RI_W - REAL(kind=dp), INTENT(INOUT), OPTIONAL :: grid_diag_re_accum(:), grid_diag_im_accum(:) REAL(kind=dp) :: prefactor prefactor = 1.0_dp IF (PRESENT(prefactor_opt)) prefactor = prefactor_opt - ! RI-RS screened-exchange backend (linRTBSE only; rirs_kernel is forced .FALSE. for full RTBSE, - ! so this is inert there). The RI-RS routine does its own Re/Im split, replacing the AO-RI body. - ! The optional grid_diag_* accumulators harvest diag(φρφ^T) for the Hartree reuse (RI-RS only; - ! absent on AO-RI calls, which build no grid). - IF (rtbse_env%rirs_kernel) THEN - CALL compute_sigma_ri_rs_complex(rtbse_env%bs_env, sigma_cfm, prefactor, greens_cfm, & - grid_diag_re_accum=grid_diag_re_accum, & - grid_diag_im_accum=grid_diag_im_accum) - RETURN - END IF - ! Carry out the sigma part twice ! Real part CALL cp_cfm_to_fm(msource=greens_cfm, mtargetr=rtbse_env%real_workspace(1)) CALL get_sigma(rtbse_env, rtbse_env%real_workspace(2), prefactor, rtbse_env%real_workspace(1)) - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(2), mtarget=rtbse_env%sigma_complex_workspace(1)) + CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(2), mtarget=rtbse_env%ham_workspace(1)) ! Imaginary part CALL cp_cfm_to_fm(msource=greens_cfm, mtargeti=rtbse_env%real_workspace(1)) CALL get_sigma(rtbse_env, rtbse_env%real_workspace(2), prefactor, rtbse_env%real_workspace(1)) CALL cp_fm_to_cfm(msourcei=rtbse_env%real_workspace(2), mtarget=sigma_cfm) ! Add the real part CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), sigma_cfm, & - CMPLX(1.0, 0.0, kind=dp), rtbse_env%sigma_complex_workspace(1)) + CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_workspace(1)) END SUBROUTINE get_sigma_complex ! ************************************************************************************************** @@ -1097,25 +981,15 @@ CONTAINS REAL(kind=dp), INTENT(IN), OPTIONAL :: prefactor_opt TYPE(cp_fm_type), INTENT(IN) :: greens_fm ! matrix to contract with RI_W REAL(kind=dp) :: prefactor - TYPE(dbcsr_type) :: greens_dbcsr_scratch - TYPE(post_scf_bandstructure_type), POINTER :: bs_env prefactor = 1.0_dp IF (PRESENT(prefactor_opt)) prefactor = prefactor_opt - ! Local AO-AO dbcsr scratch for the FM->DBCSR conversion. Previously this - ! routine used rtbse_env%rho_dbcsr as the workspace, which coupled AO-RI SX - ! to the AO-RI Hartree allocation path - the historical (RIRS-H + AO-RI-SX) - ! cross-combo (no longer expressible under the single KERNEL_RI switch) - ! then segfaulted because rho_dbcsr is skipped when rirs_kernel=T. - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) - CALL dbcsr_create(greens_dbcsr_scratch, name="get_sigma greens scratch", & - template=bs_env%mat_ao_ao%matrix) + ! Carry out the sigma part twice + ! Convert to dbcsr + CALL copy_fm_to_dbcsr(greens_fm, rtbse_env%rho_dbcsr) + CALL get_sigma_dbcsr(rtbse_env, sigma_fm, prefactor, rtbse_env%rho_dbcsr) - CALL copy_fm_to_dbcsr(greens_fm, greens_dbcsr_scratch) - CALL get_sigma_dbcsr(rtbse_env, sigma_fm, prefactor, greens_dbcsr_scratch) - - CALL dbcsr_release(greens_dbcsr_scratch) END SUBROUTINE get_sigma_real ! ************************************************************************************************** !> \brief Calculates the self-energy by contraction of screened potential diff --git a/src/emd/rt_bse_io.F b/src/emd/rt_bse_io.F index b939c76126..a41f6b968e 100644 --- a/src/emd/rt_bse_io.F +++ b/src/emd/rt_bse_io.F @@ -40,11 +40,8 @@ MODULE rt_bse_io do_bch, & rtp_bse_ham_g0w0, & rtp_bse_ham_ks, & - use_rt_restart, & - restart_guess - USE qs_environment_types, ONLY: get_qs_env - USE scf_control_types, ONLY: scf_control_type - USE physcon, ONLY: evolt, femtoseconds + use_rt_restart + USE physcon, ONLY: femtoseconds USE rt_propagation_output, ONLY: print_moments, & print_rt_file, & rt_file_comp_real @@ -57,9 +54,6 @@ MODULE rt_bse_io CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = "rt_bse_io" - ! RESTART.trace on-disk format version - bump whenever the header or record layout changes - INTEGER, PARAMETER, PRIVATE :: restart_trace_version = 1 - #:include "rt_bse_macros.fypp" PUBLIC :: output_moments, & @@ -69,12 +63,6 @@ MODULE rt_bse_io output_mos_covariant, & output_restart, & read_restart, & - output_restart_linearized, & - read_restart_info, & - read_restart_trace, & - read_restart_density, & - read_restart_C, & - check_restart_eps_consistency, & print_etrs_info_header, & print_etrs_info, & print_timestep_info, & @@ -164,87 +152,24 @@ CONTAINS END SUBROUTINE print_etrs_info_header ! ************************************************************************************************** -!> \brief Writes the summary line of a completed propagation timestep +!> \brief Writes the header for the etrs iteration updates - only for log level > low !> \param rtbse_env Entry point - rtbse environment -!> \param step Index of the completed timestep -!> \param electron_num_re Real part of the electron number, one entry per spin channel -!> \param convergence Optional convergence metric reached by the ETRS iteration -!> \param etrs_num Optional number of ETRS iterations used in this timestep -!> \param step_walltime Optional wall time of this timestep, in seconds ! ************************************************************************************************** - SUBROUTINE print_timestep_info(rtbse_env, step, electron_num_re, convergence, etrs_num, & - step_walltime) + SUBROUTINE print_timestep_info(rtbse_env, step, convergence, electron_num_re, etrs_num) TYPE(rtbse_env_type) :: rtbse_env INTEGER :: step - REAL(kind=dp), DIMENSION(:), INTENT(IN) :: electron_num_re - REAL(kind=dp), OPTIONAL :: convergence - INTEGER, OPTIONAL :: etrs_num - REAL(kind=dp), OPTIONAL :: step_walltime + REAL(kind=dp) :: convergence + REAL(kind=dp) :: electron_num_re + INTEGER :: etrs_num TYPE(cp_logger_type), POINTER :: logger - LOGICAL :: flag_lrrtbse - INTEGER :: nch logger => cp_get_default_logger() - ! one electron-number column per spin channel (1 = closed shell, 2 = open shell alpha/beta) - nch = SIZE(electron_num_re) - - IF (.NOT. PRESENT(convergence) .OR. .NOT. PRESENT(etrs_num)) THEN - flag_lrrtbse = .TRUE. - ELSE - flag_lrrtbse = .FALSE. - END IF IF (logger%iter_info%print_level > low_print_level .AND. rtbse_env%unit_nr > 0) THEN - IF (flag_lrrtbse) THEN - IF (step == 0) THEN - IF (PRESENT(step_walltime)) THEN - WRITE (rtbse_env%unit_nr, '(A45,T70,F11.3)') & - " RTBSE| Estimated runtime for propagation [s]", & - step_walltime*REAL(rtbse_env%sim_nsteps, dp) - WRITE (rtbse_env%unit_nr, '(A)') & - " RTBSE|" - IF (nch == 1) THEN - WRITE (rtbse_env%unit_nr, '(A23,T27,A13,T66,A15)') & - " RTBSE| Simulation step", "Step time [s]", "Electron number" - ELSE - ! T67/T88 (not T66/T86): each α/β is 2 bytes but 1 display col, so the byte - ! anchor is +1 per unicode char to right-align ')' under the value's last digit. - ! T anchors carry +1 byte per α/β before the ')' (α col → +1, β col → +2), - ! since each is 2 bytes but 1 display col; right-aligns ')' on the last digit. - WRITE (rtbse_env%unit_nr, '(A23,T27,A13,T47,A15,T68,A15)') & - " RTBSE| Simulation step", "Step time [s]", "El. number (α)", "El. number (β)" - END IF - ELSE - IF (nch == 1) THEN - WRITE (rtbse_env%unit_nr, '(A23,T66,A15)') " RTBSE| Simulation step", "Electron number" - ELSE - WRITE (rtbse_env%unit_nr, '(A23,T47,A15,T68,A15)') & - " RTBSE| Simulation step", "El. number (α)", "El. number (β)" - END IF - END IF - END IF - IF (PRESENT(step_walltime)) THEN - IF (nch == 1) THEN - WRITE (rtbse_env%unit_nr, '(A7,I16,T30,F10.3,T69,E12.3E3)') & - ' RTBSE|', step, step_walltime, electron_num_re(1) - ELSE - WRITE (rtbse_env%unit_nr, '(A7,I16,T30,F10.3,T49,E12.3E3,T69,E12.3E3)') & - ' RTBSE|', step, step_walltime, electron_num_re(1), electron_num_re(2) - END IF - ELSE - IF (nch == 1) THEN - WRITE (rtbse_env%unit_nr, '(A7,I16,T61,E20.8E3)') ' RTBSE|', step, electron_num_re(1) - ELSE - WRITE (rtbse_env%unit_nr, '(A7,I16,T49,E12.3E3,T69,E12.3E3)') & - ' RTBSE|', step, electron_num_re(1), electron_num_re(2) - END IF - END IF - ELSE - WRITE (rtbse_env%unit_nr, '(A23,A20,A20,A17)') " RTBSE| Simulation step", "Convergence", & - "Electron number", "ETRS Iterations" - WRITE (rtbse_env%unit_nr, '(A7,I16,E20.8E3,E20.8E3,I17)') ' RTBSE|', step, convergence, & - electron_num_re(1), etrs_num - END IF + WRITE (rtbse_env%unit_nr, '(A23,A20,A20,A17)') " RTBSE| Simulation step", "Convergence", & + "Electron number", "ETRS Iterations" + WRITE (rtbse_env%unit_nr, '(A7,I16,E20.8E3,E20.8E3,I17)') ' RTBSE|', step, convergence, & + electron_num_re, etrs_num END IF END SUBROUTINE print_timestep_info @@ -269,22 +194,6 @@ CONTAINS file_labels(3) = "_SPIN_B_RE.dat" file_labels(4) = "_SPIN_B_IM.dat" logger => cp_get_default_logger() - - ! In the linearized RT-BSE active-MO path, rho is already in the MO basis - ! restricted to the active window (sized mo_active x mo_active). Dump it - ! directly without the AO-side C^T S * rho * S C transformation. - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - DO j = 1, rtbse_env%n_spin - rho_unit_re = cp_print_key_unit_nr(logger, print_key_section, extension=file_labels(2*j - 1)) - rho_unit_im = cp_print_key_unit_nr(logger, print_key_section, extension=file_labels(2*j)) - CALL cp_cfm_to_fm(rho(j), rtbse_env%real_workspace_mo(1), rtbse_env%real_workspace_mo(2)) - CALL cp_fm_write_formatted(rtbse_env%real_workspace_mo(1), rho_unit_re) - CALL cp_fm_write_formatted(rtbse_env%real_workspace_mo(2), rho_unit_im) - CALL cp_print_key_finished_output(rho_unit_re, logger, print_key_section) - CALL cp_print_key_finished_output(rho_unit_im, logger, print_key_section) - END DO - RETURN - END IF ! Start by multiplying the current density by MOS DO j = 1, rtbse_env%n_spin rho_unit_re = cp_print_key_unit_nr(logger, print_key_section, extension=file_labels(2*j - 1)) @@ -448,33 +357,25 @@ CONTAINS TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho INTEGER :: i, j, n REAL(kind=dp), DIMENSION(3) :: moments_re - TYPE(cp_fm_type), DIMENSION(:), POINTER :: ws n = rtbse_env%sim_step - rtbse_env%sim_start_orig + 1 - ! In linearized RT-BSE rho and moments are MO-active sized; otherwise AO sized. - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - ws => rtbse_env%real_workspace_mo - ELSE - ws => rtbse_env%real_workspace - END IF - DO j = 1, rtbse_env%n_spin ! Need to transpose due to the definition of trace function - CALL cp_cfm_to_fm(msource=rho(j), mtargetr=ws(2)) + CALL cp_cfm_to_fm(msource=rho(j), mtargetr=rtbse_env%real_workspace(2)) DO i = 1, 3 ! Moments should be symmetric, test without transopose? - CALL cp_fm_transpose(rtbse_env%moments(i, j), ws(1)) - CALL cp_fm_trace(ws(1), ws(2), moments_re(i)) + CALL cp_fm_transpose(rtbse_env%moments(i), rtbse_env%real_workspace(1)) + CALL cp_fm_trace(rtbse_env%real_workspace(1), rtbse_env%real_workspace(2), moments_re(i)) ! Scale by spin degeneracy and electron charge moments_re(i) = -moments_re(i)*rtbse_env%spin_degeneracy rtbse_env%moments_trace(j, i, n) = CMPLX(moments_re(i), 0.0, kind=dp) END DO ! Same for imaginary part - CALL cp_cfm_to_fm(msource=rho(j), mtargeti=ws(2)) + CALL cp_cfm_to_fm(msource=rho(j), mtargeti=rtbse_env%real_workspace(2)) DO i = 1, 3 - CALL cp_fm_transpose(rtbse_env%moments(i, j), ws(1)) - CALL cp_fm_trace(ws(1), ws(2), moments_re(i)) + CALL cp_fm_transpose(rtbse_env%moments(i), rtbse_env%real_workspace(1)) + CALL cp_fm_trace(rtbse_env%real_workspace(1), rtbse_env%real_workspace(2), moments_re(i)) ! Scale by spin degeneracy and electron charge moments_re(i) = -moments_re(i)*rtbse_env%spin_degeneracy rtbse_env%moments_trace(j, i, n) = rtbse_env%moments_trace(j, i, n) + CMPLX(0.0, moments_re(i), kind=dp) @@ -585,392 +486,4 @@ CONTAINS END IF END DO END SUBROUTINE read_restart -! ************************************************************************************************** -!> \brief Linearized RT-BSE restart writer. Writes the restart set: lab-frame MO-active density -!> matrices, the .info step index (sim_step = steps completed = the resume step), the -!> once-per-run C_active gauge reference, and the appended RESTART.trace record feeding the -!> FT prefix on continuation. All indices derive from sim_step so the .info/.trace -!> bookkeeping cannot drift apart. (Full RTBSE uses the upstream output_restart above.) -!> \param rtbse_env RT-BSE environment -!> \param rho Density matrix (lab frame) to store -! ************************************************************************************************** - SUBROUTINE output_restart_linearized(rtbse_env, rho) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho - TYPE(cp_fm_type), DIMENSION(:), POINTER :: workspace - CHARACTER(len=17), DIMENSION(4) :: file_labels - CHARACTER(len=16), DIMENSION(2) :: c_file_labels - TYPE(cp_logger_type), POINTER :: logger - INTEGER :: rho_unit_nr, i - - ! Default labels distinguishing up to two spin species and real/imaginary parts - file_labels(1) = "_SPIN_A_RE.matrix" - file_labels(2) = "_SPIN_A_IM.matrix" - file_labels(3) = "_SPIN_B_RE.matrix" - file_labels(4) = "_SPIN_B_IM.matrix" - c_file_labels(1) = "_SPIN_A_C.matrix" - c_file_labels(2) = "_SPIN_B_C.matrix" - - logger => cp_get_default_logger() - - ! In linearized RT-BSE rho is MO-active sized; otherwise AO sized. - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - workspace => rtbse_env%real_workspace_mo - ELSE - workspace => rtbse_env%real_workspace - END IF - - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_to_fm(rho(i), workspace(1), workspace(2)) - ! Real part - rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=file_labels(2*i - 1), & - file_form="UNFORMATTED", file_position="REWIND") - CALL cp_fm_write_unformatted(workspace(1), rho_unit_nr) - CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) - ! Imag part - rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=file_labels(2*i), & - file_form="UNFORMATTED", file_position="REWIND") - CALL cp_fm_write_unformatted(workspace(2), rho_unit_nr) - CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) - ! Info - rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=".info", & - file_form="UNFORMATTED", file_position="REWIND") - IF (rho_unit_nr > 0) WRITE (rho_unit_nr) rtbse_env%sim_step - CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) - END DO - - ! Once-per-run C_active dump (linearized only): gauge reference for the restart basis bridge - IF (ASSOCIATED(rtbse_env%real_workspace_mo) .AND. .NOT. rtbse_env%restart_C_written) THEN - DO i = 1, rtbse_env%n_spin - rho_unit_nr = cp_print_key_unit_nr(logger, rtbse_env%restart_section, extension=c_file_labels(i), & - file_form="UNFORMATTED", file_position="REWIND") - CALL cp_fm_write_unformatted(rtbse_env%C_active(i), rho_unit_nr) - CALL cp_print_key_finished_output(rho_unit_nr, logger, rtbse_env%restart_section) - END DO - rtbse_env%restart_C_written = .TRUE. - END IF - - CALL write_restart_trace(rtbse_env) - END SUBROUTINE output_restart_linearized -! ************************************************************************************************** -!> \brief Appends the current observable-trace record to RESTART.trace. Records are keyed by the -!> observable slot n_slot = sim_step - sim_start_orig + 1 - the SAME index output_moments/ -!> output_field write (both drivers bump sim_step inside the propagation call before the -!> output calls run). On the first call of a run the file is rewritten from memory (header + -!> records 1..n_slot), truncating leftovers from an aborted run; subsequent calls append one -!> record. Ionode writes; layout matches read_restart_trace verbatim. -!> \param rtbse_env RT-BSE environment -! ************************************************************************************************** - SUBROUTINE write_restart_trace(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_logger_type), POINTER :: logger - CHARACTER(len=default_path_length) :: save_name - INTEGER :: trace_unit, n, n_eps, n_slot - - logger => cp_get_default_logger() - save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".trace", my_local=.FALSE.) - - IF (rtbse_env%unit_nr > 0) THEN - n_slot = rtbse_env%sim_step - rtbse_env%sim_start_orig + 1 - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - ! scalar row count is safe: determine_active_mo_window takes the union window across - ! spins, so eps_active is rectangular (mo_active, n_spin) by construction - n_eps = SIZE(rtbse_env%eps_active, 1) - ELSE - n_eps = 0 - END IF - IF (.NOT. rtbse_env%restart_trace_written) THEN - CALL open_file(save_name, file_status="UNKNOWN", file_form="UNFORMATTED", file_action="WRITE", & - file_position="REWIND", unit_number=trace_unit) - WRITE (trace_unit) restart_trace_version - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - WRITE (trace_unit) rtbse_env%n_spin, rtbse_env%mo_active, rtbse_env%n_ao - ELSE - WRITE (trace_unit) rtbse_env%n_spin, rtbse_env%n_ao, rtbse_env%n_ao - END IF - WRITE (trace_unit) rtbse_env%sim_dt - WRITE (trace_unit) REAL(rtbse_env%dft_control%rtp_control%delta_pulse_direction, dp), & - rtbse_env%dft_control%rtp_control%delta_pulse_scale - WRITE (trace_unit) n_eps - IF (n_eps > 0) WRITE (trace_unit) rtbse_env%eps_active - DO n = 1, n_slot - WRITE (trace_unit) n, rtbse_env%time_trace(n), rtbse_env%field_trace(:, n), & - rtbse_env%moments_trace(:, :, n) - END DO - ELSE - CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="WRITE", & - file_position="APPEND", unit_number=trace_unit) - WRITE (trace_unit) n_slot, rtbse_env%time_trace(n_slot), rtbse_env%field_trace(:, n_slot), & - rtbse_env%moments_trace(:, :, n_slot) - END IF - CALL close_file(trace_unit) - END IF - rtbse_env%restart_trace_written = .TRUE. - END SUBROUTINE write_restart_trace -! ************************************************************************************************** -!> \brief Early phase of the restart read: the starting step index from the .info file, the original -!> run's dt peeked from the RESTART.trace header (so ENFORCE_MAX_DT can inherit it), and an -!> SCF_GUESS hygiene check. Runs BEFORE initialize_maximum_timestep; the trace prefix records -!> are loaded separately by read_restart_trace once the trace arrays are sized. -!> \param rtbse_env RT-BSE environment -! ************************************************************************************************** - SUBROUTINE read_restart_info(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_logger_type), POINTER :: logger - CHARACTER(len=default_path_length) :: save_name - INTEGER :: info_unit, trace_unit, version - TYPE(scf_control_type), POINTER :: scf_control - - logger => cp_get_default_logger() - - save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".info", my_local=.FALSE.) - IF (file_exists(save_name)) THEN - CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & - unit_number=info_unit) - READ (info_unit) rtbse_env%sim_start - CALL close_file(info_unit) - IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A31,I25,A24)') " RTBSE| Starting from timestep ", & - rtbse_env%sim_start, ", delta kick NOT applied" - ELSE - CPWARN("Restart required but no info file found - starting from sim_step given in input") - END IF - - ! Peek the original run's dt from the trace header (version, dims record, dt) so ENFORCE_MAX_DT - ! can inherit it rather than recompute a window-dependent dt. The dims record is skipped here; - ! read_restart_trace re-reads the full header and validates it once the trace arrays are sized. - save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".trace", my_local=.FALSE.) - IF (file_exists(save_name)) THEN - CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & - unit_number=trace_unit) - READ (trace_unit) version - IF (version == restart_trace_version) THEN - READ (trace_unit) - READ (trace_unit) rtbse_env%sim_dt_restart - END IF - CALL close_file(trace_unit) - END IF - - ! Hygiene nudge only - correctness is protected by the restart basis bridge (linearized path) - NULLIFY (scf_control) - CALL get_qs_env(rtbse_env%qs_env, scf_control=scf_control) - IF (scf_control%density_guess /= restart_guess) THEN - CPWARN("RT_RESTART without SCF_GUESS RESTART - SCF may reconverge to a gauge-rotated MO basis.") - END IF - END SUBROUTINE read_restart_info -! ************************************************************************************************** -!> \brief Reads the RESTART.trace prefix (records 1..sim_start) into the in-memory moment/field/ -!> time traces so the continuation FT covers the full history. Header guards: version, -!> n_spin, dims, dt (abort); kick params (warn); eps_active > 0.1 meV (warn). All ranks read -!> (the traces are replicated). Record layout matches write_restart_trace verbatim. -!> \param rtbse_env RT-BSE environment -! ************************************************************************************************** - SUBROUTINE read_restart_trace(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_logger_type), POINTER :: logger - CHARACTER(len=default_path_length) :: save_name, err_msg - INTEGER :: trace_unit, version, n_spin_file, & - n_basis_file, n_ao_file, n_eps, n, & - n_read_max, ios - REAL(kind=dp) :: dt_file, kick_scale_file, t_rec - REAL(kind=dp), DIMENSION(3) :: kick_dir_file - REAL(kind=dp), DIMENSION(:, :), ALLOCATABLE :: eps_file - COMPLEX(kind=dp), DIMENSION(3) :: field_rec - COMPLEX(kind=dp), DIMENSION(:, :), ALLOCATABLE :: mom_rec - - logger => cp_get_default_logger() - save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, extension=".trace", my_local=.FALSE.) - ! No trace + real prior history: the FT would run on a zero prefix - either a guaranteed - ! multi_fft abort AFTER the full propagation (default FT%START_TIME=0, delta_t=0) or a - ! silently wrong tail-only spectrum (START_TIME>0). Fail fast instead. - IF (.NOT. file_exists(save_name)) THEN - IF (rtbse_env%sim_start > 0) THEN - CALL cp_abort(__LOCATION__, & - "RT_RESTART without RESTART.trace - the continuation FT would miss the pre-restart "// & - "history. Restore the original run's RESTART.trace next to the density restart files.") - END IF - RETURN - END IF - - CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & - unit_number=trace_unit) - READ (trace_unit) version - IF (version /= restart_trace_version) THEN - WRITE (err_msg, '(A,I0,A,I0)') "RESTART.trace: format version ", version, & - " does not match this binary's version ", restart_trace_version - CALL cp_abort(__LOCATION__, TRIM(err_msg)) - END IF - READ (trace_unit) n_spin_file, n_basis_file, n_ao_file - IF (n_spin_file /= rtbse_env%n_spin) CPABORT("RESTART.trace: n_spin mismatch") - IF (n_ao_file /= rtbse_env%n_ao) CPABORT("RESTART.trace: n_ao mismatch") - ! v1 is strict same-window: the linearized active-MO count must match (D6) - IF (ASSOCIATED(rtbse_env%real_workspace_mo) .AND. n_basis_file /= rtbse_env%mo_active) THEN - CALL cp_abort(__LOCATION__, & - "RESTART.trace: active-MO count differs from the original run - same-window continuation only") - END IF - READ (trace_unit) dt_file - ! ENFORCE_MAX_DT inherits dt_file (read_restart_info -> initialize_maximum_timestep), so this - ! fires only on the manual path (ENFORCE off + user dt /= original); name the exact fix. - IF (ABS(dt_file - rtbse_env%sim_dt) > 1.0e-12_dp*MAX(1.0_dp, ABS(rtbse_env%sim_dt))) THEN - WRITE (err_msg, '(A,ES16.9,A)') & - "RESTART.trace: TIMESTEP differs from the original run - continuation undefined. "// & - "Set MD%TIMESTEP [fs] ", dt_file*femtoseconds, & - " or enable RTBSE%ENFORCE_MAX_DT to inherit it automatically." - CALL cp_abort(__LOCATION__, TRIM(err_msg)) - END IF - READ (trace_unit) kick_dir_file, kick_scale_file - IF (MAXVAL(ABS(kick_dir_file - REAL(rtbse_env%dft_control%rtp_control%delta_pulse_direction, dp))) > 1.0e-12_dp .OR. & - ABS(kick_scale_file - rtbse_env%dft_control%rtp_control%delta_pulse_scale) > 1.0e-12_dp) THEN - CALL cp_warn(__LOCATION__, & - "RESTART.trace: delta-kick parameters differ from the original run - FT normalization inconsistent.") - END IF - READ (trace_unit) n_eps - IF (n_eps > 0) THEN - ALLOCATE (eps_file(n_eps, rtbse_env%n_spin)) - READ (trace_unit) eps_file - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - IF (n_eps /= SIZE(rtbse_env%eps_active, 1)) THEN - CALL cp_abort(__LOCATION__, "RESTART.trace: active-window size mismatch") - END IF - ! eps_active is not populated yet (built later in the Hamiltonian init); stash for the - ! post-Hamiltonian consistency check in check_restart_eps_consistency. - ALLOCATE (rtbse_env%eps_active_restart(n_eps, rtbse_env%n_spin)) - rtbse_env%eps_active_restart(:, :) = eps_file - END IF - DEALLOCATE (eps_file) - END IF - - ALLOCATE (mom_rec(rtbse_env%n_spin, 3)) - n_read_max = 0 - DO - READ (trace_unit, IOSTAT=ios) n, t_rec, field_rec, mom_rec - IF (ios /= 0) EXIT - ! Fill through slot sim_start+1: both drivers bump sim_step inside the propagation call - ! (etrs_scf_loop / solve_rk4_timestep), so the live loop's first step writes slot - ! sim_start+2 and slot sim_start+1 must be reloaded here. - IF (n > rtbse_env%sim_start + 1) EXIT - IF (n > SIZE(rtbse_env%time_trace)) THEN - CPABORT("RESTART.trace: record index exceeds trace size - increase MOTION%MD%STEPS") - END IF - rtbse_env%time_trace(n) = t_rec - rtbse_env%field_trace(:, n) = field_rec - rtbse_env%moments_trace(:, :, n) = mom_rec - n_read_max = MAX(n_read_max, n) - END DO - DEALLOCATE (mom_rec) - CALL close_file(trace_unit) - IF (n_read_max < rtbse_env%sim_start) THEN - CPWARN("RESTART.trace: fewer records than restart step - trace prefix incomplete.") - END IF - END SUBROUTINE read_restart_trace -! ************************************************************************************************** -!> \brief Compares the original run's active eigenvalues (stashed by read_restart_trace) against -!> the recomputed eps_active, once the Hamiltonian is built. Prints the max deviation and -!> warns above 0.1 meV (GW analytic continuation gives run-to-run QP noise above FP, so the -!> threshold is deliberately loose). Frees the stash. No-op if nothing was stashed. -!> \param rtbse_env RT-BSE environment -! ************************************************************************************************** - SUBROUTINE check_restart_eps_consistency(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - REAL(kind=dp) :: eps_dev - - IF (.NOT. ASSOCIATED(rtbse_env%eps_active_restart)) RETURN - - eps_dev = MAXVAL(ABS(rtbse_env%eps_active_restart - rtbse_env%eps_active)) - IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') & - " RTBSE| Restart eps_active max deviation vs original run ", eps_dev, " Ha" - ! 0.1 meV = 1.0e-4 eV, converted to Ha via evolt (Ha -> eV factor) - IF (eps_dev > 1.0e-4_dp/evolt) THEN - CALL cp_warn(__LOCATION__, & - "RESTART.trace: active eigenvalues deviate beyond 0.1 meV - "// & - "Hamiltonian changed; continuation is physically inconsistent.") - END IF - - DEALLOCATE (rtbse_env%eps_active_restart) - NULLIFY (rtbse_env%eps_active_restart) - END SUBROUTINE check_restart_eps_consistency -! ************************************************************************************************** -!> \brief Late phase of the restart read: overwrites rho from the lab-frame restart matrices and -!> sets restart_extracted. MO-active for the linearized path, AO otherwise -!> (cp_fm_read_unformatted aborts on a size mismatch, guarding a changed active window). -!> \param rtbse_env RT-BSE environment -! ************************************************************************************************** - SUBROUTINE read_restart_density(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_logger_type), POINTER :: logger - CHARACTER(len=default_path_length) :: save_name, save_name_2 - INTEGER :: rho_unit_nr, j - CHARACTER(len=17), DIMENSION(4) :: file_labels - TYPE(cp_fm_type), DIMENSION(:), POINTER :: ws - - ! This allows the delta kick and output of moment at time 0 in all cases - ! except the case when both imaginary and real parts of the density are read - rtbse_env%restart_extracted = .FALSE. - logger => cp_get_default_logger() - - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) THEN - ws => rtbse_env%real_workspace_mo - ELSE - ws => rtbse_env%real_workspace - END IF - - ! Default labels distinguishing up to two spin species and real/imaginary parts - file_labels(1) = "_SPIN_A_RE.matrix" - file_labels(2) = "_SPIN_A_IM.matrix" - file_labels(3) = "_SPIN_B_RE.matrix" - file_labels(4) = "_SPIN_B_IM.matrix" - DO j = 1, rtbse_env%n_spin - save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, & - extension=file_labels(2*j - 1), my_local=.FALSE.) - save_name_2 = cp_print_key_generate_filename(logger, rtbse_env%restart_section, & - extension=file_labels(2*j), my_local=.FALSE.) - IF (file_exists(save_name) .AND. file_exists(save_name_2)) THEN - CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & - unit_number=rho_unit_nr) - CALL cp_fm_read_unformatted(ws(1), rho_unit_nr) - CALL close_file(rho_unit_nr) - CALL open_file(save_name_2, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & - unit_number=rho_unit_nr) - CALL cp_fm_read_unformatted(ws(2), rho_unit_nr) - CALL close_file(rho_unit_nr) - CALL cp_fm_to_cfm(ws(1), ws(2), & - rtbse_env%rho(j)) - rtbse_env%restart_extracted = .TRUE. - ELSE - CPWARN("Restart without some restart matrices - starting from SCF density.") - END IF - END DO - END SUBROUTINE read_restart_density -! ************************************************************************************************** -!> \brief Reads the previous run's C_active slabs (gauge reference for the restart basis bridge). -!> \param rtbse_env RT-BSE environment -!> \param C_old Caller-created fm array (n_spin) on fm_struct_ao_mo_active, filled on success -!> \param found .TRUE. iff all per-spin C files were present and read -! ************************************************************************************************** - SUBROUTINE read_restart_C(rtbse_env, C_old, found) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_fm_type), DIMENSION(:), POINTER :: C_old - LOGICAL, INTENT(OUT) :: found - TYPE(cp_logger_type), POINTER :: logger - CHARACTER(len=default_path_length) :: save_name - CHARACTER(len=16), DIMENSION(2) :: c_file_labels - INTEGER :: c_unit, j - - c_file_labels(1) = "_SPIN_A_C.matrix" - c_file_labels(2) = "_SPIN_B_C.matrix" - logger => cp_get_default_logger() - found = .FALSE. - DO j = 1, rtbse_env%n_spin - save_name = cp_print_key_generate_filename(logger, rtbse_env%restart_section, & - extension=c_file_labels(j), my_local=.FALSE.) - IF (.NOT. file_exists(save_name)) THEN - CPWARN("Restart without C_active file - assuming identical MO gauge (no basis bridge).") - RETURN - END IF - CALL open_file(save_name, file_status="OLD", file_form="UNFORMATTED", file_action="READ", & - unit_number=c_unit) - CALL cp_fm_read_unformatted(C_old(j), c_unit) - CALL close_file(c_unit) - END DO - found = .TRUE. - END SUBROUTINE read_restart_C END MODULE rt_bse_io diff --git a/src/emd/rt_bse_linearized.F b/src/emd/rt_bse_linearized.F deleted file mode 100644 index b4fc0d46b6..0000000000 --- a/src/emd/rt_bse_linearized.F +++ /dev/null @@ -1,2841 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief Routines for the propagation of the linearized RT-BSE equations of motion. -!> Propagates the first-order density matrix response Δρ within the active MO window, -!> in the Tamm-Dancoff approximation or with the full (A, B) coupling, instead of the -!> lesser Green's function propagated by rt_bse. Also provides the Liouvillian eigenvalue -!> diagnostic, which builds the Liouvillian by probing the kernel with canonical basis -!> vectors and diagonalizes it. -!> \note The control is handed directly from cp2k_runs -!> The initialization and delta-kick routines are adapted from the full RT-BSE -!> propagator in rt_bse.F. -!> \author Maximilian Graml (03.26) -!> \author Stepan Marek (09.24) - original RT-BSE routines adapted here -! ************************************************************************************************** - -MODULE rt_bse_linearized - USE cp_cfm_basic_linalg, ONLY: cp_cfm_gemm,& - cp_cfm_norm,& - cp_cfm_scale,& - cp_cfm_scale_and_add,& - cp_cfm_transpose - USE cp_cfm_diag, ONLY: cp_cfm_heevd - USE cp_cfm_types, ONLY: & - cp_cfm_get_info, cp_cfm_get_submatrix, cp_cfm_set_all, cp_cfm_set_element, & - cp_cfm_set_submatrix, cp_cfm_to_cfm, cp_cfm_to_fm, cp_cfm_type, cp_fm_to_cfm - USE cp_dbcsr_api, ONLY: dbcsr_add,& - dbcsr_copy,& - dbcsr_get_info,& - dbcsr_p_type,& - dbcsr_release,& - dbcsr_set - USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& - copy_fm_to_dbcsr - USE cp_fm_basic_linalg, ONLY: cp_fm_scale,& - cp_fm_scale_and_add,& - cp_fm_transpose - USE cp_fm_types, ONLY: cp_fm_create,& - cp_fm_get_diag,& - cp_fm_get_info,& - cp_fm_release,& - cp_fm_set_all,& - cp_fm_to_fm_submat_general,& - cp_fm_type - USE cp_log_handling, ONLY: cp_get_default_logger,& - cp_logger_type - USE cp_output_handling, ONLY: cp_add_iter_level,& - cp_iterate,& - cp_print_key_finished_output,& - cp_print_key_unit_nr,& - cp_rm_iter_level - USE dbt_api, ONLY: dbt_copy_matrix_to_tensor - USE force_env_methods, ONLY: force_env_calc_energy_force - USE force_env_types, ONLY: force_env_type - USE input_constants, ONLY: rtp_bse_ham_g0w0,& - use_mom_ref_zero,& - use_rt_restart - USE kinds, ONLY: dp - USE machine, ONLY: m_walltime - USE mathconstants, ONLY: twopi - USE moments_utils, ONLY: get_reference_point - USE parallel_gemm_api, ONLY: parallel_gemm - USE physcon, ONLY: evolt,& - seconds - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type - USE qs_environment_types, ONLY: get_qs_env - USE qs_moments, ONLY: build_local_moment_matrix - USE rpa_gw_kpoints_util, ONLY: cp_cfm_power - USE rt_bse, ONLY: get_hartree,& - get_sigma,& - init_hartree,& - initialize_rtbse_env,& - propagate_density,& - rho_metric - USE rt_bse_io, ONLY: & - check_restart_eps_consistency, output_field, output_moments, output_mos_contravariant, & - output_restart_linearized, print_timestep_info, read_restart_C, read_restart_density, & - read_restart_info, read_restart_trace - USE rt_bse_ri_rs, ONLY: compute_hartree_ri_rs,& - compute_hartree_ri_rs_complex,& - compute_hartree_ri_rs_from_diag,& - rt_bse_ri_rs_ensure_V_grid,& - rt_bse_ri_rs_ensure_W0_grid - USE rt_bse_types, ONLY: create_rtbse_env,& - release_rtbse_env,& - rtbse_env_type - USE rt_propagation_output, ONLY: print_ft -#include "../base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rt_bse_linearized' - - ! build_shared_sex_and_hartree input-convention selector. The mask choice also fixes the input - ! Hermiticity, which gates the Hartree imaginary channel (Im computed iff non-Hermitian = OV only). - INTEGER, PARAMETER, PRIVATE :: kernel_input_ov = 1, kernel_input_ovvo = 2, kernel_input_full = 3 - - PUBLIC :: run_propagation_linearized_bse - -CONTAINS - -! ************************************************************************************************** -!> \brief Runs the electron-only real time propagation of the linearized BSE -!> \param force_env Force environment data, entry point of the calculation -! ************************************************************************************************** - SUBROUTINE run_propagation_linearized_bse(force_env) - TYPE(force_env_type), POINTER :: force_env - - CHARACTER(len=*), PARAMETER :: routineN = 'run_propagation_linearized_bse' - - INTEGER :: handle, i, j - REAL(kind=dp) :: t_phys, t_start, timestep_walltime, & - timestep_walltime_start - REAL(kind=dp), DIMENSION(2) :: enum_im, enum_re - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_lab - TYPE(cp_logger_type), POINTER :: logger - TYPE(rtbse_env_type), POINTER :: rtbse_env - - ! Per-spin (alpha/beta) electron numbers; only 1:n_spin entries are used. - - CALL timeset(routineN, handle) - - CALL cp_warn(__LOCATION__, & - "Linearized RT-BSE is under active development. Make sure you understand "// & - "the method and validate results before using it for production calculations.") - - ! To Do: Bibliography information - - logger => cp_get_default_logger() - - ! Run the initial SCF calculation / read SCF restart information - CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., consistent_energies=.FALSE.) - - ! Allocate all persistant storage and read input that does not need further processing - CALL create_rtbse_env(rtbse_env, force_env, linearized=.TRUE.) - - ! Restart phase 1a: read sim_start + the original run's dt (from the trace header) BEFORE - ! ENFORCE_MAX_DT, so the continuation inherits that dt instead of a window-dependent one. - IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart) THEN - CALL read_restart_info(rtbse_env) - END IF - - CALL initialize_maximum_timestep(rtbse_env) - - ! Restart phase 1b: load the trace prefix now that ENFORCE_MAX_DT has sized the trace arrays. - IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart) THEN - IF (rtbse_env%sim_start >= rtbse_env%sim_nsteps) THEN - CPABORT("RT_RESTART: restart step >= STEPS - increase MOTION%MD%STEPS") - END IF - CALL read_restart_trace(rtbse_env) - END IF - - CALL print_linrtbse_header_info(rtbse_env) - - ! Build the truncated MO coefficient slabs C_active(:, first_active_mo..last_active_mo) - ! used by all AO<->MO transforms in the linearized path. - CALL populate_C_active(rtbse_env) - - ! Initiate iteration level "MD" in order to copy the structure of other RTP codes - CALL cp_add_iter_level(logger%iter_info, "MD") - ! Initialize non-trivial values - ! - calculates the moment operators - CALL initialize_moments(rtbse_env) - ! - populates overlap and inverse overlap matrices - CALL initialize_rtbse_env(rtbse_env) - - ! - populates the fresh SCF density matrix rho^0 (and the rho_orig reference for delta rho) - CALL initialize_density_matrix(rtbse_env) - - ! Restart phase 2: overwrite rho from the lab-frame restart files, bridge into this run's MO - ! gauge, then enter this run's rotating frame (rotate_rho_phase is a no-op when omega_shift=0) - IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart) THEN - CALL read_restart_density(rtbse_env) - IF (rtbse_env%restart_extracted) THEN - CALL apply_restart_basis_bridge(rtbse_env) - t_start = REAL(rtbse_env%sim_start, dp)*rtbse_env%sim_dt - DO i = 1, rtbse_env%n_spin - CALL rotate_rho_phase(rtbse_env, rtbse_env%rho(i), i, -rtbse_env%omega_shift*t_start) - END DO - END IF - END IF - ! - calculates/populates the G0W0/KS Hamiltonian, respectively - CALL initialize_singleparticle_hamiltonian(rtbse_env) - ! Restart Hamiltonian-consistency heads-up: eps_active exists only now, so compare here - CALL check_restart_eps_consistency(rtbse_env) - ! Transform initial density matrix to AO basis for use in Hartree and self-energy calculations - DO i = 1, rtbse_env%n_spin - CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%rho_orig(i), rtbse_env%rho_ao_scratch(i), i) - END DO - ! - calculates the Hartree reference potential - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_set_all(rtbse_env%ham_reference(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - CALL initialize_hartree_potential(rtbse_env) - ! - calculates the SEX reference self-energy - CALL initialize_sex_selfenergy(rtbse_env) - - ! Liouvillian eigenvalue diagnostic (one-shot at init, TDA or ABBA via dispatcher). - ! Detached from the propagator; safe to call after the reference-init routines. - IF (rtbse_env%diagnose_liouvillian_eig) THEN - CALL diagnose_liouvillian_eigenvalues(rtbse_env) - END IF - - ! Setup the time based on the starting step - ! Assumes identical dt between two runs - rtbse_env%sim_time = REAL(rtbse_env%sim_start, dp)*rtbse_env%sim_dt - NULLIFY (rho_lab) - ! Output 0 time moments and field - IF (.NOT. rtbse_env%restart_extracted) THEN - CALL output_field(rtbse_env) - CALL build_rho_lab(rtbse_env, rtbse_env%rho, rtbse_env%sim_time, rho_lab) - CALL output_moments(rtbse_env, rho_lab) - END IF - - ! Do not apply the delta kick if we are doing a restart calculation - IF (rtbse_env%dft_control%rtp_control%apply_delta_pulse .AND. (.NOT. rtbse_env%restart_extracted)) THEN - CALL apply_delta_pulse_MO(rtbse_env) - END IF - - ! ********************** Start the time loop ********************** - ! NOTE : Time-loop starts at index sim_start = 0, unless restarted or configured otherwise - DO i = rtbse_env%sim_start, rtbse_env%sim_nsteps - 1 - timestep_walltime_start = m_walltime() - - ! Update the simulation time - rtbse_env%sim_time = REAL(i, dp)*rtbse_env%sim_dt - rtbse_env%sim_step = i - - CALL solve_rk4_timestep(rtbse_env, rtbse_env%rho, rtbse_env%rho_new) - CALL get_electron_number_MO(rtbse_env, rtbse_env%rho_new, & - enum_re(1:rtbse_env%n_spin), enum_im(1:rtbse_env%n_spin)) - timestep_walltime = m_walltime() - timestep_walltime_start - CALL print_timestep_info(rtbse_env, i, enum_re(1:rtbse_env%n_spin), step_walltime=timestep_walltime) - CALL cp_iterate(logger%iter_info, iter_nr=i, last=(i == rtbse_env%sim_nsteps - 1)) - - ! Update rho - DO j = 1, rtbse_env%n_spin - CALL cp_cfm_to_cfm(rtbse_env%rho_new(j), rtbse_env%rho(j)) - END DO - ! Print the updated field - CALL output_field(rtbse_env) - ! rho is the rotating-frame density at physical time t_phys = (i+1)*dt. - ! Build a lab-frame copy once and feed it to all observable/restart sinks. - t_phys = REAL(i + 1, dp)*rtbse_env%sim_dt - CALL build_rho_lab(rtbse_env, rtbse_env%rho, t_phys, rho_lab) - ! If needed, print out the density matrix in MO basis - CALL output_mos_contravariant(rtbse_env, rho_lab, rtbse_env%rho_section) - ! Also handles outputting to memory - CALL output_moments(rtbse_env, rho_lab) - ! Output restart files, so that the restart resumes at the step recorded in .info - CALL output_restart_linearized(rtbse_env, rho_lab) - END DO - ! ********************** End the time loop ********************** - - CALL cp_rm_iter_level(logger%iter_info, "MD") - - ! Carry out the FT - CALL print_ft(rtbse_env%rtp_section, & - rtbse_env%moments_trace, & - rtbse_env%time_trace, & - rtbse_env%field_trace, & - rtbse_env%dft_control%rtp_control, & - info_opt=rtbse_env%unit_nr) - - ! Deallocate everything - CALL release_rtbse_env(rtbse_env) - - CALL timestop(handle) - END SUBROUTINE run_propagation_linearized_bse - -! ************************************************************************************************** -!> \brief Computes the analytic RK4 stability bound t* = 2√2 / Ω_max (a.u.) from the largest active -!> GW/KS gap, and (TDA + first-peak) the rotating-frame shift Ω_0 = ε^ai_min. -!> Writes the timestep diagnostics to stdout; optionally rewrites TIMESTEP/STEPS under -!> ENFORCE_MAX_DT; on restart it inherits the original dt from the trace and only rescales STEPS. -!> \param rtbse_env Entry point - rtbse environment -! ************************************************************************************************** - SUBROUTINE initialize_maximum_timestep(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'initialize_maximum_timestep' - - CHARACTER(len=256) :: hint_msg - INTEGER :: handle, i_first, i_last, ispin, & - n_steps_new, n_steps_old - REAL(kind=dp) :: eps_max_ai, eps_min_ai, eps_occ_max, eps_occ_min, eps_virt_max, & - eps_virt_min, ev_tmp, grace_factor, omega_max, sim_dt_as, total_time - - CALL timeset(routineN, handle) - - i_first = rtbse_env%first_active_mo - i_last = rtbse_env%last_active_mo - - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - omega_max = MAXVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:i_last, :, :)) - & - MINVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:i_last, :, :)) - ELSE - omega_max = MAXVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:i_last, :)) - & - MINVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:i_last, :)) - END IF - - ! First-peak shift (TDA only): set Ω_0 = eps_min_ai so the lowest - ! active OV mode oscillates at zero frequency in the rotating frame - ! (RK4-exact for peak 1). omega_max is the full active OV width - ! Delta = eps_max_ai - eps_min_ai, where eps_ai = eps_a - eps_i runs - ! over the active OV pairs only (i in active occupied, a in active - ! virtual). - rtbse_env%omega_shift = 0.0_dp - IF (rtbse_env%tda_active .AND. rtbse_env%tda_shift_to_first_peak) THEN - eps_occ_min = HUGE(0.0_dp) - eps_occ_max = -HUGE(0.0_dp) - eps_virt_min = HUGE(0.0_dp) - eps_virt_max = -HUGE(0.0_dp) - DO ispin = 1, rtbse_env%n_spin - ! Active occupied window: first_active_mo .. n_occ(ispin) - IF (rtbse_env%n_occ(ispin) >= i_first) THEN - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:rtbse_env%n_occ(ispin), :, ispin)) - eps_occ_min = MIN(eps_occ_min, ev_tmp) - ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_G0W0(i_first:rtbse_env%n_occ(ispin), :, ispin)) - eps_occ_max = MAX(eps_occ_max, ev_tmp) - ELSE - ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:rtbse_env%n_occ(ispin), ispin)) - eps_occ_min = MIN(eps_occ_min, ev_tmp) - ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_scf_Gamma(i_first:rtbse_env%n_occ(ispin), ispin)) - eps_occ_max = MAX(eps_occ_max, ev_tmp) - END IF - END IF - ! Active virtual window: n_occ(ispin)+1 .. last_active_mo - IF (rtbse_env%n_occ(ispin) < i_last) THEN - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin) + 1:i_last, :, ispin)) - eps_virt_min = MIN(eps_virt_min, ev_tmp) - ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin) + 1:i_last, :, ispin)) - eps_virt_max = MAX(eps_virt_max, ev_tmp) - ELSE - ev_tmp = MINVAL(rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin) + 1:i_last, ispin)) - eps_virt_min = MIN(eps_virt_min, ev_tmp) - ev_tmp = MAXVAL(rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin) + 1:i_last, ispin)) - eps_virt_max = MAX(eps_virt_max, ev_tmp) - END IF - END IF - END DO - - IF (eps_occ_max > -HUGE(0.0_dp) .AND. eps_virt_min < HUGE(0.0_dp)) THEN - eps_min_ai = eps_virt_min - eps_occ_max - eps_max_ai = eps_virt_max - eps_occ_min - rtbse_env%omega_shift = eps_min_ai - omega_max = eps_max_ai - eps_min_ai - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A)') & - " RTBSE| ---------- First-peak shift diagnostics (TDA, active OV pairs) ----------" - WRITE (rtbse_env%unit_nr, '(A,F14.6,A,F14.6)') & - " RTBSE| eps_occ [eV] min / max =", eps_occ_min*evolt, & - " /", eps_occ_max*evolt - WRITE (rtbse_env%unit_nr, '(A,F14.6,A,F14.6)') & - " RTBSE| eps_virt [eV] min / max =", eps_virt_min*evolt, & - " /", eps_virt_max*evolt - WRITE (rtbse_env%unit_nr, '(A,F14.6,A,F14.6)') & - " RTBSE| eps_ai [eV] min / max =", eps_min_ai*evolt, & - " /", eps_max_ai*evolt - WRITE (rtbse_env%unit_nr, '(A,F14.6)') & - " RTBSE| omega_shift [eV] =", rtbse_env%omega_shift*evolt - WRITE (rtbse_env%unit_nr, '(A,F14.6)') & - " RTBSE| omega_max [eV] (full) =", omega_max*evolt - WRITE (rtbse_env%unit_nr, '(A)') & - " RTBSE| ------------------------------------------------------------------------" - END IF - ELSE - ! Active window has no genuine OV pair - fall back to no shift - rtbse_env%omega_shift = 0.0_dp - rtbse_env%tda_shift_to_first_peak = .FALSE. - END IF - END IF - - rtbse_env%omega_max = omega_max - - IF (omega_max > 0.0_dp) THEN - ! t* = 2√2 / Ω_max (a.u.; imaginary-axis RK4 bound |R(iy)| ≤ 1 at y = 2√2) - rtbse_env%maximum_timestep = 2.0_dp*SQRT(2.0_dp)/omega_max - ELSE - CALL cp_abort(__LOCATION__, & - "Error in estimating maximum timestep: largest KS/GW gap is "// & - "non-positive. Check the active MO window (cutoffs) and the "// & - "eigenvalues.") - END IF - - IF (rtbse_env%sim_dt <= 0.0_dp) THEN - CALL cp_abort(__LOCATION__, & - "TIMESTEP must be positive for linearized RT-BSE. Use RTBSE%ENFORCE_MAX_DT "// & - "with a positive TIMESTEP to automatically rewrite TIMESTEP and STEPS.") - END IF - - n_steps_old = MAX(0, rtbse_env%sim_nsteps) - - IF (rtbse_env%enforce_max_dt) THEN - total_time = REAL(n_steps_old, dp)*rtbse_env%sim_dt - ! Full code needs a grace factor of 4 - IF (rtbse_env%tda_active) THEN - grace_factor = 1.0_dp - ELSE - grace_factor = 4.0_dp - END IF - IF (rtbse_env%dft_control%rtp_control%initial_wfn == use_rt_restart .AND. & - rtbse_env%sim_dt_restart > 0.0_dp) THEN - ! Continuation: dt is frozen in the trace, so inherit it and only rescale the step count - ! to the requested window. Recomputing dt from the (longer) window would desync the trace - ! time-grid and trip the continuation guard in read_restart_trace. - rtbse_env%sim_dt = rtbse_env%sim_dt_restart - n_steps_new = MAX(1, NINT(total_time/rtbse_env%sim_dt)) - rtbse_env%sim_nsteps = n_steps_new - sim_dt_as = rtbse_env%sim_dt*seconds*1e18_dp - WRITE (hint_msg, '(A,F16.4,A,I0,A)') & - 'ENFORCE_MAX_DT on restart: inheriting original TIMESTEP ', sim_dt_as, & - ' as and setting STEPS to ', n_steps_new, '.' - CALL cp_hint(__LOCATION__, TRIM(hint_msg)) - ! The inherited dt was stable in the original run; warn only if this run's stability - ! window shrank below it (e.g. the recomputed GW eigenvalues shifted the gap). - IF (rtbse_env%sim_dt > rtbse_env%maximum_timestep/grace_factor) THEN - CALL cp_warn(__LOCATION__, & - "ENFORCE_MAX_DT restart: inherited dt exceeds this run's stability "// & - "limit - the recomputed Hamiltonian may make the propagation unstable.") - END IF - ELSE - n_steps_new = MAX(1, CEILING(total_time/(rtbse_env%maximum_timestep/grace_factor))) - rtbse_env%sim_dt = total_time/REAL(n_steps_new, dp) - rtbse_env%sim_nsteps = n_steps_new - sim_dt_as = rtbse_env%sim_dt*seconds*1e18_dp - WRITE (hint_msg, '(A,F16.4,A,I0,A)') & - 'ENFORCE_MAX_DT enabled. Resetting TIMESTEP to ', sim_dt_as, & - ' as and STEPS to ', n_steps_new, '.' - CALL cp_hint(__LOCATION__, TRIM(hint_msg)) - END IF - END IF - - IF (rtbse_env%sim_nsteps /= n_steps_old) THEN - CALL reallocate_ft_traces(rtbse_env) - END IF - - CALL timestop(handle) - END SUBROUTINE initialize_maximum_timestep - -! ************************************************************************************************** -!> \brief Reallocate FT trace buffers after ENFORCE_MAX_DT rewrites the step count. -!> \param rtbse_env Entry point - rtbse environment -! ************************************************************************************************** - SUBROUTINE reallocate_ft_traces(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'reallocate_ft_traces' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - IF (ASSOCIATED(rtbse_env%moments_trace)) DEALLOCATE (rtbse_env%moments_trace) - IF (ASSOCIATED(rtbse_env%field_trace)) DEALLOCATE (rtbse_env%field_trace) - IF (ASSOCIATED(rtbse_env%time_trace)) DEALLOCATE (rtbse_env%time_trace) - - ALLOCATE (rtbse_env%moments_trace(rtbse_env%n_spin, 3, rtbse_env%sim_nsteps + 1), & - source=CMPLX(0.0_dp, 0.0_dp, kind=dp)) - ALLOCATE (rtbse_env%field_trace(3, rtbse_env%sim_nsteps + 1), & - source=CMPLX(0.0_dp, 0.0_dp, kind=dp)) - ALLOCATE (rtbse_env%time_trace(rtbse_env%sim_nsteps + 1), source=0.0_dp) - - CALL timestop(handle) - END SUBROUTINE reallocate_ft_traces - -! ************************************************************************************************** -!> \brief Prints the linRTBSE run header to stdout: active-MO window (first/last/count) and the -!> occupied/virtual energy cutoffs. -!> \param rtbse_env Entry point - rtbse environment -! ************************************************************************************************** - SUBROUTINE print_linrtbse_header_info(rtbse_env) - TYPE(rtbse_env_type) :: rtbse_env - - INTEGER :: ispin, n_steps - REAL(kind=dp) :: e_first, e_last, fft_resolution, & - nyquist_frequency, total_time - TYPE(cp_logger_type), POINTER :: logger - - logger => cp_get_default_logger() - n_steps = MAX(0, rtbse_env%sim_nsteps) - total_time = REAL(n_steps, dp)*rtbse_env%sim_dt - fft_resolution = 0.0_dp - nyquist_frequency = 0.0_dp - IF (total_time > 0.0_dp) fft_resolution = twopi/total_time - IF (rtbse_env%sim_dt > 0.0_dp) nyquist_frequency = twopi/(2.0_dp*rtbse_env%sim_dt) - - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, *) '' - WRITE (rtbse_env%unit_nr, '(A)') ' /-----------------------------------------------'// & - '------------------------------\' - WRITE (rtbse_env%unit_nr, '(A)') ' | '// & - ' |' - WRITE (rtbse_env%unit_nr, '(A)') ' | Linearized Real Time Bethe-Salpeter Propagation'// & - ' |' - WRITE (rtbse_env%unit_nr, '(A)') ' | '// & - ' |' - WRITE (rtbse_env%unit_nr, '(A)') ' \-----------------------------------------------'// & - '------------------------------/' - WRITE (rtbse_env%unit_nr, *) '' - - WRITE (rtbse_env%unit_nr, '(A18,L62)') ' Apply delta pulse', & - rtbse_env%dft_control%rtp_control%apply_delta_pulse - WRITE (rtbse_env%unit_nr, '(A)') '' - WRITE (rtbse_env%unit_nr, '(A18,L62)') ' Use Tamm-Dancoff approximation', & - rtbse_env%tda_active - IF (rtbse_env%tda_active) THEN - WRITE (rtbse_env%unit_nr, '(A,T71,L10)') ' TDA first-peak shift active', & - rtbse_env%tda_shift_to_first_peak - IF (rtbse_env%tda_shift_to_first_peak) THEN - WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' TDA first-peak shift Omega_0 [eV]:', & - rtbse_env%omega_shift*evolt - END IF - END IF - - WRITE (rtbse_env%unit_nr, '(A)') '' - - WRITE (rtbse_env%unit_nr, '(A,T65,F16.4)') ' Estimated maximum timestep within stability region [as]:', & - rtbse_env%maximum_timestep*seconds*1e18_dp - WRITE (rtbse_env%unit_nr, '(A,T65,F16.4)') ' Applied timestep [as]:', & - rtbse_env%sim_dt*seconds*1e18_dp - WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' Number of propagation steps:', n_steps - WRITE (rtbse_env%unit_nr, '(A,T65,F16.4)') ' Total propagation time [as]:', & - total_time*seconds*1e18_dp - WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' Estimated FFT frequency resolution without interpolation [eV]:', & - fft_resolution*evolt - WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' Nyquist frequency [eV]:', & - nyquist_frequency*evolt - WRITE (rtbse_env%unit_nr, '(A,T65,F16.6)') ' Estimated maximum oscillation frequency (gap-based) [eV]:', & - rtbse_env%omega_max*evolt - - ! Active MO window (energy-cutoff truncation) for linearized RT-BSE - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - WRITE (rtbse_env%unit_nr, '(A,T75,A6)') ' Active-window single-particle spectrum source:', ' G0W0' - ELSE - WRITE (rtbse_env%unit_nr, '(A,T75,A6)') ' Active-window single-particle spectrum source:', ' KS' - END IF - IF (rtbse_env%rtbse_energy_cutoff_occ > 0.0_dp) THEN - WRITE (rtbse_env%unit_nr, '(A,T71,F10.3)') ' Active-window occupied energy cutoff [eV]:', & - rtbse_env%rtbse_energy_cutoff_occ*evolt - ELSE - WRITE (rtbse_env%unit_nr, '(A,T71,A10)') ' Active-window occupied energy cutoff [eV]:', ' disabled' - END IF - IF (rtbse_env%rtbse_energy_cutoff_empty > 0.0_dp) THEN - WRITE (rtbse_env%unit_nr, '(A,T71,F10.3)') ' Active-window virtual energy cutoff [eV]:', & - rtbse_env%rtbse_energy_cutoff_empty*evolt - ELSE - WRITE (rtbse_env%unit_nr, '(A,T71,A10)') ' Active-window virtual energy cutoff [eV]:', ' disabled' - END IF - WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' First active occupied MO index:', rtbse_env%first_active_mo - WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' Last active virtual MO index:', rtbse_env%last_active_mo - WRITE (rtbse_env%unit_nr, '(A,T71,I10)') ' Number of active MOs:', rtbse_env%mo_active - IF (rtbse_env%active_mo_truncation) THEN - ! The window is cut on the DFT axis but propagated on the QP axis, so the QP edges may - ! exceed the nominal cutoff. Print both so the window can be checked against the input. - DO ispin = 1, rtbse_env%n_spin - e_first = (rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%first_active_mo, ispin) - & - rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin), ispin))*evolt - e_last = (rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%last_active_mo, ispin) - & - rtbse_env%bs_env%eigenval_scf_Gamma(rtbse_env%n_occ(ispin) + 1, ispin))*evolt - WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & - ' first active MO, E - E_HOMO (KS) [eV]:', e_first - WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & - ' last active MO, E - E_LUMO (KS) [eV]:', e_last - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - e_first = (rtbse_env%bs_env%eigenval_G0W0(rtbse_env%first_active_mo, 1, ispin) - & - rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin), 1, ispin))*evolt - e_last = (rtbse_env%bs_env%eigenval_G0W0(rtbse_env%last_active_mo, 1, ispin) - & - rtbse_env%bs_env%eigenval_G0W0(rtbse_env%n_occ(ispin) + 1, 1, ispin))*evolt - WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & - ' first active MO, E - E_HOMO (QP) [eV]:', e_first - WRITE (rtbse_env%unit_nr, '(A,I1,A,T71,F10.3)') ' Spin ', ispin, & - ' last active MO, E - E_LUMO (QP) [eV]:', e_last - END IF - END DO - END IF - END IF - - END SUBROUTINE print_linrtbse_header_info - -! ************************************************************************************************** -!> \brief Populates rtbse_env%C_active(i_spin) (n_ao x mo_active) by extracting columns -!> first_active_mo..last_active_mo from bs_env%fm_mo_coeff_Gamma(i_spin). -!> \param rtbse_env RT-BSE environment -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** - SUBROUTINE populate_C_active(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'populate_C_active' - - INTEGER :: handle, i - - CALL timeset(routineN, handle) - - DO i = 1, rtbse_env%n_spin - CALL cp_fm_set_all(rtbse_env%C_active(i), 0.0_dp) - CALL cp_fm_to_fm_submat_general( & - rtbse_env%bs_env%fm_mo_coeff_Gamma(i), rtbse_env%C_active(i), & - rtbse_env%n_ao, rtbse_env%mo_active, & - 1, rtbse_env%first_active_mo, & - 1, 1, & - rtbse_env%bs_env%fm_mo_coeff_Gamma(i)%matrix_struct%context) - END DO - - CALL timestop(handle) - END SUBROUTINE populate_C_active - -! ************************************************************************************************** -!> \brief Builds the dipole moment operators r_mn in the active-MO basis (per axis, per spin) from -!> the AO moment matrices: moments(k,σ) at the reference point, moments_field(k,σ) at origin. -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_moments(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'initialize_moments' - - INTEGER :: handle, i_spin, k - REAL(kind=dp), DIMENSION(3) :: rpoint - TYPE(cp_fm_type) :: tmp_ao - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, moments_dbcsr_p - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env, matrix_s=matrix_s) - - ! AO-sized scratch buffer for moment matrices before transform to MO basis - CALL cp_fm_create(tmp_ao, bs_env%fm_s_Gamma%matrix_struct) - - ! ****** START MOMENTS OPERATOR CALCULATION - ! Construct moments from dbcsr - NULLIFY (moments_dbcsr_p) - ALLOCATE (moments_dbcsr_p(3)) - DO k = 1, 3 - ! Make sure the pointer is empty - NULLIFY (moments_dbcsr_p(k)%matrix) - ! Allocate a new matrix that the pointer points to - ALLOCATE (moments_dbcsr_p(k)%matrix) - ! Create the matrix storage - matrix copies the structure of overlap matrix - CALL dbcsr_copy(moments_dbcsr_p(k)%matrix, matrix_s(1)%matrix) - END DO - ! Run the moment calculation - ! check for presence to prevent memory errors - rpoint(:) = 0.0_dp - CALL get_reference_point(rpoint, qs_env=rtbse_env%qs_env, & - reference=rtbse_env%moment_ref_type, ref_point=rtbse_env%user_moment_ref_point) - CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) - ! Copy to AO scratch then transform to MO-active - DO k = 1, 3 - CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, tmp_ao) - DO i_spin = 1, rtbse_env%n_spin - CALL transform_ao_to_mo_covariant_fm(rtbse_env, tmp_ao, rtbse_env%moments(k, i_spin), i_spin) - END DO - END DO - ! TODO: remove moments_field (only needed for the TDDFT comparison) - ! Now, repeat without reference point to get the moments for field - CALL get_reference_point(rpoint, qs_env=rtbse_env%qs_env, & - reference=use_mom_ref_zero) - CALL build_local_moment_matrix(rtbse_env%qs_env, moments_dbcsr_p, 1, rpoint) - DO k = 1, 3 - CALL copy_dbcsr_to_fm(moments_dbcsr_p(k)%matrix, tmp_ao) - DO i_spin = 1, rtbse_env%n_spin - CALL transform_ao_to_mo_covariant_fm(rtbse_env, tmp_ao, rtbse_env%moments_field(k, i_spin), i_spin) - END DO - END DO - - ! Now can deallocate dbcsr matrices - DO k = 1, 3 - CALL dbcsr_release(moments_dbcsr_p(k)%matrix) - DEALLOCATE (moments_dbcsr_p(k)%matrix) - END DO - DEALLOCATE (moments_dbcsr_p) - CALL cp_fm_release(tmp_ao) - ! ****** END MOMENTS OPERATOR CALCULATION - - CALL timestop(handle) - END SUBROUTINE initialize_moments - -! ************************************************************************************************** -!> \brief Initial MO density ρ^0_mn = f_m δ_mn (f_m = 1 on active occupied, 0 on virtual), copied to -!> rho_orig as the reference for the δ-kick. Imaginary part zero. -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - adapted to the linearized active-MO path -! ************************************************************************************************** - SUBROUTINE initialize_density_matrix(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'initialize_density_matrix' - - INTEGER :: handle, i, i_row_global, ii, & - j_col_global, jj, ncol_global, & - ncol_local, nrow_global, nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - - CALL timeset(routineN, handle) - - ! Get distribution of MO-active workspace - CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & - nrow_global=nrow_global, ncol_global=ncol_global, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - - ! Iterate over both spins - DO i = 1, rtbse_env%n_spin - !Ensure that workspace is set to 0 - CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) - DO ii = 1, nrow_local - i_row_global = row_indices(ii) - DO jj = 1, ncol_local - j_col_global = col_indices(jj) - IF (i_row_global == j_col_global .AND. & - (i_row_global + rtbse_env%first_active_mo - 1) <= rtbse_env%n_occ(i)) THEN - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = 1.0_dp - END IF - END DO - END DO - ! Sets imaginary part to zero - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%rho(i)) - ! Save the reference value for the case of delta kick - CALL cp_cfm_to_cfm(rtbse_env%rho(i), rtbse_env%rho_orig(i)) - END DO - ! rho_orig stays the SCF reference for delta rho; a restart overwrites only rho, downstream in - ! the driver (read_restart_density + apply_restart_basis_bridge + rotate_rho_phase). - - CALL timestop(handle) - END SUBROUTINE initialize_density_matrix - -! ************************************************************************************************** -!> \brief Single-particle reference Hamiltonian in the active-MO basis: H^0_mn = ε^GW_m δ_mn (or KS -!> ε^scf), diagonal. TDA first-peak adds +Ω_0/2 on occupied, -Ω_0/2 on virtual diagonals. -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - refactor in prep. of linearized propagation -! ************************************************************************************************** - SUBROUTINE initialize_singleparticle_hamiltonian(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'initialize_singleparticle_hamiltonian' - - INTEGER :: abs_mo_idx, handle, i, i_row_global, ii, & - j_col_global, jj, ncol_global, & - ncol_local, nrow_global, nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) - - ! Get distribution of MO-active workspace - CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & - nrow_global=nrow_global, ncol_global=ncol_global, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - - !Ensure that workspace is set to 0 - CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) - rtbse_env%eps_active(:, :) = 0.0_dp - ! ****** START SINGLE PARTICLE HAMILTONIAN CALCULATION - DO i = 1, rtbse_env%n_spin - DO ii = 1, nrow_local - i_row_global = row_indices(ii) - DO jj = 1, ncol_local - j_col_global = col_indices(jj) - IF (i_row_global == j_col_global) THEN - abs_mo_idx = i_row_global + rtbse_env%first_active_mo - 1 - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! G0W0 Hamiltonian - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = bs_env%eigenval_G0W0(abs_mo_idx, 1, i) - ELSE - ! KS Hamiltonian - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = bs_env%eigenval_scf_Gamma(abs_mo_idx, i) - END IF - ! First-peak shift (TDA only): rotate the single-particle Hamiltonian - ! into a frame where the lowest active OV mode oscillates at zero, with - ! Ω_0 = eps_min_ai. Adds +Ω_0/2 on active occupied diagonals and - ! -Ω_0/2 on active virtual diagonals so that [h', rho]_OV picks up an - ! overall (- eps_ai + Ω_0) and OO/VV blocks remain commutator-free. - IF (rtbse_env%tda_active .AND. rtbse_env%tda_shift_to_first_peak) THEN - IF (abs_mo_idx <= rtbse_env%n_occ(i)) THEN - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) + 0.5_dp*rtbse_env%omega_shift - ELSE - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) - 0.5_dp*rtbse_env%omega_shift - END IF - END IF - ! Mirror the finalized diagonal into the replicated active-energy array - rtbse_env%eps_active(i_row_global, i) = rtbse_env%real_workspace_mo(1)%local_data(ii, jj) - END IF - END DO - END DO - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%ham_reference_singleparticle(i)) - END DO - ! Each diagonal element was set on its single owner rank; sum to replicate eps_active. - CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%sum(rtbse_env%eps_active) - ! ****** END SINGLE PARTICLE HAMILTONIAN CALCULATION - - CALL timestop(handle) - END SUBROUTINE initialize_singleparticle_hamiltonian - -! ************************************************************************************************** -!> \brief Reference Hartree subtraction: builds V^H[ρ^0] (AO-RI or RI-RS) and subtracts it into -!> ham_reference, realizing H_eff = ... + V_H[ρ] - V_H[ρ^0]. Only for non-TDA n_spin=1 (in -!> TDA the OV/VO projection of the OO-diagonal ρ^0 vanishes, so the reference is zero). -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - add transform to MO -! ************************************************************************************************** - SUBROUTINE initialize_hartree_potential(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'initialize_hartree_potential' - - INTEGER :: handle, i, n_grid - LOGICAL :: use_hartree_reference, use_rirs_kernel - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CALL timeset(routineN, handle) - ! Get pointers to parameters from qs_env - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) - use_hartree_reference = (.NOT. rtbse_env%tda_active) .AND. (rtbse_env%n_spin == 1) .AND. & - (.NOT. rtbse_env%debug_disable_hartree) - use_rirs_kernel = rtbse_env%rirs_kernel - - ! Make sure the RI-RS V_grid kernel is available if we need it for Hartree. - IF (use_rirs_kernel) CALL rt_bse_ri_rs_ensure_V_grid(bs_env, rtbse_env%qs_env) - - ! Spin-summed grid-density accumulators for the RI-RS Hartree reuse (diag(φρφ^T) harvested in SEX; - ! mat_phi_mu_l is grid x AO, so its row count is n_grid). Allocated ONLY for RI-RS + Hartree, so the - ! get_sigma harvest calls (passed unconditionally below) see an absent optional and self-disable on - ! AO-RI / Hartree-off (F2008 unallocated-allocatable -> absent optional). Sole allocator, runs once. - IF (use_rirs_kernel .AND. (.NOT. rtbse_env%debug_disable_hartree)) THEN - CALL dbcsr_get_info(bs_env%ri_rs%mat_phi_mu_l, nfullrows_total=n_grid) - ALLOCATE (rtbse_env%hartree_diag_re(n_grid), rtbse_env%hartree_diag_im(n_grid)) - END IF - - ! The RI-RS Hartree normally reuses the grid density harvested by the SEX kernel. With SEX - ! disabled but Hartree on, that diagonal is never produced, so the Hartree must rebuild the full - ! real-space density grid itself every RK4 stage - much slower. Warn once (this is a debug-only - ! configuration); the rebuild fallback lives in the use_sex branches of the Hartree kernels. - IF (use_rirs_kernel .AND. (.NOT. rtbse_env%debug_disable_hartree) .AND. rtbse_env%debug_disable_sex) THEN - CALL cp_warn(__LOCATION__, & - "RI-RS Hartree rebuilds the full density grid every RK4 stage because SEX is "// & - "disabled (DEBUG_DISABLE_SEX) and no SEX-harvested diagonal is available to reuse. "// & - "This slows down the Hartree computation considerably.") - END IF - - ! ****** START HARTREE POTENTIAL REFERENCE CALCULATION - ! v_dbcsr is needed by either AO-RI Hartree (here) or by AO-RI SEX (W = V + W^c assembly). - IF (.NOT. use_rirs_kernel) THEN - CALL init_hartree(rtbse_env, rtbse_env%v_dbcsr) - END IF - ! Always zero ham_reference here (this routine is the first to touch it). - ! The Hartree reference subtraction is then conditionally added below. - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_set_all(rtbse_env%ham_reference(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - ! Calculate the original Hartree potential - ! Uses rho_orig - same as rho for initial run but different for continued run - ! In TDA the propagator evaluates separate OV/VO-projected kernel passes. - ! rho_orig is OO-diagonal in the MO basis, so its OV/VO projections vanish - ! and the corresponding Hartree reference is identically zero. - IF (use_hartree_reference) THEN - DO i = 1, rtbse_env%n_spin - IF (use_rirs_kernel) THEN - ! V^H_λσ = sum_l φ_λ(r_l) v_l φ_σ(r_l), v_l = sum_l' V_ll' n_l' (RI-RS) - ! AO-RI get_hartree uses only Re(rho); mirror that on the RI-RS path. - CALL cp_cfm_to_fm(msource=rtbse_env%rho_ao_scratch(i), & - mtargetr=rtbse_env%real_workspace(1)) - CALL compute_hartree_ri_rs(bs_env, rtbse_env%real_workspace(1), & - rtbse_env%hartree_curr_ao(i)) - ELSE - ! V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) ρ^0_µν] (AO-RI; reference density) - CALL get_hartree(rtbse_env, rtbse_env%rho_ao_scratch(i), rtbse_env%hartree_curr_ao(i)) - END IF - ! Scaling by spin degeneracy - CALL cp_fm_scale(rtbse_env%spin_degeneracy, rtbse_env%hartree_curr_ao(i)) - ! Transform to MO basis (AO scratch -> MO-active result) - CALL transform_ao_to_mo_covariant_fm(rtbse_env, rtbse_env%hartree_curr_ao(i), rtbse_env%hartree_curr(i), i) - ! Apply occupation factor f_n-f_m - CALL transform_mo_occupation_factor_diff_fm(rtbse_env, rtbse_env%hartree_curr(i), i) - ! Subtract the reference from the reference Hamiltonian - ! following H_eff = ... + V_Hartree(rho) - V_Hartree(rho_0), - CALL cp_fm_to_cfm(msourcer=rtbse_env%hartree_curr(i), mtarget=rtbse_env%ham_workspace(1)) - CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & - CMPLX(-1.0, 0.0, kind=dp), rtbse_env%ham_workspace(1)) - END DO - END IF - ! ****** END HARTREE POTENTIAL REFERENCE CALCULATION - - CALL timestop(handle) - END SUBROUTINE initialize_hartree_potential - -! ************************************************************************************************** -!> \brief Reference SEX self-energy subtraction into ham_reference (non-TDA, n_spin=1). Assembles -!> W = V + W^c, then Σ^SX = -W ρ^0, (f_n - f_m)-weighted, subtracted. -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml (03.26) - add transform to MO -! ************************************************************************************************** - SUBROUTINE initialize_sex_selfenergy(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'initialize_sex_selfenergy' - - INTEGER :: handle, i - LOGICAL :: use_rirs_kernel, use_sex_reference - - CALL timeset(routineN, handle) - use_sex_reference = (.NOT. rtbse_env%tda_active) .AND. (rtbse_env%n_spin == 1) .AND. & - (.NOT. rtbse_env%debug_disable_sex) - use_rirs_kernel = rtbse_env%rirs_kernel - - ! Make sure the RI-RS W0_grid kernel is available if we need it for SEX. - IF (use_rirs_kernel) CALL rt_bse_ri_rs_ensure_W0_grid(rtbse_env%bs_env, rtbse_env%qs_env) - - ! ****** START SEX REFERENCE CALCULATION - ! w_dbcsr and screened_dbt are needed for get_sigma routines (AO-RI path only). - ! For RI-RS the W = V + W^c kernel is on the real-space grid in mat_W0_grid_rtbse. - IF (.NOT. use_rirs_kernel) THEN - IF (rtbse_env%ham_reference_type == rtp_bse_ham_g0w0) THEN - ! W(w=0) is built by the GW step only under its RTBSE rtp_method gate; reaching this - ! consumer without it means gate and consumer disagree. The HF branch below needs no W. - IF (.NOT. ASSOCIATED(rtbse_env%bs_env%fm_W_MIC_freq_zero%matrix_struct)) THEN - CALL cp_abort(__LOCATION__, & - "RT-BSE AO-RI kernel needs the screened interaction W(w=0), which the "// & - "GW step did not build. Select the RT-BSE propagator with '&RTBSE' or "// & - "'&RTBSE RTBSE', not '&RTBSE TDDFT'.") - END IF - ! In a non-HF calculation, copy the actual correlation part of the interaction - CALL copy_fm_to_dbcsr(rtbse_env%bs_env%fm_W_MIC_freq_zero, rtbse_env%w_dbcsr) - ELSE - ! In HF, correlation is set to zero - CALL dbcsr_set(rtbse_env%w_dbcsr, 0.0_dp) - END IF - ! Add the Hartree to the screened_dbt tensor - now W = V + W^c - CALL dbcsr_add(rtbse_env%w_dbcsr, rtbse_env%v_dbcsr, 1.0_dp, 1.0_dp) - CALL dbt_copy_matrix_to_tensor(rtbse_env%w_dbcsr, rtbse_env%screened_dbt) - END IF - ! Calculate the SEX starting energies - DO i = 1, rtbse_env%n_spin - ! Calculate the exchange (SEX) part for this spin channel - ! Uses rho_orig - same as rho for initial run but different for continued run - ! For KS reference this is the time-dependent Fock exchange (w_dbcsr = v only). - ! In TDA the propagator evaluates separate OV/VO-projected kernel passes. - ! rho_orig is OO-diagonal in the MO basis, so its OV/VO projections - ! vanish and the SEX reference must remain zero in TDA. - IF (use_sex_reference) THEN - ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) ρ^0_µν][sum_P (νσ|P) W_PQ] (reference) - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(i), -1.0_dp, rtbse_env%rho_ao_scratch(i)) - ! Transform to MO basis (AO scratch -> MO-active result) - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(i), rtbse_env%sigma_SEX(i), i) - ! Apply occupation factor f_n-f_m - CALL transform_mo_occupation_factor_diff_cfm(rtbse_env, rtbse_env%sigma_SEX(i), i) - ! Subtract from the complex reference Hamiltonian - CALL cp_cfm_scale_and_add(CMPLX(1.0, 0.0, kind=dp), rtbse_env%ham_reference(i), & - CMPLX(-1.0, 0.0, kind=dp), rtbse_env%sigma_SEX(i)) - END IF - END DO - ! ****** END SEX REFERENCE CALCULATION - - CALL timestop(handle) - END SUBROUTINE initialize_sex_selfenergy - -! ************************************************************************************************** -!> \brief Propagates the density one timestep by RK4 for ∂_t ρ = f(t,ρ) = -!> -i( Δε Δρ + (f_n - f_m) V_Hartree(Δρ) + ΔΣ(Δρ) ); see body for the 4-stage scheme. -!> Spin loop is inner to each stage (cross-spin Hartree coupling). -!> \param rtbse_env Entry point - rtbse environment -!> \param rho_start Initial density matrix -!> \param rho_end Final density matrix -! ************************************************************************************************** - SUBROUTINE solve_rk4_timestep(rtbse_env, rho_start, rho_end) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_start, rho_end - - CHARACTER(len=*), PARAMETER :: routineN = 'solve_rk4_timestep' - - INTEGER :: handle, i - - CALL timeset(routineN, handle) - ! RK4 follows the typical scheme - ! d/dt ρ = f(t, ρ) - ! f(t,ρ) = -i( Δε Δρ + (f_n-f_m) V_Hartree(Δρ) + ΔΣ(Δρ) ) - ! i.e. RK4 reads - ! k_1 = f(t, ρ_start) - ! k_2 = f(t + dt/2, ρ_start + dt/2 * k_1) - ! k_3 = f(t + dt/2, ρ_start + dt/2 * k_2) - ! k_4 = f(t + dt, ρ_start + dt * k_3) - ! ρ_end = ρ_start + dt/6 * (k_1 + 2*k_2 + 2*k_3 + k_4) - ! Note that the effective Hamiltonian needs to be updated for each evaluation of f, - ! as it depends on the density matrix at the respective time - - ! Spin loop is INNER to each RK4 stage (inside do_rk4_stage): cross-spin-coupled kernels (Hartree in - ! open shell) need every spin's stage density before any spin advances. rk4_coefficients(i) holds - ! spin i's CURRENT-stage k (indexed by spin, not stage - see its allocation in create_rtbse_env), - ! reused across stages; rho_workspace(i) holds spin i's stage density. Bit-identical for n_spin=1. - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_to_cfm(rho_start(i), rho_end(i)) - END DO - ! Each stage: do_rk4_stage evaluates k = f(stage density) for all spins, accumulates - ! rho_end += result_weight*dt*k (Butcher b = 1/6, 1/3, 1/3, 1/6) and forms the next stage density - ! rho_workspace = rho_start + advance_weight*dt*k (node c = 1/2, 1/2, 1; omitted on k_4, which only - ! accumulates). The dt factor is applied inside do_rk4_stage, so the calls show the bare weights. - ! k_1 = f(t, rho_start) - CALL do_rk4_stage(rtbse_env, rho_start, rho_start, rho_end, & - result_weight=1.0_dp/6.0_dp, advance_weight=0.5_dp) - ! k_2 = f(t + dt/2, rho_start + dt/2 * k_1) - CALL do_rk4_stage(rtbse_env, rtbse_env%rho_workspace, rho_start, rho_end, & - result_weight=1.0_dp/3.0_dp, advance_weight=0.5_dp) - ! k_3 = f(t + dt/2, rho_start + dt/2 * k_2) - CALL do_rk4_stage(rtbse_env, rtbse_env%rho_workspace, rho_start, rho_end, & - result_weight=1.0_dp/3.0_dp, advance_weight=1.0_dp) - ! k_4 = f(t + dt, rho_start + dt * k_3) - CALL do_rk4_stage(rtbse_env, rtbse_env%rho_workspace, rho_start, rho_end, & - result_weight=1.0_dp/6.0_dp) - - ! Update bookkeeping to the next timestep similar to logic of etrs_scf_loop - rtbse_env%sim_step = rtbse_env%sim_step + 1 - rtbse_env%sim_time = rtbse_env%sim_time + rtbse_env%sim_dt - - CALL timestop(handle) - END SUBROUTINE solve_rk4_timestep - -! ************************************************************************************************** -!> \brief Takes one RK4 stage. Evaluates k = f(t, rho_eval) for every spin into -!> rtbse_env%rk4_coefficients, accumulates it into the running result (rho_end += result_weight*dt*k) -!> and - unless this is the last stage - forms the next stage density -!> (rho_workspace = rho_base + advance_weight*dt*k). Builds the stage's shared kernels first: the -!> cross-spin Hartree is built once per stage and consumed by every spin in update_effective_ham_MO. -!> All shell/kernel combinations go through build_shared_sex_and_hartree (mask_mode selects the -!> input convention); update_effective_ham_MO is then a pure consumer. -!> No timeset/timestop: the callees are individually timed and this runs 4x per RK4 timestep. -!> \param rtbse_env RT-BSE environment -!> \param rho_eval Per-spin MO density f is evaluated at (rho_start for k_1, rho_workspace otherwise) -!> \param rho_base Per-spin MO density the next stage advances from (the step's rho_start) -!> \param rho_end Per-spin RK4 result accumulator (= rho_start + dt/6*(k1+2k2+2k3+k4) after all 4 stages) -!> \param result_weight RK4 Butcher weight b (dt factor applied inside) for accumulating k into rho_end -!> \param advance_weight RK4 node c (dt factor applied inside) for the next stage density; ABSENT on the last stage -!> \author Maximilian Graml -! ************************************************************************************************** - SUBROUTINE do_rk4_stage(rtbse_env, rho_eval, rho_base, rho_end, result_weight, advance_weight) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_eval, rho_base, rho_end - REAL(kind=dp), INTENT(IN) :: result_weight - REAL(kind=dp), INTENT(IN), OPTIONAL :: advance_weight - - INTEGER :: i, mask_mode - - ! Input convention for this stage's shared kernel build: - IF (rtbse_env%tda_active) THEN - mask_mode = kernel_input_ov ! TDA (any shell): OV only, non-Hermitian - ELSE IF (rtbse_env%n_spin > 1) THEN - mask_mode = kernel_input_ovvo ! open-shell ABBA: OV+VO, Hermitian - ELSE - mask_mode = kernel_input_full ! closed-shell ABBA: full ρ, Hermitian - END IF - ! Build this stage's shared SEX + bare Hartree; consumers are per-spin in update_effective_ham_MO. - CALL build_shared_sex_and_hartree(rtbse_env, rho_eval, mask_mode) - DO i = 1, rtbse_env%n_spin - CALL update_effective_ham_MO(rtbse_env, rho_eval(i), rtbse_env%rk4_coefficients(i), i) - IF (rtbse_env%tda_active .OR. rtbse_env%n_spin > 1) THEN - CALL project_drho_to_ov(rtbse_env, rtbse_env%rk4_coefficients(i), i) - END IF - END DO - ! Fold each spin's k into the RK4 result and (unless last stage) form the next stage density. - ! The dt factor lives here so the call sites carry the bare RK4 weights. - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rho_end(i), & - CMPLX(result_weight*rtbse_env%sim_dt, 0.0_dp, kind=dp), rtbse_env%rk4_coefficients(i)) - IF (PRESENT(advance_weight)) THEN - CALL cp_cfm_to_cfm(rho_base(i), rtbse_env%rho_workspace(i)) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_workspace(i), & - CMPLX(advance_weight*rtbse_env%sim_dt, 0.0_dp, kind=dp), rtbse_env%rk4_coefficients(i)) - END IF - END DO - END SUBROUTINE do_rk4_stage - -! ************************************************************************************************** -!> \brief Builds the spin-summed complex Hartree potential in AO, once per RK4 stage (AO-RI or RI-RS). -!> rho_total = spin_degeneracy * sum_sigma (OV-masked rho^sigma -> AO); hartree_total_ao = -!> V_H[rho_total]. update_effective_ham_MO back-transforms it with each spin's C, so this -!> single call feeds every spin block - the cross-spin Hartree coupling of open shell. -!> Side effect: leaves rho_ao_scratch(sigma) = OV-masked AO density (recomputed per spin in -!> update_effective_ham_MO; built here only to form the sum). -!> \param rtbse_env RT-BSE environment -!> \param rho_stage Per-spin MO density at the current RK4 stage -!> \param keep_ovvo .FALSE. = OV source mask (TDA); .TRUE. = OV+VO (open-shell ABBA). -!> \author Maximilian Graml -! ************************************************************************************************** - SUBROUTINE build_shared_hartree_ao(rtbse_env, rho_stage, keep_ovvo) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_stage - LOGICAL, INTENT(IN) :: keep_ovvo - - CHARACTER(len=*), PARAMETER :: routineN = 'build_shared_hartree_ao' - - INTEGER :: handle, isp - - CALL timeset(routineN, handle) - ! Per spin: mask the stage density and project to AO. - DO isp = 1, rtbse_env%n_spin - CALL cp_cfm_to_cfm(rho_stage(isp), rtbse_env%rho_delta_mo(isp)) - CALL mask_mo_block_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), isp, & - keep_OV=.TRUE., keep_ovvo=keep_ovvo) - CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), & - rtbse_env%rho_ao_scratch(isp), isp) - END DO - ! Sum: rho_total = spin_degeneracy * sum_isp rho_ao_scratch(isp). - CALL cp_cfm_set_all(rtbse_env%rho_total_ao_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - DO isp = 1, rtbse_env%n_spin - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_total_ao_scratch, & - CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), & - rtbse_env%rho_ao_scratch(isp)) - END DO - ! One complex Hartree contraction on the summed density. RI backend = kernel choice: both - ! get_hartree_complex and compute_hartree_ri_rs_complex take AO x AO in/out and are spin-blind, - ! so the spin-summed cross-spin density feeds whichever kernel is active. - IF (rtbse_env%rirs_kernel) THEN - ! V^H_λσ = sum_l φ_λ(r_l) v_l φ_σ(r_l), v_l = sum_l' V_ll' n_l'[ρ^total] (RI-RS) - CALL compute_hartree_ri_rs_complex(rtbse_env%bs_env, rtbse_env%rho_total_ao_scratch, & - rtbse_env%hartree_total_ao) - ELSE - ! V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) ρ^total_µν] (AO-RI) - CALL get_hartree_complex(rtbse_env, rtbse_env%rho_total_ao_scratch, & - rtbse_env%hartree_total_ao, 1) - END IF - CALL timestop(handle) - END SUBROUTINE build_shared_hartree_ao - -! ************************************************************************************************** -!> \brief Unified cross-spin kernel builder, once per RK4 stage for every shell. Computes the -!> per-spin SEX self-energy (stashed in sigma_SEX_ao(σ)) and the single shared bare Hartree -!> (hartree_total_ao), so update_effective_ham_MO only consumes them. -!> mask_mode selects the source-density convention (OV / OV+VO / full-ρ); it also determines -!> the input Hermiticity, which gates the Hartree imaginary channel: Im computed only when -!> mask_mode = kernel_input_ov (non-Hermitian TDA input); for Hermitian input Im ≡ 0 analytically -!> and is skipped. Hartree emitted BARE (no spin_degeneracy); consumer scales g on the MO output. -!> \param rtbse_env RT-BSE environment -!> \param rho_stage Per-spin MO density at the current RK4 stage -!> \param mask_mode Input-convention selector: kernel_input_ov / kernel_input_ovvo / kernel_input_full -!> \author Maximilian Graml -! ************************************************************************************************** - SUBROUTINE build_shared_sex_and_hartree(rtbse_env, rho_stage, mask_mode) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_stage - INTEGER, INTENT(IN) :: mask_mode - - CHARACTER(len=*), PARAMETER :: routineN = 'build_shared_sex_and_hartree' - - INTEGER :: handle, isp - LOGICAL :: harvest_im, use_hartree, & - use_rirs_kernel, use_sex - - CALL timeset(routineN, handle) - use_hartree = .NOT. rtbse_env%debug_disable_hartree - use_sex = .NOT. rtbse_env%debug_disable_sex - use_rirs_kernel = rtbse_env%rirs_kernel - ! Im channel iff the masked input is non-Hermitian (OV-only, TDA). For Hermitian input (OV+VO - ! or full ρ) Im(ρ) is antisymmetric and Coulomb factors are symmetric, so V_H[Im] ≡ 0. - harvest_im = (mask_mode == kernel_input_ov) - - ! Pre-zero the RI-RS spin-summed grid-diagonal accumulators (the SEX harvest target). - IF (use_rirs_kernel .AND. use_sex .AND. use_hartree) THEN - rtbse_env%hartree_diag_re(:) = 0.0_dp - IF (harvest_im) rtbse_env%hartree_diag_im(:) = 0.0_dp - END IF - ! Per spin: stage ρ into AO (masked per mask_mode); SEX (stash sigma_SEX_ao(σ)); RI-RS harvests - ! the diagonal. - DO isp = 1, rtbse_env%n_spin - CALL cp_cfm_to_cfm(rho_stage(isp), rtbse_env%rho_delta_mo(isp)) - SELECT CASE (mask_mode) - CASE (kernel_input_ov) - CALL mask_mo_block_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), isp, & - keep_OV=.TRUE., keep_ovvo=.FALSE.) - CASE (kernel_input_ovvo) - CALL mask_mo_block_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), isp, & - keep_OV=.TRUE., keep_ovvo=.TRUE.) - CASE (kernel_input_full) - ! no mask: full ρ (closed-shell ABBA; reference subtracted later via ham_reference) - CASE DEFAULT - CPABORT("Unknown mask_mode in build_shared_sex_and_hartree") - END SELECT - CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%rho_delta_mo(isp), & - rtbse_env%rho_ao_scratch(isp), isp) - IF (use_sex) THEN - ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ]. Im accumulator passed only - ! when harvesting; absent (unallocated optional) on AO-RI / Hartree-off / Hermitian. - IF (harvest_im) THEN - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(isp), -1.0_dp, rtbse_env%rho_ao_scratch(isp), & - grid_diag_re_accum=rtbse_env%hartree_diag_re, & - grid_diag_im_accum=rtbse_env%hartree_diag_im) - ELSE - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(isp), -1.0_dp, rtbse_env%rho_ao_scratch(isp), & - grid_diag_re_accum=rtbse_env%hartree_diag_re) - END IF - END IF - END DO - ! Shared cross-spin Hartree, emitted BARE (no spin_degeneracy — consumer scales g on output). - ! RI-RS reuses the spin-summed grid diagonal; AO-RI contracts rho_total = sum_σ ρ_σ. - ! Hermitian input: real Hartree path (Im ≡ 0); non-Hermitian: complex. - IF (use_hartree) THEN - IF (use_rirs_kernel .AND. use_sex) THEN - IF (harvest_im) THEN - CALL compute_hartree_ri_rs_from_diag(rtbse_env%bs_env, rtbse_env%hartree_diag_re, & - rtbse_env%hartree_total_ao, n_im=rtbse_env%hartree_diag_im) - ELSE - CALL compute_hartree_ri_rs_from_diag(rtbse_env%bs_env, rtbse_env%hartree_diag_re, & - rtbse_env%hartree_total_ao) - END IF - ELSE - CALL cp_cfm_set_all(rtbse_env%rho_total_ao_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - DO isp = 1, rtbse_env%n_spin - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_total_ao_scratch, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_ao_scratch(isp)) - END DO - IF (use_rirs_kernel) THEN - IF (harvest_im) THEN - CALL compute_hartree_ri_rs_complex(rtbse_env%bs_env, rtbse_env%rho_total_ao_scratch, & - rtbse_env%hartree_total_ao) - ELSE - ! Hermitian input: real RI-RS on Re(ρ_total) -> cfm with Im ≡ 0. - CALL cp_cfm_to_fm(msource=rtbse_env%rho_total_ao_scratch, & - mtargetr=rtbse_env%real_workspace(1)) - CALL compute_hartree_ri_rs(rtbse_env%bs_env, rtbse_env%real_workspace(1), & - rtbse_env%hartree_curr_ao(1)) - CALL cp_cfm_set_all(rtbse_env%hartree_total_ao, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_fm_to_cfm(msourcer=rtbse_env%hartree_curr_ao(1), & - mtarget=rtbse_env%hartree_total_ao) - END IF - ELSE - IF (harvest_im) THEN - CALL get_hartree_complex(rtbse_env, rtbse_env%rho_total_ao_scratch, & - rtbse_env%hartree_total_ao, 1) - ELSE - ! Hermitian input: real AO-RI on Re(ρ_total) -> cfm with Im ≡ 0. - CALL get_hartree(rtbse_env, rtbse_env%rho_total_ao_scratch, & - rtbse_env%hartree_curr_ao(1)) - CALL cp_cfm_set_all(rtbse_env%hartree_total_ao, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_fm_to_cfm(msourcer=rtbse_env%hartree_curr_ao(1), & - mtarget=rtbse_env%hartree_total_ao) - END IF - END IF - END IF - END IF - CALL timestop(handle) - END SUBROUTINE build_shared_sex_and_hartree - - ! ************************************************************************************************** -!> \brief Assembles the linearized RT-BSE right-hand side in the MO basis and returns it scaled by -i: -!> ham_effective <- -i( [H^0, ρ] + (f_n - f_m)(ΔΣ^SX[Δρ] + ΔV^H[Δρ]) ), i.e. the -!> f(t,ρ) of ∂_t Δρ_mn = -i( (ε_m - ε_n)Δρ_mn + (f_n - f_m)(V^H_mn + Σ^SX_mn) ). -!> ham_reference already carries KS+G0W0 minus the reference SEX/Hartree, so the kernels -!> enter as differences vs the reference. Forks: tda_active (drop B-coupling: one OV kernel -!> pass + VO conjugate) vs full ABBA (OV+VO); n_spin and the KERNEL_RI (rirs_kernel) flag -!> select the AO-RI or RI-RS backend per term. -!> \param rtbse_env Entry point of the calculation - contains current state of variables -!> \param rho Real and imaginary parts ( + spin) of the density at current time -!> \param ham_effective Effective Hamiltonian in the MO basis that is updated in this routine -!> \param ispin Spin channel σ being assembled -! ************************************************************************************************** - SUBROUTINE update_effective_ham_MO(rtbse_env, rho, ham_effective, ispin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type) :: rho, ham_effective - INTEGER :: ispin - - CHARACTER(len=*), PARAMETER :: routineN = 'update_effective_ham_MO' - - INTEGER :: handle, i_global, i_loc, j_global, & - j_loc, ncl, nrl - INTEGER, DIMENSION(:), POINTER :: c_idx, r_idx - LOGICAL :: use_hartree, use_sex - - CALL timeset(routineN, handle) - use_hartree = .NOT. rtbse_env%debug_disable_hartree - use_sex = .NOT. rtbse_env%debug_disable_sex - - ! Reset the effective Hamiltonian to KS Hamiltonian + G0W0 - reference SEX - reference Hartree - ! Sets the imaginary part to zero - CALL cp_cfm_to_cfm(rtbse_env%ham_reference(ispin), ham_effective) - ! [H^0, ρ]_mn = (ε_m - ε_n) ρ_mn exactly (H^0 diagonal in active-MO basis). Element-wise - ! local pass replacing the two gemms; ham_effective and rho share fm_struct_mo_active so - ! their local layouts coincide. Covers all (m,n) (OO/VV retained for closed-shell ABBA). - CALL cp_cfm_get_info(matrix=ham_effective, nrow_local=nrl, ncol_local=ncl, & - row_indices=r_idx, col_indices=c_idx) - DO j_loc = 1, ncl - j_global = c_idx(j_loc) - DO i_loc = 1, nrl - i_global = r_idx(i_loc) - ham_effective%local_data(i_loc, j_loc) = ham_effective%local_data(i_loc, j_loc) & - + CMPLX(rtbse_env%eps_active(i_global, ispin) - rtbse_env%eps_active(j_global, ispin), & - 0.0_dp, kind=dp)*rho%local_data(i_loc, j_loc) - END DO - END DO - ! Determine the field at current time - IF (rtbse_env%dft_control%apply_efield_field) THEN - CALL cp_abort(__LOCATION__, & - "Continuous/pulsed E(t) field coupling is not implemented for linearized "// & - "RT-BSE. Only the delta-kick (impulsive) absorption spectrum is supported; "// & - "use APPLY_DELTA_PULSE.") - ELSE - ! No field - rtbse_env%field(:) = 0.0_dp - END IF - IF (.NOT. rtbse_env%tda_active) THEN - ! ===== ABBA: consume the prebuilt per-spin SEX (sigma_SEX_ao(σ)) and shared bare Hartree - ! (hartree_total_ao). (f_n-f_m) zeros OO/VV and sets OV/VO signs. Closed shell uses full-ρ - ! input (no mask, reference subtracted via ham_reference); open shell uses OV+VO mask. ===== - IF (use_sex) THEN - ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ] - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), & - rtbse_env%sigma_SEX(ispin), ispin) - CALL transform_mo_occupation_factor_diff_cfm(rtbse_env, rtbse_env%sigma_SEX(ispin), ispin) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%sigma_SEX(ispin)) - END IF - IF (use_hartree) THEN - ! Builder emits bare V_H (no spin_degeneracy); fold g here (post-occ-factor). - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & - rtbse_env%ham_workspace(1), ispin) - CALL transform_mo_occupation_factor_diff_cfm(rtbse_env, rtbse_env%ham_workspace(1), ispin) - CALL cp_cfm_scale(CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) - END IF - ELSE - ! ----- TDA: drop B-coupling. Consume the OV-input kernels prebuilt by - ! build_shared_sex_and_hartree. K_MO[Δρ_VO] = (K_MO[Δρ_OV])^C (real C + symmetric AO kernels), - ! so evaluate on OV, mask MO to OV, add VO as conjugate transpose. - ! Signs: (f_n - f_m) = -1 on OV, +1 on VO; applied explicitly. ----- - - ! SEX: AO->MO, mask OV, stash (assembled after Hartree). - IF (use_sex) THEN - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), & - rtbse_env%sigma_SEX(ispin), ispin) - CALL mask_mo_block_cfm(rtbse_env, rtbse_env%sigma_SEX(ispin), ispin, keep_OV=.TRUE.) - END IF - - ! Hartree: hartree_total_ao is bare (no spin_degeneracy); fold g here (post-mask). - ! VO = (OV)^C; rho_delta_mo(ispin) is idle scratch. - IF (use_hartree) THEN - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & - rtbse_env%ham_workspace(1), ispin) - CALL mask_mo_block_cfm(rtbse_env, rtbse_env%ham_workspace(1), ispin, keep_OV=.TRUE.) - CALL cp_cfm_scale(CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1)) - CALL cp_cfm_transpose(rtbse_env%ham_workspace(1), 'C', rtbse_env%rho_delta_mo(ispin)) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_delta_mo(ispin)) - END IF - - ! SEX assembled (stashed sigma_SEX, OV-masked). OV sign -1; VO = (OV)^C sign +1. - IF (use_sex) THEN - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%sigma_SEX(ispin)) - CALL cp_cfm_transpose(rtbse_env%sigma_SEX(ispin), 'C', rtbse_env%rho_delta_mo(ispin)) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), ham_effective, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%rho_delta_mo(ispin)) - END IF - - ! Restore rho_ao_scratch to the AO image of the current full rho, so any - ! post-routine consumer (output_mos) sees the same invariant. - CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rho, rtbse_env%rho_ao_scratch(ispin), ispin) - END IF - ! Return the actual RHS f(t,rho) = -i * A(rho) for RK4 - CALL cp_cfm_scale(CMPLX(0.0_dp, -1.0_dp, kind=dp), ham_effective) - - CALL timestop(handle) - END SUBROUTINE update_effective_ham_MO - -! ************************************************************************************************** -!> \brief Single-spin Liouvillian matvec: apply L^sigma_sigma to one spin's Delta rho_MO and return -!> L * Delta rho_MO in MO basis, OV+VO blocks populated. Drives the n_spin=1 TDA diagnostic -!> and the (n_spin=1) ABBA diagnostic; the open-shell TDA path uses the array routine -!> apply_liouvillian_to_drho instead. Detached from the propagator (does NOT touch -!> rho / rho_orig / ham_effective / ham_reference); only env scratches drho_probe(ispin), -!> rho_ao_scratch, sigma_SEX_ao, hartree_total_ao, ham_workspace(1), sigma_SEX, -!> rho_delta_mo(ispin), real_workspace_mo(1) are used. -!> -!> Matrix elements correspond to the Casida-A matrix: -!> L_{ia,jb} = (eps_a - eps_i) delta_{ij} delta_{ab} + (ia|jb) - W_{ij,ab} -!> with no (f_n - f_m) factor (the propagator path applies -1 on OV; we want raw +K). -!> Honors rtbse_env%rirs_kernel to dispatch Hartree to the RI-RS grid kernel -!> (compute_hartree_ri_rs_complex); the SX RI-RS dispatch also reads rirs_kernel inside get_sigma. -!> AO-RI path: get_hartree_complex / get_sigma. -!> -!> \param rtbse_env RT-BSE environment (TDA, n_spin=1). -!> \param drho_in Input Delta rho_MO (mo_active x mo_active complex). -!> \param L_drho_out Output L * Delta rho_MO; OV+VO blocks populated; OO/VV zero. -!> \param ispin Spin index. -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** - SUBROUTINE apply_liouvillian_to_drho_spin(rtbse_env, drho_in, L_drho_out, ispin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), INTENT(IN) :: drho_in - TYPE(cp_cfm_type), INTENT(INOUT) :: L_drho_out - INTEGER, INTENT(IN) :: ispin - - CHARACTER(len=*), PARAMETER :: routineN = 'apply_liouvillian_to_drho_spin' - - INTEGER :: abs_mo_idx, handle, i_row_global, ii, & - j_col_global, jj, ncol_local, & - nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - LOGICAL :: use_hartree, use_sex - - CALL timeset(routineN, handle) - - ! Mirror update_effective_ham_MO kernel gating: only Hartree + SX are gated - ! (no COH kernel in linRTBSE). - use_hartree = .NOT. rtbse_env%debug_disable_hartree - use_sex = .NOT. rtbse_env%debug_disable_sex - ! RI-RS dispatch reads rtbse_env%rirs_kernel directly below. - ! V_grid / W0_grid are populated by initialize_hartree_potential / - ! initialize_sex_selfenergy, which run before this diagnostic. - - ! 1. Stage drho_in into drho_probe. TDA: mask to OV (propagator carries only OV - ! and the VO contribution is recovered later via the (.)^C shortcut). ABBA: keep - ! the full OV+VO content - drho_in carries both blocks independently. - CALL cp_cfm_to_cfm(drho_in, rtbse_env%drho_probe(ispin)) - IF (rtbse_env%tda_active) THEN - CALL mask_mo_block_cfm(rtbse_env, rtbse_env%drho_probe(ispin), ispin, keep_OV=.TRUE.) - END IF - - ! 2. Project Delta rho_OV (MO -> AO, contravariant). - CALL transform_mo_to_ao_contravariant_cfm(rtbse_env, rtbse_env%drho_probe(ispin), & - rtbse_env%rho_ao_scratch(ispin), ispin) - - ! 3. Initialize the output accumulator. - CALL cp_cfm_set_all(L_drho_out, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - - ! 4. eps_{ai} diagonal contribution, kept before the kernel steps (5/6). drho_in aliases - ! rtbse_env%drho_probe(ispin) at the caller; the kernels' VO Hermitian-conjugate scratch - ! is rho_delta_mo(ispin) (NOT drho_probe), so they no longer corrupt drho_in - but eps - ! first is the clean ordering. Build H_eps as a real diagonal fm in real_workspace_mo(1), - ! convert to cfm in ham_workspace(1), accumulate [drho_in, H_eps] = drho * H - H * drho. - ! On OV: ([drho, H])_{ia} = (eps_a - eps_i) * drho_{ia} = +eps_{ai} * drho_{ia}. - ! On VO: -eps_{ai} * drho_{ai} (sign flips); irrelevant - driver only reads OV. - ! Bare GW eigenvalues (lab frame) so eigenvalues compare 1:1 to bse_full.F. - CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) - DO ii = 1, nrow_local - i_row_global = row_indices(ii) - DO jj = 1, ncol_local - j_col_global = col_indices(jj) - IF (i_row_global == j_col_global) THEN - abs_mo_idx = i_row_global + rtbse_env%first_active_mo - 1 - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & - rtbse_env%bs_env%eigenval_G0W0(abs_mo_idx, 1, ispin) - END IF - END DO - END DO - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & - mtarget=rtbse_env%ham_workspace(1)) - ! drho * H_eps - CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), drho_in, rtbse_env%ham_workspace(1), & - CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out) - ! -H_eps * drho - CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1), drho_in, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out) - - ! 5. Hartree contribution: get_hartree_complex (Re/Im split) on AO Delta rho, then - ! AO->MO covariant, mask OV+VO, accumulate +spin_degeneracy on OV and on VO. - ! No (f_n - f_m) factor: we want raw +K (Casida convention), not the propagator's -K_OV. - ! VO contribution comes from the Hermitian conjugate of the OV result (P2 in - ! rt_bse_pitfalls_physics.md): for real C_active + AO-pair-symmetric kernel, - ! K_MO[Delta rho_VO] = (K_MO[Delta rho_OV])^C. - IF (use_hartree) THEN - IF (rtbse_env%rirs_kernel) THEN - ! V^H_λσ = sum_l φ_λ(r_l) v_l φ_σ(r_l), v_l = sum_l' V_ll' n_l' (RI-RS) - CALL compute_hartree_ri_rs_complex(rtbse_env%bs_env, rtbse_env%rho_ao_scratch(ispin), & - rtbse_env%hartree_total_ao) - ELSE - ! V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) Δρ_µν] (AO-RI) - CALL get_hartree_complex(rtbse_env, rtbse_env%rho_ao_scratch(ispin), & - rtbse_env%hartree_total_ao, ispin) - END IF - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & - rtbse_env%ham_workspace(1), ispin) - CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%ham_workspace(1), L_drho_out, & - CMPLX(rtbse_env%spin_degeneracy, 0.0_dp, kind=dp), ispin) - END IF - - ! 6. Screened-exchange contribution: get_sigma is already complex-aware. The - ! -1.0_dp factor passed to get_sigma builds the -W contribution; we then add - ! +1.0 here (no occupation-factor flip), giving raw K^SX = -W as required by - ! K = (ia|jb) - W_{ij,ab} (Casida convention with +K). - IF (use_sex) THEN - ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ] - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), -1.0_dp, rtbse_env%rho_ao_scratch(ispin)) - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(ispin), & - rtbse_env%sigma_SEX(ispin), ispin) - CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%sigma_SEX(ispin), L_drho_out, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), ispin) - END IF - - CALL timestop(handle) - END SUBROUTINE apply_liouvillian_to_drho_spin - -! ************************************************************************************************** -!> \brief Adds the MO-domain kernel contribution K_MO * Delta rho to L_drho_out, branching on -!> rtbse_env%tda_active. TDA: masks K_MO to OV in place, adds scale*K_MO on OV, then -!> builds the VO contribution as (K_MO_OV)^C and adds it (valid only under the TDA -!> assumption Delta rho_VO = (Delta rho_OV)^C). ABBA: adds the full mo_active x mo_active -!> K_MO directly - OV+VO blocks are computed naturally from the full OV+VO input. -!> K_MO is INTENT(INOUT); in the TDA branch it is masked in place (treat as scratch -!> after this call). rho_delta_mo(ispin) is used as the VO-transpose scratch in the TDA -!> branch (NOT drho_probe, which the open-shell array driver keeps as the live probe). -!> \param rtbse_env RT-BSE environment. -!> \param K_MO Kernel contribution in MO basis (mo_active x mo_active). Scratched in TDA branch. -!> \param L_drho_out Accumulator (mo_active x mo_active). -!> \param scale Complex scale factor (spin_degeneracy for Hartree, 1.0 for SX). -!> \param ispin Spin index. -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** - SUBROUTINE add_K_MO_to_L_drho(rtbse_env, K_MO, L_drho_out, scale, ispin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), INTENT(INOUT) :: K_MO, L_drho_out - COMPLEX(kind=dp), INTENT(IN) :: scale - INTEGER, INTENT(IN) :: ispin - - CHARACTER(len=*), PARAMETER :: routineN = 'add_K_MO_to_L_drho' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - IF (rtbse_env%tda_active) THEN - CALL mask_mo_block_cfm(rtbse_env, K_MO, ispin, keep_OV=.TRUE.) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out, scale, K_MO) - CALL cp_cfm_transpose(K_MO, 'C', rtbse_env%rho_delta_mo(ispin)) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out, scale, rtbse_env%rho_delta_mo(ispin)) - ELSE - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out, scale, K_MO) - END IF - - CALL timestop(handle) - END SUBROUTINE add_K_MO_to_L_drho - -! ************************************************************************************************** -!> \brief Open-shell TDA Liouvillian matvec: apply the joint spin-block L_TDA to a per-spin probe -!> and return L * Delta rho on every spin block. A probe on spin sigma feeds the diagonal -!> block A^{sigma,sigma} (eps + Coulomb + SX) AND the off-diagonal Coulomb block -!> A^{sigma',sigma} for every other output spin sigma' (cross-spin Hartree - the term that -!> produces the singlet/triplet split). AO-RI only: the Phase-D guard forbids RIRS -!> for n_spin>1, so there is no RIRS branch here; the n_spin=1 diagnostic routes -!> through apply_liouvillian_to_drho_spin instead (which keeps the RIRS path). -!> \param rtbse_env RT-BSE environment (TDA). -!> \param drho_in Per-spin probe Delta rho_MO (mo_active x mo_active each); zero on non-probed spins. -!> \param L_drho_out Per-spin output L * Delta rho; OV+VO blocks populated, OO/VV zero. -!> \author Maximilian Graml -! ************************************************************************************************** - SUBROUTINE apply_liouvillian_to_drho(rtbse_env, drho_in, L_drho_out) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: drho_in, L_drho_out - - CHARACTER(len=*), PARAMETER :: routineN = 'apply_liouvillian_to_drho' - - INTEGER :: abs_mo_idx, handle, i_row_global, ii, & - isp, isp_out, j_col_global, jj, & - ncol_local, nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - LOGICAL :: use_hartree, use_sex - - CALL timeset(routineN, handle) - - use_hartree = .NOT. rtbse_env%debug_disable_hartree - use_sex = .NOT. rtbse_env%debug_disable_sex - - ! Zero every output spin block before accumulating. - DO isp = 1, rtbse_env%n_spin - CALL cp_cfm_set_all(L_drho_out(isp), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - - ! eps^sigma commutator -> diagonal block only (eps is spin-diagonal). MUST precede the - ! kernel steps (add_K_MO_to_L_drho scratches MO buffers). Lab-frame bare GW eigenvalues - ! so they compare 1:1 to bse_full_diag.F. - CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - DO isp = 1, rtbse_env%n_spin - CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) - DO ii = 1, nrow_local - i_row_global = row_indices(ii) - DO jj = 1, ncol_local - j_col_global = col_indices(jj) - IF (i_row_global == j_col_global) THEN - abs_mo_idx = i_row_global + rtbse_env%first_active_mo - 1 - rtbse_env%real_workspace_mo(1)%local_data(ii, jj) = & - rtbse_env%bs_env%eigenval_G0W0(abs_mo_idx, 1, isp) - END IF - END DO - END DO - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & - mtarget=rtbse_env%ham_workspace(1)) - ! [drho, H_eps] = drho * H_eps - H_eps * drho - CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), drho_in(isp), rtbse_env%ham_workspace(1), & - CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out(isp)) - CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%ham_workspace(1), drho_in(isp), & - CMPLX(1.0_dp, 0.0_dp, kind=dp), L_drho_out(isp)) - END DO - - ! Project per-spin OV-masked rho_ao(sigma) (consumed by SX) and build the single cross-spin - ! Hartree V_H[spin_degeneracy * sum_sigma rho_ao(sigma)] (Coulomb is spin-blind). - ! build_shared_hartree_ao does both; skip only when neither kernel is active. - IF (use_hartree .OR. use_sex) THEN - CALL build_shared_hartree_ao(rtbse_env, drho_in, keep_ovvo=.FALSE.) - END IF - - ! Hartree: the one shared V_H read back with each output spin's C fills the diagonal - ! A^{sigma,sigma} AND the off-diagonal A^{sigma',sigma}. Coeff 1.0 (spin_degeneracy lives in - ! the summed density); no (f_n - f_m) factor (Casida +K convention). - IF (use_hartree) THEN - DO isp_out = 1, rtbse_env%n_spin - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%hartree_total_ao, & - rtbse_env%ham_workspace(1), isp_out) - CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%ham_workspace(1), L_drho_out(isp_out), & - CMPLX(1.0_dp, 0.0_dp, kind=dp), isp_out) - END DO - END IF - - ! Screened exchange: spin-diagonal (W^sigma acts only within spin sigma). get_sigma builds - ! -W; add raw +1 (no occupation-factor flip), giving K^SX = -W. - IF (use_sex) THEN - DO isp = 1, rtbse_env%n_spin - ! Σ^SX_λσ = -sum_νQ [sum_µ (λµ|Q) Δρ_µν][sum_P (νσ|P) W_PQ] (per spin) - CALL get_sigma(rtbse_env, rtbse_env%sigma_SEX_ao(isp), -1.0_dp, rtbse_env%rho_ao_scratch(isp)) - CALL transform_ao_to_mo_covariant_cfm(rtbse_env, rtbse_env%sigma_SEX_ao(isp), & - rtbse_env%sigma_SEX(isp), isp) - CALL add_K_MO_to_L_drho(rtbse_env, rtbse_env%sigma_SEX(isp), L_drho_out(isp), & - CMPLX(1.0_dp, 0.0_dp, kind=dp), isp) - END DO - END IF - - CALL timestop(handle) - END SUBROUTINE apply_liouvillian_to_drho - -! ************************************************************************************************** -!> \brief Public entry for the Liouvillian eigenvalue diagnostic. -!> Dispatches to the TDA branch (Casida-A via cp_cfm_heevd) or the ABBA branch -!> (Furche reduction via cp_cfm_power) based on rtbse_env%tda_active. -!> Called once at job init from run_propagation_linearized_bse, gated on -!> rtbse_env%diagnose_liouvillian_eig (n_spin = 1 enforced at env creation). -!> \param rtbse_env RT-BSE environment with diagnostic scratch already allocated. -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** - SUBROUTINE diagnose_liouvillian_eigenvalues(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'diagnose_liouvillian_eigenvalues' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - IF (rtbse_env%tda_active) THEN - CALL diagnose_TDA_liouvillian(rtbse_env) - ELSE - CALL diagnose_ABBA_liouvillian(rtbse_env) - END IF - - CALL timestop(handle) - END SUBROUTINE diagnose_liouvillian_eigenvalues - -! ************************************************************************************************** -!> \brief TDA branch of the Liouvillian eigenvalue diagnostic. Probes the Liouvillian with -!> canonical OV unit vectors and assembles the joint spin-block Casida-A matrix as L_pairs -!> (N_OV_joint x N_OV_joint, spin blocks stacked), then diagonalizes via cp_cfm_heevd. -!> A probe on spin sigma fills its column block and the response on every output spin lands -!> in that spin's row block (the off-diagonal blocks carry the cross-spin Coulomb that -!> splits singlet/triplet). The matvec is dispatched on n_spin: n_spin=1 uses the -!> single-spin apply_liouvillian_to_drho_spin (keeps the RIRS path, bit-identical to the -!> closed-shell baseline); n_spin=2 uses the AO-RI array apply_liouvillian_to_drho. -!> Eigenvalues go to stdout (RTBSE|) and to the LIOUVILLIAN_EIG .dat file. Detached from -!> RK4 state. Called from the dispatcher when tda_active=.TRUE. -!> \param rtbse_env RT-BSE environment with TDA diagnostic scratch already allocated. -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** - SUBROUTINE diagnose_TDA_liouvillian(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'diagnose_TDA_liouvillian' - - COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: ov_block - INTEGER :: b, eig_unit, handle, j, k_col, k_local, & - n, n_ov_joint, sigma_out, sigma_probe - INTEGER, ALLOCATABLE, DIMENSION(:) :: n_act_occ, n_act_virt, n_ov, off - REAL(kind=dp) :: residual_max - TYPE(cp_logger_type), POINTER :: logger - - CALL timeset(routineN, handle) - logger => cp_get_default_logger() - - ! Per-spin OV counts + offsets into the stacked joint Liouvillian. off(1)=0, - ! off(2)=n_ov(1); n_ov_joint = sum_sigma n_ov(sigma). n_spin=1 -> single block. - ALLOCATE (n_act_occ(rtbse_env%n_spin), n_act_virt(rtbse_env%n_spin), & - n_ov(rtbse_env%n_spin), off(rtbse_env%n_spin)) - n_ov_joint = 0 - DO sigma_probe = 1, rtbse_env%n_spin - n_act_occ(sigma_probe) = rtbse_env%n_occ(sigma_probe) - rtbse_env%first_active_mo + 1 - n_act_virt(sigma_probe) = rtbse_env%last_active_mo - rtbse_env%n_occ(sigma_probe) - n_ov(sigma_probe) = n_act_occ(sigma_probe)*n_act_virt(sigma_probe) - off(sigma_probe) = n_ov_joint - n_ov_joint = n_ov_joint + n_ov(sigma_probe) - END DO - - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE| ----- TDA Liouvillian diagnostic -----' - WRITE (rtbse_env%unit_nr, '(A,I0,A,I0)') & - ' RTBSE| n_spin = ', rtbse_env%n_spin, ', joint N_OV = ', n_ov_joint - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' - END IF - - ! Single joint block to the .dat file (REWIND). ignore_should_output=.TRUE. so this fires - ! at init regardless of MD-iteration cadence. - eig_unit = cp_print_key_unit_nr(logger, rtbse_env%eig_section, & - extension=".dat", & - file_form="FORMATTED", & - file_position="REWIND", & - ignore_should_output=.TRUE.) - IF (eig_unit > 0) THEN - WRITE (eig_unit, '(A)') '# Joint spin-block TDA Liouvillian eigenvalues' - IF (rtbse_env%n_spin == 1) THEN - WRITE (eig_unit, '(A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, ', N_OV = ', n_ov(1) - ELSE - WRITE (eig_unit, '(A,I0,A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, & - ', N_OV(1) = ', n_ov(1), ', N_OV(2) = ', n_ov(2) - END IF - END IF - - ! Assemble the joint Casida-A matrix. A probe on spin sigma_probe with canonical OV unit - ! vector e_{(j,b)} fills column off(sigma_probe)+k_local; the response on each output spin - ! sigma_out lands in its row block [off(sigma_out)+1 .. +n_ov(sigma_out)]. Block-level - ! transfers keep this at O(N_OV_joint) collective ops. Column-major OV index - ! k_local = (b_local-1)*n_act_occ + j_local matches the Fortran layout of ov_block, so - ! RESHAPE without padding gives the right (n_ov, 1) column. - DO sigma_probe = 1, rtbse_env%n_spin - DO b = rtbse_env%n_occ(sigma_probe) + 1, rtbse_env%last_active_mo - DO j = rtbse_env%first_active_mo, rtbse_env%n_occ(sigma_probe) - k_local = (b - rtbse_env%n_occ(sigma_probe) - 1)*n_act_occ(sigma_probe) + & - (j - rtbse_env%first_active_mo + 1) - k_col = off(sigma_probe) + k_local - - DO sigma_out = 1, rtbse_env%n_spin - CALL cp_cfm_set_all(rtbse_env%drho_probe(sigma_out), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - CALL cp_cfm_set_element(rtbse_env%drho_probe(sigma_probe), & - j - rtbse_env%first_active_mo + 1, & - b - rtbse_env%first_active_mo + 1, & - CMPLX(1.0_dp, 0.0_dp, kind=dp)) - - ! n_spin=1 keeps the single-spin matvec (RIRS-capable, bit-identical baseline); - ! n_spin=2 is AO-RI-only (Phase-D guard) -> cross-spin array matvec. - IF (rtbse_env%n_spin == 1) THEN - CALL apply_liouvillian_to_drho_spin(rtbse_env, rtbse_env%drho_probe(1), & - rtbse_env%L_drho(1), 1) - ELSE - CALL apply_liouvillian_to_drho(rtbse_env, rtbse_env%drho_probe, rtbse_env%L_drho) - END IF - - ! Stack each output spin's OV response into the joint column. - DO sigma_out = 1, rtbse_env%n_spin - ALLOCATE (ov_block(n_act_occ(sigma_out), n_act_virt(sigma_out))) - CALL cp_cfm_get_submatrix(rtbse_env%L_drho(sigma_out), ov_block, & - start_row=1, start_col=n_act_occ(sigma_out) + 1, & - n_rows=n_act_occ(sigma_out), n_cols=n_act_virt(sigma_out)) - CALL cp_cfm_set_submatrix(rtbse_env%L_pairs, & - RESHAPE(ov_block, [n_ov(sigma_out), 1]), & - start_row=off(sigma_out) + 1, start_col=k_col, & - n_rows=n_ov(sigma_out), n_cols=1) - DEALLOCATE (ov_block) - END DO - END DO - END DO - END DO - - ! Hermitian residual on the joint matrix: real-orbital BSE => L real symmetric, so - ! ||L - L^H||_max should be at the FP floor. D = L^H - L into eigvecs_pairs (idle here; - ! heevd overwrites it), then its max-element norm via the BLACS-native pzlange path. - CALL cp_cfm_transpose(rtbse_env%L_pairs, 'C', rtbse_env%eigvecs_pairs) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%eigvecs_pairs, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%L_pairs) - residual_max = cp_cfm_norm(rtbse_env%eigvecs_pairs, 'M') - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A,ES16.6)') & - ' RTBSE| Hermitian residual ||L - L^H||_max = ', residual_max - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' - END IF - IF (residual_max > 1.0E-6_dp) THEN - CPABORT("Liouvillian Hermitian residual > 1e-6 - check kernel signs / symmetry.") - END IF - - ! Diagonalize the joint matrix. cp_cfm_heevd returns ascending real eigenvalues. - CALL cp_cfm_heevd(rtbse_env%L_pairs, rtbse_env%eigvecs_pairs, & - rtbse_env%eigenvalues_liouvillian) - - ! Stdout table (eV, F12.4 right-aligned to col 80, L-7) + .dat (a.u. + eV). - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A,T26,A,T59,A)') & - ' RTBSE|', "Excitation index n", "Excitation energy (eV)" - DO n = 1, n_ov_joint - WRITE (rtbse_env%unit_nr, '(A,T40,I4,T69,F12.4)') & - ' RTBSE|', n, rtbse_env%eigenvalues_liouvillian(n)*evolt - END DO - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' - END IF - IF (eig_unit > 0) THEN - WRITE (eig_unit, '(A)') '# n Omega [a.u.] Omega [eV]' - DO n = 1, n_ov_joint - WRITE (eig_unit, '(I5,4X,ES24.14E3,4X,ES24.14E3)') n, & - rtbse_env%eigenvalues_liouvillian(n), & - rtbse_env%eigenvalues_liouvillian(n)*evolt - END DO - END IF - - CALL cp_print_key_finished_output(eig_unit, logger, rtbse_env%eig_section) - - DEALLOCATE (n_act_occ, n_act_virt, n_ov, off) - - CALL timestop(handle) - END SUBROUTINE diagnose_TDA_liouvillian - -! ************************************************************************************************** -!> \brief ABBA branch of the Liouvillian eigenvalue diagnostic. Assembles the joint spin-block -!> A and B by probing apply_liouvillian_to_drho with canonical OV unit vectors: a probe on -!> spin sigma_probe fills joint column off(sigma_probe)+k_local; each output spin's OV -!> response -> A, VO response -> -B^* (recovered by sign-flip + conjugation). One joint -!> Furche reduction follows: (A-B)>0 gate (independent cp_cfm_heevd), (A-B)^{1/2} via -!> cp_cfm_power, C = (A-B)^{1/2}(A+B)(A-B)^{1/2}, cp_cfm_heevd, Ω_n = √(C). The -!> matvec is dispatched on n_spin: n_spin=1 -> apply_liouvillian_to_drho_spin (RIRS-capable, -!> bit-identical to the closed-shell baseline); n_spin=2 -> the AO-RI cross-spin array -!> apply_liouvillian_to_drho. For n_spin=1 the routine reduces to the single-block path. -!> Output: a single joint spectrum (stdout RTBSE| + LIOUVILLIAN_EIG .dat). All eigenvalues -!> are retained, including optically dark triplet modes (the kernel-correctness gate). -!> \param rtbse_env RT-BSE environment with ABBA diagnostic scratch allocated. -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** - SUBROUTINE diagnose_ABBA_liouvillian(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'diagnose_ABBA_liouvillian' - - COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: ov_block, vo_block - COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: B_local - INTEGER :: b, eig_unit, handle, j, k_col, k_local, & - n, n_ov_joint, sigma_out, sigma_probe - INTEGER, ALLOCATABLE, DIMENSION(:) :: n_act_occ, n_act_virt, n_ov, off - REAL(kind=dp) :: lambda_min_AmB, residual_A, residual_B - TYPE(cp_logger_type), POINTER :: logger - - CALL timeset(routineN, handle) - logger => cp_get_default_logger() - - ! Per-spin OV counts + offsets into the stacked joint A/B (same layout as the TDA - ! diagnostic). off(1)=0, off(2)=n_ov(1); n_ov_joint = sum_sigma n_ov(sigma). For - ! n_spin=1 this is the single block, bit-identical to the closed-shell ABBA path. - ALLOCATE (n_act_occ(rtbse_env%n_spin), n_act_virt(rtbse_env%n_spin), & - n_ov(rtbse_env%n_spin), off(rtbse_env%n_spin)) - n_ov_joint = 0 - DO sigma_probe = 1, rtbse_env%n_spin - n_act_occ(sigma_probe) = rtbse_env%n_occ(sigma_probe) - rtbse_env%first_active_mo + 1 - n_act_virt(sigma_probe) = rtbse_env%last_active_mo - rtbse_env%n_occ(sigma_probe) - n_ov(sigma_probe) = n_act_occ(sigma_probe)*n_act_virt(sigma_probe) - off(sigma_probe) = n_ov_joint - n_ov_joint = n_ov_joint + n_ov(sigma_probe) - END DO - - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE| ----- ABBA Liouvillian diagnostic -----' - WRITE (rtbse_env%unit_nr, '(A,I0,A,I0)') & - ' RTBSE| n_spin = ', rtbse_env%n_spin, ', joint N_OV = ', n_ov_joint - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' - END IF - - eig_unit = cp_print_key_unit_nr(logger, rtbse_env%eig_section, & - extension=".dat", & - file_form="FORMATTED", & - file_position="REWIND", & - ignore_should_output=.TRUE.) - IF (eig_unit > 0) THEN - WRITE (eig_unit, '(A)') '# Joint spin-block ABBA Liouvillian eigenvalues' - IF (rtbse_env%n_spin == 1) THEN - WRITE (eig_unit, '(A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, ', N_OV = ', n_ov(1) - ELSE - WRITE (eig_unit, '(A,I0,A,I0,A,I0)') '# n_spin = ', rtbse_env%n_spin, & - ', N_OV(1) = ', n_ov(1), ', N_OV(2) = ', n_ov(2) - END IF - END IF - - ! Assemble joint A and B. Probe on spin sigma_probe, OV pair (j,b) -> joint column - ! k_col = off(sigma_probe)+k_local (column-major k_local, as TDA). Each output spin's - ! OV response -> A rows [off(sigma_out)+1 ..]; VO response -> B rows (TRANSPOSE to OV - ! layout), recovered as -B^* below. The n_spin=2 array matvec produces the full OV+VO - ! readout (add_K_MO_to_L_drho .NOT.tda_active branch); one cross-spin Hartree fills - ! both A^{s,s'} and B^{s,s'} Coulomb; SX stays spin-diagonal. - DO sigma_probe = 1, rtbse_env%n_spin - DO b = rtbse_env%n_occ(sigma_probe) + 1, rtbse_env%last_active_mo - DO j = rtbse_env%first_active_mo, rtbse_env%n_occ(sigma_probe) - k_local = (b - rtbse_env%n_occ(sigma_probe) - 1)*n_act_occ(sigma_probe) + & - (j - rtbse_env%first_active_mo + 1) - k_col = off(sigma_probe) + k_local - - DO sigma_out = 1, rtbse_env%n_spin - CALL cp_cfm_set_all(rtbse_env%drho_probe(sigma_out), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - CALL cp_cfm_set_element(rtbse_env%drho_probe(sigma_probe), & - j - rtbse_env%first_active_mo + 1, & - b - rtbse_env%first_active_mo + 1, & - CMPLX(1.0_dp, 0.0_dp, kind=dp)) - - IF (rtbse_env%n_spin == 1) THEN - CALL apply_liouvillian_to_drho_spin(rtbse_env, rtbse_env%drho_probe(1), & - rtbse_env%L_drho(1), 1) - ELSE - CALL apply_liouvillian_to_drho(rtbse_env, rtbse_env%drho_probe, rtbse_env%L_drho) - END IF - - DO sigma_out = 1, rtbse_env%n_spin - ALLOCATE (ov_block(n_act_occ(sigma_out), n_act_virt(sigma_out))) - ALLOCATE (vo_block(n_act_virt(sigma_out), n_act_occ(sigma_out))) - CALL cp_cfm_get_submatrix(rtbse_env%L_drho(sigma_out), ov_block, & - start_row=1, start_col=n_act_occ(sigma_out) + 1, & - n_rows=n_act_occ(sigma_out), n_cols=n_act_virt(sigma_out)) - CALL cp_cfm_set_submatrix(rtbse_env%A_mat, & - RESHAPE(ov_block, [n_ov(sigma_out), 1]), & - start_row=off(sigma_out) + 1, start_col=k_col, & - n_rows=n_ov(sigma_out), n_cols=1) - ! TRANSPOSE puts vo_block in (n_act_occ, n_act_virt) layout, matching the OV pack. - CALL cp_cfm_get_submatrix(rtbse_env%L_drho(sigma_out), vo_block, & - start_row=n_act_occ(sigma_out) + 1, start_col=1, & - n_rows=n_act_virt(sigma_out), n_cols=n_act_occ(sigma_out)) - CALL cp_cfm_set_submatrix(rtbse_env%B_mat, & - RESHAPE(TRANSPOSE(vo_block), [n_ov(sigma_out), 1]), & - start_row=off(sigma_out) + 1, start_col=k_col, & - n_rows=n_ov(sigma_out), n_cols=1) - DEALLOCATE (ov_block, vo_block) - END DO - END DO - END DO - END DO - - ! Recover B from -B^* via rank-local pass on the cfm's MPI-local data (documented - ! exception to the fm/cfm-routines-only rule); B_recovered = -CONJG(stored). - B_local => rtbse_env%B_mat%local_data - B_local = -CONJG(B_local) - - ! Block-symmetry residuals on the JOINT matrices: A Hermitian, B real-symmetric. - CALL cp_cfm_transpose(rtbse_env%A_mat, 'C', rtbse_env%eigvecs_pairs) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%eigvecs_pairs, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%A_mat) - residual_A = cp_cfm_norm(rtbse_env%eigvecs_pairs, 'M') - - CALL cp_cfm_transpose(rtbse_env%B_mat, 'T', rtbse_env%eigvecs_pairs) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%eigvecs_pairs, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%B_mat) - residual_B = cp_cfm_norm(rtbse_env%eigvecs_pairs, 'M') - - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A,ES16.6)') & - ' RTBSE| Hermitian residual ||A - A^H||_max = ', residual_A - WRITE (rtbse_env%unit_nr, '(A,ES16.6)') & - ' RTBSE| Symmetry residual ||B - B^T||_max = ', residual_B - END IF - IF (residual_A > 1.0E-6_dp) THEN - CPABORT("A is not Hermitian within 1e-6 - check kernel signs / symmetry.") - END IF - IF (residual_B > 1.0E-6_dp) THEN - CPABORT("B is not symmetric within 1e-6 - check kernel signs / symmetry.") - END IF - - ! A +/- B in scratches (both Hermitian). - CALL cp_cfm_to_cfm(rtbse_env%A_mat, rtbse_env%AmB_scratch) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%AmB_scratch, & - CMPLX(-1.0_dp, 0.0_dp, kind=dp), rtbse_env%B_mat) - CALL cp_cfm_to_cfm(rtbse_env%A_mat, rtbse_env%ApB_scratch) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%ApB_scratch, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), rtbse_env%B_mat) - - ! (A-B) positivity gate on the joint matrix: heevd on a copy; abort if lambda_min < 0. - CALL cp_cfm_to_cfm(rtbse_env%AmB_scratch, rtbse_env%L_pairs) - CALL cp_cfm_heevd(rtbse_env%L_pairs, rtbse_env%eigvecs_pairs, rtbse_env%eigenvalues_liouvillian) - lambda_min_AmB = rtbse_env%eigenvalues_liouvillian(1) - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A,ES16.6,A,F12.6,A)') & - ' RTBSE| lambda_min(A - B) = ', & - lambda_min_AmB, ' a.u. (', lambda_min_AmB*evolt, ' eV)' - END IF - ! Hard abort by design: a non-positive (A-B) breaks the Furche reduction. - IF (lambda_min_AmB < 0.0_dp) THEN - CALL cp_abort(__LOCATION__, & - "(A - B) not positive definite - this may hint at a triplet or "// & - "charge-transfer instability of the reference state.") - END IF - - ! In-place AmB_scratch -> (A-B)^{1/2} via cp_cfm_power. threshold=0 substitution - ! codepath is unreachable here (lambda_min_AmB > 0 already enforced above). - CALL cp_cfm_power(rtbse_env%AmB_scratch, threshold=0.0_dp, exponent=0.5_dp) - - ! C = (A-B)^{1/2}(A+B)(A-B)^{1/2}. B_mat free after step "A+/-B" -> reuse as T scratch. - CALL cp_cfm_gemm('N', 'N', n_ov_joint, n_ov_joint, n_ov_joint, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), & - rtbse_env%AmB_scratch, rtbse_env%ApB_scratch, & - CMPLX(0.0_dp, 0.0_dp, kind=dp), & - rtbse_env%B_mat) - CALL cp_cfm_gemm('N', 'N', n_ov_joint, n_ov_joint, n_ov_joint, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), & - rtbse_env%B_mat, rtbse_env%AmB_scratch, & - CMPLX(0.0_dp, 0.0_dp, kind=dp), & - rtbse_env%L_pairs) - - ! Diagonalize C -> Ω_n^2; take +√. Safety clamp on tiny-negative noise. - CALL cp_cfm_heevd(rtbse_env%L_pairs, rtbse_env%eigvecs_pairs, rtbse_env%eigenvalues_liouvillian) - DO n = 1, n_ov_joint - IF (rtbse_env%eigenvalues_liouvillian(n) < 0.0_dp) THEN - rtbse_env%eigenvalues_liouvillian(n) = 0.0_dp - ELSE - rtbse_env%eigenvalues_liouvillian(n) = SQRT(rtbse_env%eigenvalues_liouvillian(n)) - END IF - END DO - - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' - WRITE (rtbse_env%unit_nr, '(A,T26,A,T59,A)') & - ' RTBSE|', "Excitation index n", "Excitation energy (eV)" - DO n = 1, n_ov_joint - WRITE (rtbse_env%unit_nr, '(A,T40,I4,T69,F12.4)') & - ' RTBSE|', n, rtbse_env%eigenvalues_liouvillian(n)*evolt - END DO - WRITE (rtbse_env%unit_nr, '(A)') ' RTBSE|' - END IF - IF (eig_unit > 0) THEN - WRITE (eig_unit, '(A)') '# n Omega [a.u.] Omega [eV]' - DO n = 1, n_ov_joint - WRITE (eig_unit, '(I5,4X,ES24.14E3,4X,ES24.14E3)') n, & - rtbse_env%eigenvalues_liouvillian(n), & - rtbse_env%eigenvalues_liouvillian(n)*evolt - END DO - END IF - - CALL cp_print_key_finished_output(eig_unit, logger, rtbse_env%eig_section) - - DEALLOCATE (n_act_occ, n_act_virt, n_ov, off) - - CALL timestop(handle) - END SUBROUTINE diagnose_ABBA_liouvillian - -! ************************************************************************************************** -!> \brief Covariant AO->MO transform of an operator (real): M^MO_mn = sum_µν C_µm M^AO_µν C_νn. -!> For operator-like kernels (Σ^SX, V^H); the density uses the contravariant routine. -!> \param rtbse_env Entry point of the calculation - contains current state of variables -!> \param fm_ao operator in the AO basis (n_ao x n_ao), input -!> \param fm_mo operator in the active-MO basis (mo_active x mo_active), output -!> \param i_spin spin channel σ; selects C_active(σ) -! ************************************************************************************************** - SUBROUTINE transform_ao_to_mo_covariant_fm(rtbse_env, fm_ao, fm_mo, i_spin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_fm_type) :: fm_ao, fm_mo - INTEGER, INTENT(IN) :: i_spin - - CHARACTER(len=*), PARAMETER :: routineN = 'transform_ao_to_mo_covariant_fm' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - ! step 1: T_µn = sum_ν M^AO_µν C_νn (n_ao x mo_active) - CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, fm_ao, rtbse_env%C_active(i_spin), & - 0.0_dp, rtbse_env%ao_mo_workspace(1)) - ! step 2: M^MO_mn = sum_µ C_µm T_µn (mo_active x mo_active) - CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%ao_mo_workspace(1), & - 0.0_dp, fm_mo) - - CALL timestop(handle) - END SUBROUTINE transform_ao_to_mo_covariant_fm - -! ************************************************************************************************** -!> \brief Covariant AO->MO transform (complex): M^MO_mn = sum_µν C_µm M^AO_µν C_νn, applied to the -!> real and imaginary AO parts separately (2x the real cost). -!> \param rtbse_env Entry point of the calculation - contains current state of variables -!> \param fm_ao operator in the AO basis (n_ao x n_ao) cfm, input -!> \param fm_mo operator in the active-MO basis (mo_active x mo_active) cfm, output -!> \param i_spin spin channel σ; selects C_active(σ) -! ************************************************************************************************** - SUBROUTINE transform_ao_to_mo_covariant_cfm(rtbse_env, fm_ao, fm_mo, i_spin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type) :: fm_ao, fm_mo - INTEGER, INTENT(IN) :: i_spin - - CHARACTER(len=*), PARAMETER :: routineN = 'transform_ao_to_mo_covariant_cfm' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - ! Decompose into real/imag AO-sized parts - CALL cp_cfm_to_fm(msource=fm_ao, mtargetr=rtbse_env%real_workspace(1), & - mtargeti=rtbse_env%real_workspace(2)) - ! Re(M^MO)_mn = sum_µν C_µm Re(M^AO)_µν C_νn (two gemms via ao_mo_workspace) - CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%real_workspace(1), rtbse_env%C_active(i_spin), & - 0.0_dp, rtbse_env%ao_mo_workspace(1)) - CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%ao_mo_workspace(1), & - 0.0_dp, rtbse_env%real_workspace_mo(1)) - ! Im(M^MO)_mn = sum_µν C_µm Im(M^AO)_µν C_νn - CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%real_workspace(2), rtbse_env%C_active(i_spin), & - 0.0_dp, rtbse_env%ao_mo_workspace(1)) - CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%ao_mo_workspace(1), & - 0.0_dp, rtbse_env%real_workspace_mo(2)) - ! Reassemble into MO-sized cfm - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & - msourcei=rtbse_env%real_workspace_mo(2), & - mtarget=fm_mo) - - CALL timestop(handle) - END SUBROUTINE transform_ao_to_mo_covariant_cfm - -! ************************************************************************************************** -!> \brief Contravariant MO->AO transform of the density (complex): Δρ^AO_µν = sum_mn C_µm Δρ^MO_mn C_νn. -!> Density-like (expands MO indices), unlike the covariant operator transform. -!> \param rtbse_env Entry point of the calculation - contains current state of variables -!> \param fm_mo density in the active-MO basis (mo_active x mo_active) cfm, input -!> \param fm_ao density in the AO basis (n_ao x n_ao) cfm, output -!> \param i_spin spin channel σ; selects C_active(σ) -! ************************************************************************************************** - SUBROUTINE transform_mo_to_ao_contravariant_cfm(rtbse_env, fm_mo, fm_ao, i_spin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type) :: fm_mo, fm_ao - INTEGER, INTENT(IN) :: i_spin - - CHARACTER(len=*), PARAMETER :: routineN = 'transform_mo_to_ao_contravariant_cfm' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - ! Re/Im split of Δρ^MO (mo_active x mo_active) into persistent MO-sized scratch - CALL cp_cfm_to_fm(msource=fm_mo, mtargetr=rtbse_env%real_workspace_mo(1), & - mtargeti=rtbse_env%real_workspace_mo(2)) - ! Re(Δρ^AO)_µν = sum_mn C_µm Re(Δρ^MO)_mn C_νn (C·ρ via ao_mo_workspace, then ·C^T) - CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%mo_active, & - 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%real_workspace_mo(1), & - 0.0_dp, rtbse_env%ao_mo_workspace(1)) - CALL parallel_gemm("N", "T", rtbse_env%n_ao, rtbse_env%n_ao, rtbse_env%mo_active, & - 1.0_dp, rtbse_env%ao_mo_workspace(1), rtbse_env%C_active(i_spin), & - 0.0_dp, rtbse_env%real_workspace(1)) - ! Im(Δρ^AO)_µν = sum_mn C_µm Im(Δρ^MO)_mn C_νn - CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%mo_active, & - 1.0_dp, rtbse_env%C_active(i_spin), rtbse_env%real_workspace_mo(2), & - 0.0_dp, rtbse_env%ao_mo_workspace(1)) - CALL parallel_gemm("N", "T", rtbse_env%n_ao, rtbse_env%n_ao, rtbse_env%mo_active, & - 1.0_dp, rtbse_env%ao_mo_workspace(1), rtbse_env%C_active(i_spin), & - 0.0_dp, rtbse_env%real_workspace(2)) - ! Reassemble into AO-sized cfm - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(1), & - msourcei=rtbse_env%real_workspace(2), mtarget=fm_ao) - - CALL timestop(handle) - END SUBROUTINE transform_mo_to_ao_contravariant_cfm - -! ************************************************************************************************** -!> \brief Scales each MO-active element (m,n) by the occupation prefactor (f_n - f_m), f in {0,1} -!> (complex): OV -> -1, VO -> +1, OO/VV -> 0. The only trace of "ρ^0 diagonal in MO". -!> Applied to whatever kernel the caller passes (Σ^SX, V^H in MO) - bound by the caller. -!> \param rtbse_env Entry point of the calculation - contains current state of variables -!> \param cfm MO-active kernel matrix (mo_active x mo_active) cfm, scaled in place -!> \param i_spin spin channel σ; OV/VO boundary set by n_occ(σ) -! ************************************************************************************************** - SUBROUTINE transform_mo_occupation_factor_diff_cfm(rtbse_env, cfm, i_spin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type) :: cfm - INTEGER :: i_spin - - CHARACTER(len=*), PARAMETER :: routineN = 'transform_mo_occupation_factor_diff_cfm' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL cp_cfm_to_fm(msource=cfm, mtargetr=rtbse_env%real_workspace_mo(1), & - mtargeti=rtbse_env%real_workspace_mo(2)) - ! (f_n - f_m) applied to the real part - CALL transform_mo_occupation_factor_diff_fm(rtbse_env, rtbse_env%real_workspace_mo(1), i_spin) - ! (f_n - f_m) applied to the imaginary part - CALL transform_mo_occupation_factor_diff_fm(rtbse_env, rtbse_env%real_workspace_mo(2), i_spin) - ! Copy back to cfm - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), & - msourcei=rtbse_env%real_workspace_mo(2), & - mtarget=cfm) - - CALL timestop(handle) - END SUBROUTINE transform_mo_occupation_factor_diff_cfm - -! ************************************************************************************************** -!> \brief Scales each MO-active element (m,n) by the occupation prefactor (f_n - f_m), f in {0,1} -!> (real): OV -> -1, VO -> +1, OO/VV -> 0. Real-input worker for the cfm variant; the only -!> trace of "ρ^0 diagonal in MO". Bound by the caller to the kernel being scaled. -!> \param rtbse_env Entry point of the calculation - contains current state of variables -!> \param fm MO-active kernel matrix (mo_active x mo_active) fm, scaled in place -!> \param i_spin spin channel σ; OV/VO boundary set by n_occ(σ) -! ************************************************************************************************** - SUBROUTINE transform_mo_occupation_factor_diff_fm(rtbse_env, fm, i_spin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_fm_type) :: fm - INTEGER :: i_spin - - CHARACTER(len=*), PARAMETER :: routineN = 'transform_mo_occupation_factor_diff_fm' - - INTEGER :: handle, i_global, i_global_mo, i_local, & - j_global, j_global_mo, j_local, n_occ, & - ncol_local, nrow_local, shift - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - REAL(kind=dp) :: occ_factor - REAL(kind=dp), DIMENSION(:, :), POINTER :: local_data - - CALL timeset(routineN, handle) - - n_occ = rtbse_env%n_occ(i_spin) - ! Shift mapping local active-window index to absolute MO index - shift = rtbse_env%first_active_mo - 1 - - CALL cp_fm_get_info(matrix=fm, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - - local_data => fm%local_data - - DO i_local = 1, nrow_local - i_global = row_indices(i_local) - i_global_mo = i_global + shift - DO j_local = 1, ncol_local - j_global = col_indices(j_local) - j_global_mo = j_global + shift - - IF (i_global_mo <= n_occ .AND. j_global_mo > n_occ) THEN - occ_factor = -1.0_dp - ELSE IF (i_global_mo > n_occ .AND. j_global_mo <= n_occ) THEN - occ_factor = 1.0_dp - ELSE - occ_factor = 0.0_dp - END IF - - local_data(i_local, j_local) = occ_factor*local_data(i_local, j_local) - END DO - END DO - - CALL timestop(handle) - END SUBROUTINE transform_mo_occupation_factor_diff_fm - -! ************************************************************************************************** -!> \brief Mask an MO-active cfm: keep either OV or VO block, zero everything else. -!> \param rtbse_env RT-BSE environment -!> \param cfm MO-active cfm to mask in place -!> \param i_spin Spin index -!> \param keep_OV .TRUE. keeps the (occ row, virt col) block; .FALSE. keeps (virt row, occ col) -!> \param keep_ovvo if present and .TRUE., keep BOTH off-diagonal blocks (OV and VO) and zero -!> OO/VV; overrides keep_OV. Absent/false reproduces the keep_OV behaviour. -! ************************************************************************************************** - SUBROUTINE mask_mo_block_cfm(rtbse_env, cfm, i_spin, keep_OV, keep_ovvo) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type) :: cfm - INTEGER, INTENT(IN) :: i_spin - LOGICAL, INTENT(IN) :: keep_OV - LOGICAL, INTENT(IN), OPTIONAL :: keep_ovvo - - CHARACTER(len=*), PARAMETER :: routineN = 'mask_mo_block_cfm' - - COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data - INTEGER :: handle, i_global, i_global_mo, i_local, & - j_global, j_global_mo, j_local, n_occ, & - ncol_local, nrow_local, shift - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - LOGICAL :: keep, l_keep_ovvo - - CALL timeset(routineN, handle) - - l_keep_ovvo = .FALSE. - IF (PRESENT(keep_ovvo)) l_keep_ovvo = keep_ovvo - - n_occ = rtbse_env%n_occ(i_spin) - shift = rtbse_env%first_active_mo - 1 - - CALL cp_cfm_get_info(matrix=cfm, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - - local_data => cfm%local_data - - DO i_local = 1, nrow_local - i_global = row_indices(i_local) - i_global_mo = i_global + shift - DO j_local = 1, ncol_local - j_global = col_indices(j_local) - j_global_mo = j_global + shift - IF (l_keep_ovvo) THEN - ! keep both off-diagonal blocks (OV and VO); drop OO/VV - keep = ((i_global_mo <= n_occ) .NEQV. (j_global_mo <= n_occ)) - ELSE IF (keep_OV) THEN - keep = (i_global_mo <= n_occ .AND. j_global_mo > n_occ) - ELSE - keep = (i_global_mo > n_occ .AND. j_global_mo <= n_occ) - END IF - IF (.NOT. keep) local_data(i_local, j_local) = CMPLX(0.0_dp, 0.0_dp, kind=dp) - END DO - END DO - - CALL timestop(handle) - END SUBROUTINE mask_mo_block_cfm - -! ************************************************************************************************** -!> \brief Mask an MO-active fm: keep either OV or VO block, zero everything else. -!> \param rtbse_env RT-BSE environment -!> \param fm MO-active fm to mask in place -!> \param i_spin Spin index -!> \param keep_OV .TRUE. keeps the (occ row, virt col) block; .FALSE. keeps (virt row, occ col) -! ************************************************************************************************** - SUBROUTINE mask_mo_block_fm(rtbse_env, fm, i_spin, keep_OV) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_fm_type) :: fm - INTEGER, INTENT(IN) :: i_spin - LOGICAL, INTENT(IN) :: keep_OV - - CHARACTER(len=*), PARAMETER :: routineN = 'mask_mo_block_fm' - - INTEGER :: handle, i_global, i_global_mo, i_local, & - j_global, j_global_mo, j_local, n_occ, & - ncol_local, nrow_local, shift - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - LOGICAL :: keep - REAL(kind=dp), DIMENSION(:, :), POINTER :: local_data - - CALL timeset(routineN, handle) - - n_occ = rtbse_env%n_occ(i_spin) - shift = rtbse_env%first_active_mo - 1 - - CALL cp_fm_get_info(matrix=fm, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - - local_data => fm%local_data - - DO i_local = 1, nrow_local - i_global = row_indices(i_local) - i_global_mo = i_global + shift - DO j_local = 1, ncol_local - j_global = col_indices(j_local) - j_global_mo = j_global + shift - IF (keep_OV) THEN - keep = (i_global_mo <= n_occ .AND. j_global_mo > n_occ) - ELSE - keep = (i_global_mo > n_occ .AND. j_global_mo <= n_occ) - END IF - IF (.NOT. keep) local_data(i_local, j_local) = 0.0_dp - END DO - END DO - - CALL timestop(handle) - END SUBROUTINE mask_mo_block_fm - -! ************************************************************************************************** -!> \brief Multiply a MO-active cfm rho by the TDA symmetric-shift rotation: -!> rho_OV *= exp(i * phase), rho_VO *= exp(-i * phase). -!> OO/VV blocks are left untouched. For direction='to_lab' pass phase = -Ω_0*t; -!> for direction='to_rotating' pass phase = +Ω_0*t. No-op when omega_shift = 0. -!> Preserves Hermiticity since the two phases are complex conjugates of each other. -!> \param rtbse_env RT-BSE environment -!> \param rho MO-active cfm rotated in place -!> \param i_spin Spin index -!> \param phase Real phase argument (radians); typically +/- Ω_0 * t -! ************************************************************************************************** - SUBROUTINE rotate_rho_phase(rtbse_env, rho, i_spin, phase) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type) :: rho - INTEGER, INTENT(IN) :: i_spin - REAL(kind=dp), INTENT(IN) :: phase - - CHARACTER(len=*), PARAMETER :: routineN = 'rotate_rho_phase' - - COMPLEX(kind=dp) :: phase_ov, phase_vo - COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data - INTEGER :: handle, i_global, i_global_mo, i_local, & - j_global, j_global_mo, j_local, n_occ, & - ncol_local, nrow_local, shift - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - - IF (rtbse_env%omega_shift == 0.0_dp) RETURN - - CALL timeset(routineN, handle) - - n_occ = rtbse_env%n_occ(i_spin) - shift = rtbse_env%first_active_mo - 1 - phase_ov = CMPLX(COS(phase), SIN(phase), kind=dp) - phase_vo = CONJG(phase_ov) - - CALL cp_cfm_get_info(matrix=rho, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - local_data => rho%local_data - - DO i_local = 1, nrow_local - i_global = row_indices(i_local) - i_global_mo = i_global + shift - DO j_local = 1, ncol_local - j_global = col_indices(j_local) - j_global_mo = j_global + shift - IF (i_global_mo <= n_occ .AND. j_global_mo > n_occ) THEN - ! ρ_OV *= e^{+iφ} - local_data(i_local, j_local) = phase_ov*local_data(i_local, j_local) - ELSE IF (i_global_mo > n_occ .AND. j_global_mo <= n_occ) THEN - ! ρ_VO *= e^{-iφ} - local_data(i_local, j_local) = phase_vo*local_data(i_local, j_local) - END IF - END DO - END DO - - CALL timestop(handle) - END SUBROUTINE rotate_rho_phase - -! ************************************************************************************************** -!> \brief Build a lab-frame copy of the (possibly rotating-frame) density rho for I/O. -!> On the TDA + symmetric-shift path returns rho_lab(t) by multiplying OV/VO by -!> exp(-/+ i Ω_0 t). Otherwise returns a plain copy. Writes into rho_new_last -!> (mo_struct-sized, idle outside ETRS) and returns a pointer to it; falls back to -!> the input rho when no scratch is available. -!> \param rtbse_env RT-BSE environment -!> \param rho_in Rotating-frame density (per spin) -!> \param t_phys Physical time associated with rho_in -!> \param rho_lab On exit, points to a per-spin cfm array holding rho in the lab frame. -! ************************************************************************************************** - SUBROUTINE build_rho_lab(rtbse_env, rho_in, t_phys, rho_lab) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_in - REAL(kind=dp), INTENT(IN) :: t_phys - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_lab - - CHARACTER(len=*), PARAMETER :: routineN = 'build_rho_lab' - - INTEGER :: handle, i - - IF (rtbse_env%omega_shift == 0.0_dp .OR. .NOT. ASSOCIATED(rtbse_env%rho_new_last)) THEN - rho_lab => rho_in - RETURN - END IF - - CALL timeset(routineN, handle) - - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_to_cfm(rho_in(i), rtbse_env%rho_new_last(i)) - ! Lab-frame rho_OV(t) = exp(+i*Ω_0*t) * rho_tilde_OV(t) - ! (sign derived from [h_shifted, rho_tilde]_OV = (-eps_ai + Ω_0) rho_tilde_OV). - CALL rotate_rho_phase(rtbse_env, rtbse_env%rho_new_last(i), i, rtbse_env%omega_shift*t_phys) - END DO - rho_lab => rtbse_env%rho_new_last - - CALL timestop(handle) - END SUBROUTINE build_rho_lab - -! ************************************************************************************************** -!> \brief Bridge the restart density from the previous run's active-MO gauge into this run's: -!> overlap-metric basis change U_mn = sum_µν C2_µm S_µν C1_νn (mo_active × mo_active), -!> then ρ_mn ← sum_pq U_mp ρ_pq U_nq (ρ ← U ρ U^T, U real orthogonal up to FP). -!> Exact under per-MO sign flips and degenerate-subspace rotations of the SCF solution. -!> Diagnostics per spin: max|U−1| (total gauge correction), sign-flip count, max off-diag -!> (degenerate rotation), max|U^T U−1| (representability loss; warn ≥1e-10, abort ≥1e-3), -!> max|U_OV| (occ/virt mixing; warn ≥1e-6). No-op (U=1) when the two gauges agree. -!> \param rtbse_env RT-BSE environment -! ************************************************************************************************** - SUBROUTINE apply_restart_basis_bridge(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'apply_restart_basis_bridge' - COMPLEX(kind=dp), PARAMETER :: c_one = CMPLX(1.0_dp, 0.0_dp, kind=dp), & - c_zero = CMPLX(0.0_dp, 0.0_dp, kind=dp) - - INTEGER :: handle, i, i_glob, i_mo, ii, j_glob, & - j_mo, jj, n_flip, ncol_local, & - nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - LOGICAL :: found - REAL(kind=dp) :: dev_ident, dev_offdiag, dev_ov, & - dev_unitary - REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: u_diag - REAL(kind=dp), CONTIGUOUS, DIMENSION(:, :), & - POINTER :: u_data - TYPE(cp_fm_type) :: SC_old - TYPE(cp_fm_type), DIMENSION(:), POINTER :: C_old - - CALL timeset(routineN, handle) - - NULLIFY (C_old) - ALLOCATE (C_old(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_fm_create(C_old(i), rtbse_env%fm_struct_ao_mo_active) - END DO - CALL read_restart_C(rtbse_env, C_old, found) - IF (.NOT. found) THEN - DO i = 1, rtbse_env%n_spin - CALL cp_fm_release(C_old(i)) - END DO - DEALLOCATE (C_old) - CALL timestop(handle) - RETURN - END IF - - CALL cp_fm_create(SC_old, rtbse_env%fm_struct_ao_mo_active) - ALLOCATE (u_diag(rtbse_env%mo_active)) - - DO i = 1, rtbse_env%n_spin - ! S C1 : [S C1]_µn = sum_ν S_µν C1_νn - CALL parallel_gemm("N", "N", rtbse_env%n_ao, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%S_fm, C_old(i), 0.0_dp, SC_old) - ! U = C2^T (S C1) : U_mn = sum_µ C2_µm [S C1]_µn -> real_workspace_mo(1) - CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%n_ao, & - 1.0_dp, rtbse_env%C_active(i), SC_old, 0.0_dp, rtbse_env%real_workspace_mo(1)) - - ! Diagnostics on U (local blocks + global MAX reduction; diagonal is gathered globally) - CALL cp_fm_get_diag(rtbse_env%real_workspace_mo(1), u_diag) - n_flip = COUNT(u_diag < 0.0_dp) - CALL cp_fm_get_info(rtbse_env%real_workspace_mo(1), nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices, local_data=u_data) - dev_ident = 0.0_dp; dev_offdiag = 0.0_dp; dev_ov = 0.0_dp - DO ii = 1, nrow_local - i_glob = row_indices(ii) - i_mo = i_glob + rtbse_env%first_active_mo - 1 - DO jj = 1, ncol_local - j_glob = col_indices(jj) - j_mo = j_glob + rtbse_env%first_active_mo - 1 - IF (i_glob == j_glob) THEN - dev_ident = MAX(dev_ident, ABS(u_data(ii, jj) - 1.0_dp)) - ELSE - dev_ident = MAX(dev_ident, ABS(u_data(ii, jj))) - dev_offdiag = MAX(dev_offdiag, ABS(u_data(ii, jj))) - END IF - IF ((i_mo <= rtbse_env%n_occ(i)) .NEQV. (j_mo <= rtbse_env%n_occ(i))) THEN - dev_ov = MAX(dev_ov, ABS(u_data(ii, jj))) - END IF - END DO - END DO - ! U^T U − 1 : [U^T U]_mn = sum_p U_pm U_pn -> real_workspace_mo(2) - CALL parallel_gemm("T", "N", rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - 1.0_dp, rtbse_env%real_workspace_mo(1), rtbse_env%real_workspace_mo(1), & - 0.0_dp, rtbse_env%real_workspace_mo(2)) - CALL cp_fm_get_info(rtbse_env%real_workspace_mo(2), nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices, local_data=u_data) - dev_unitary = 0.0_dp - DO ii = 1, nrow_local - i_glob = row_indices(ii) - DO jj = 1, ncol_local - j_glob = col_indices(jj) - dev_unitary = MAX(dev_unitary, ABS(u_data(ii, jj) - MERGE(1.0_dp, 0.0_dp, i_glob == j_glob))) - END DO - END DO - CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_ident) - CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_offdiag) - CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_ov) - CALL rtbse_env%real_workspace_mo(1)%matrix_struct%para_env%max(dev_unitary) - - IF (rtbse_env%unit_nr > 0) THEN - WRITE (rtbse_env%unit_nr, '(A,I3,A)') " RTBSE| Restart basis bridge U = C2^T S C1 (spin ", i, "):" - WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max |U - 1| ", dev_ident, & - " (total gauge correction)" - WRITE (rtbse_env%unit_nr, '(A,I12)') " RTBSE| sign flips (U_ii<0)", n_flip - WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max offdiag |U_ij| ", dev_offdiag, & - " (degenerate-subspace rotation)" - WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max |U^T U - 1| ", dev_unitary, & - " (representability loss)" - WRITE (rtbse_env%unit_nr, '(A,ES12.3,A)') " RTBSE| max |U_OV| ", dev_ov, & - " (occ/virt structure change)" - END IF - IF (dev_unitary >= 1.0e-3_dp) THEN - CALL cp_abort(__LOCATION__, & - "Restart basis bridge: active spaces of the two runs differ severely (|U^T U - 1| >= 1e-3)") - END IF - IF (dev_unitary >= 1.0e-10_dp .AND. dev_unitary < 1.0e-3_dp) THEN - CALL cp_warn(__LOCATION__, & - "Restart basis bridge: representability loss above 1e-10 - active windows differ slightly.") - END IF - ! 1e-6 floor: benign SCF reconvergence gives ~1e-9 occ/virt gauge noise (the bridge maps it - ! correctly either way); only a genuine occupation-structure change reaches this threshold. - IF (dev_ov >= 1.0e-6_dp) THEN - CALL cp_warn(__LOCATION__, & - "Restart basis bridge: occupied/virtual mixing above 1e-6 - occupation structure changed.") - END IF - - ! ρ ← U ρ U^T : lift U to complex, [Uρ]_mn = sum_p U_mp ρ_pn, then ρ_mn = sum_q [Uρ]_mq U_nq - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%rho_workspace(1)) - CALL cp_cfm_gemm('N', 'N', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - c_one, rtbse_env%rho_workspace(1), rtbse_env%rho(i), c_zero, rtbse_env%rho_workspace(2)) - CALL cp_cfm_gemm('N', 'C', rtbse_env%mo_active, rtbse_env%mo_active, rtbse_env%mo_active, & - c_one, rtbse_env%rho_workspace(2), rtbse_env%rho_workspace(1), c_zero, rtbse_env%rho(i)) - END DO - - DEALLOCATE (u_diag) - CALL cp_fm_release(SC_old) - DO i = 1, rtbse_env%n_spin - CALL cp_fm_release(C_old(i)) - END DO - DEALLOCATE (C_old) - CALL timestop(handle) - END SUBROUTINE apply_restart_basis_bridge - -! ************************************************************************************************** -!> \brief Complex-linear Hartree contraction. Calls the real-input get_hartree on -!> Re(rho_AO) and on Im(rho_AO) separately and assembles -!> v_AO = V_H[Re(rho_AO)] + i * V_H[Im(rho_AO)] . -!> Required by the TDA propagator where the per-pass input Delta rho_OV (or -!> Delta rho_VO) is non-Hermitian, so the imaginary part must be carried. -!> The real kernel get_hartree realises V^H_λσ = sum_PQ (λσ|P) V_PQ [sum_µν (µν|Q) Δρ_µν]. -!> \param rtbse_env RT-BSE environment -!> \param rho_cfm AO complex input density -!> \param v_cfm AO complex Hartree output (overwritten) -!> \param ispin Spin index (selects scratch slots in rtbse_env) -! ************************************************************************************************** - SUBROUTINE get_hartree_complex(rtbse_env, rho_cfm, v_cfm, ispin) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(cp_cfm_type), INTENT(IN) :: rho_cfm - TYPE(cp_cfm_type) :: v_cfm - INTEGER, INTENT(IN) :: ispin - - CHARACTER(len=*), PARAMETER :: routineN = 'get_hartree_complex' - - INTEGER :: handle - - MARK_USED(ispin) - - CALL timeset(routineN, handle) - - ! Mirrors get_sigma_complex: split rho_cfm into real and imaginary fm parts, - ! call the real-input Hartree contraction on each, then assemble - ! v_cfm = V_H[Re(rho_cfm)] + i*V_H[Im(rho_cfm)]. - ! Scratch usage: - ! real_workspace(1) - holds Re(rho) then V_H[Re] - ! real_workspace(2) - holds Im(rho) then V_H[Im] - ! sigma_complex_workspace(1) - cfm wrapper feeding the real-input slot of get_hartree - - ! V^H[Re(Δρ^AO)] -> real_workspace(1) - CALL cp_cfm_to_fm(msource=rho_cfm, mtargetr=rtbse_env%real_workspace(1)) - CALL cp_cfm_set_all(rtbse_env%sigma_complex_workspace(1), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(1), & - mtarget=rtbse_env%sigma_complex_workspace(1)) - CALL get_hartree(rtbse_env, rtbse_env%sigma_complex_workspace(1), & - rtbse_env%real_workspace(1)) - - ! Imaginary part: extract Im(rho_cfm) into real_workspace(2) - CALL cp_cfm_to_fm(msource=rho_cfm, mtargeti=rtbse_env%real_workspace(2)) - CALL cp_cfm_set_all(rtbse_env%sigma_complex_workspace(1), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(2), & - mtarget=rtbse_env%sigma_complex_workspace(1)) - CALL get_hartree(rtbse_env, rtbse_env%sigma_complex_workspace(1), & - rtbse_env%real_workspace(2)) - - ! Assemble v_cfm = real_workspace(1) + i * real_workspace(2) - CALL cp_fm_to_cfm(msourcer=rtbse_env%real_workspace(1), & - msourcei=rtbse_env%real_workspace(2), & - mtarget=v_cfm) - - CALL timestop(handle) - END SUBROUTINE get_hartree_complex - -! ************************************************************************************************** -!> \brief δ-kick (Marek2025) seeding the linearized EOM: builds the MO-active dipole operator -!> A = intensity * sum_k kvec_k r_k (MO basis), Hermitizes it, and propagates ρ by exp(-iA), -!> so Δρ^+_nm = i(f_n - f_m) A_nm excites only the OV/VO blocks. -!> \param rtbse_env RT-BSE environment -!> \author Stepan Marek (09.24) -!> \author Maximilian Graml - trafo to MO and linearized version following 10.1021/acs.jctc.2c00644 (03.26) -! ************************************************************************************************** - SUBROUTINE apply_delta_pulse_MO(rtbse_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - - CHARACTER(len=*), PARAMETER :: routineN = 'apply_delta_pulse_MO' - - INTEGER :: handle, i, k - REAL(kind=dp) :: intensity, metric - REAL(kind=dp), DIMENSION(3) :: kvec - - CALL timeset(routineN, handle) - - ! Report application - IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A28)') ' RTBSE| Applying delta pulse' - ! Extra minus for the propagation of density - intensity = -rtbse_env%dft_control%rtp_control%delta_pulse_scale - metric = 0.0_dp - kvec(:) = rtbse_env%dft_control%rtp_control%delta_pulse_direction(:) - IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, '(A38,E14.4E3,E14.4E3,E14.4E3)') & - " RTBSE| Delta pulse elements (a.u.) : ", intensity*kvec(:) - ! Per-spin kick: each spin uses its own MO-active dipole operator (C_active(i_spin) basis) - DO i = 1, rtbse_env%n_spin - CALL cp_fm_set_all(rtbse_env%real_workspace_mo(1), 0.0_dp) - DO k = 1, 3 - CALL cp_fm_scale_and_add(1.0_dp, rtbse_env%real_workspace_mo(1), & - kvec(k), rtbse_env%moments_field(k, i)) - END DO - ! enforce hermiticity of the effective Hamiltonian - CALL cp_fm_transpose(rtbse_env%real_workspace_mo(1), rtbse_env%real_workspace_mo(2)) - CALL cp_fm_scale_and_add(0.5_dp, rtbse_env%real_workspace_mo(1), & - 0.5_dp, rtbse_env%real_workspace_mo(2)) - ! multiply by intensity, set as the imaginary exponent for this spin - CALL cp_fm_scale(intensity, rtbse_env%real_workspace_mo(1)) - CALL cp_fm_to_cfm(msourcei=rtbse_env%real_workspace_mo(1), mtarget=rtbse_env%ham_workspace(i)) - END DO - ! Propagate the density by the effect of the delta pulse - CALL propagate_density(rtbse_env, rtbse_env%ham_workspace, rtbse_env%rho, rtbse_env%rho_new) - metric = rho_metric(rtbse_env%rho_new, rtbse_env%rho, rtbse_env%n_spin) - IF (rtbse_env%unit_nr > 0) WRITE (rtbse_env%unit_nr, ('(A42,E38.8E3)')) " RTBSE| Metric difference after delta kick", metric - ! Copy the new density to the old density - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_to_cfm(rtbse_env%rho_new(i), rtbse_env%rho(i)) - END DO - - CALL timestop(handle) - END SUBROUTINE apply_delta_pulse_MO - -! ************************************************************************************************** -!> \brief Zero the OO and VV blocks of an MO-basis derivative cfm in place. Used to enforce -!> strict linear response on the RK4 derivatives so that the linearized propagator -!> only carries the OV/VO branches and the OO/VV orbital-energy spreads do not enter -!> the RK4 stability bound. -!> \param rtbse_env Entry point - rtbse environment -!> \param cfm Derivative-like cfm in MO basis for one spin channel (modified in place) -!> \param i_spin Spin index -! ************************************************************************************************** - SUBROUTINE project_drho_to_ov(rtbse_env, cfm, i_spin) - TYPE(rtbse_env_type), INTENT(IN) :: rtbse_env - TYPE(cp_cfm_type), INTENT(INOUT) :: cfm - INTEGER, INTENT(IN) :: i_spin - - COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data - INTEGER :: i_global, i_global_mo, i_local, & - j_global, j_global_mo, j_local, n_occ, & - ncol_local, nrow_local, shift - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - - n_occ = rtbse_env%n_occ(i_spin) - shift = rtbse_env%first_active_mo - 1 - - CALL cp_cfm_get_info(matrix=cfm, & - nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices) - local_data => cfm%local_data - - ! keep OV/VO, zero OO/VV: project Δρ onto the δ-kick sectors - DO j_local = 1, ncol_local - j_global = col_indices(j_local) - j_global_mo = j_global + shift - DO i_local = 1, nrow_local - i_global = row_indices(i_local) - i_global_mo = i_global + shift - IF ((i_global_mo <= n_occ .AND. j_global_mo <= n_occ) .OR. & - (i_global_mo > n_occ .AND. j_global_mo > n_occ)) THEN - local_data(i_local, j_local) = CMPLX(0.0_dp, 0.0_dp, kind=dp) - END IF - END DO - END DO - END SUBROUTINE project_drho_to_ov - -! ************************************************************************************************** -!> \brief Per-spin electron numbers from the MO density: N_e^σ = spin_degeneracy * Re Tr[ρ^σ], -!> returned as one entry per spin channel (alpha/beta). The node-local diagonal partial -!> sums are reduced over the BLACS grid before scaling; the imaginary trace is a -!> non-Hermiticity diagnostic. -!> \param rtbse_env Entry point - rtbse environment -!> \param rho Density matrix in MO basis (per spin) -!> \param electron_n_re Real electron number per spin channel (size n_spin) -!> \param electron_n_im Imaginary electron number per spin channel (numerical non-hermiticity) -! ************************************************************************************************** - SUBROUTINE get_electron_number_MO(rtbse_env, rho, electron_n_re, electron_n_im) - TYPE(rtbse_env_type) :: rtbse_env - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho - REAL(kind=dp), DIMENSION(:), INTENT(OUT) :: electron_n_re, electron_n_im - - CHARACTER(len=*), PARAMETER :: routineN = 'get_electron_number_MO' - - COMPLEX(kind=dp), DIMENSION(:, :), POINTER :: local_data - INTEGER :: handle, i_global, i_local, j, j_global, & - j_local, ncol_local, nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - - CALL timeset(routineN, handle) - electron_n_re(:) = 0.0_dp - electron_n_im(:) = 0.0_dp - DO j = 1, rtbse_env%n_spin - CALL cp_cfm_get_info(matrix=rho(j), & - nrow_local=nrow_local, & - ncol_local=ncol_local, & - row_indices=row_indices, & - col_indices=col_indices) - local_data => rho(j)%local_data - ! accumulate Tr[ρ^σ] = sum_m ρ^σ_mm (real and imaginary parts separately) - DO i_local = 1, nrow_local - i_global = row_indices(i_local) - ! Search column indices for the diagonal position - DO j_local = 1, ncol_local - j_global = col_indices(j_local) - IF (j_global == i_global) THEN - ! Found diagonal element - electron_n_re(j) = electron_n_re(j) + REAL(local_data(i_local, j_local), kind=dp) - electron_n_im(j) = electron_n_im(j) + AIMAG(local_data(i_local, j_local)) - EXIT - END IF - END DO - END DO - ! reduce the per-rank partial traces over the process grid (the MO diagonal is distributed) - CALL rho(j)%matrix_struct%para_env%sum(electron_n_re(j)) - CALL rho(j)%matrix_struct%para_env%sum(electron_n_im(j)) - ! N_e^σ = spin_degeneracy * Tr[ρ^σ] (g=2 closed shell; 1 per channel open shell) - electron_n_re(j) = electron_n_re(j)*rtbse_env%spin_degeneracy - electron_n_im(j) = electron_n_im(j)*rtbse_env%spin_degeneracy - END DO - - CALL timestop(handle) - END SUBROUTINE get_electron_number_MO - -END MODULE rt_bse_linearized diff --git a/src/emd/rt_bse_ri_rs.F b/src/emd/rt_bse_ri_rs.F deleted file mode 100644 index 1ca8ddd9da..0000000000 --- a/src/emd/rt_bse_ri_rs.F +++ /dev/null @@ -1,759 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief RT-BSE RI-RS kernels: SEX and Hartree evaluated by collocation on grid points r_l. -!> Once-built grid objects: -!> φ_µ(r_l) [grid×AO], Z_lP [grid×RI], -!> V^aux_PQ = [M^-1 V^tr M^-1]_PQ [RI×RI], W^0_ll' = sum_PQ Z_lP (V + W^c(ω=0))_PQ Z_l'Q. -!> Per-call kernels, collocation X = φ_µ(r_l) (AO domain, written φ_lµ below): -!> SEX: ρ^grid_ll' = sum_µν φ_lµ Δρ_µν φ_l'ν ; -!> Σ_µν = pref * sum_ll' φ_lµ [ρ^grid ∘ W^0]_ll' φ_l'ν -!> Hartree: n_l = sum_µν φ_lµ Δρ_µν φ_lν ; -!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (applied factorized, stage 2) ; -!> V^H_µν = sum_l φ_lµ v_l φ_lν (diagonal-only, no grid×grid) -!> Independent of which GW variant produced bs_env%fm_W_MIC_freq_zero. -!> \author Maximilian Graml (05.26) -! ************************************************************************************************** -MODULE rt_bse_ri_rs - USE cp_cfm_basic_linalg, ONLY: cp_cfm_scale_and_add - USE cp_cfm_types, ONLY: cp_cfm_create,& - cp_cfm_release,& - cp_cfm_to_fm,& - cp_cfm_type,& - cp_fm_to_cfm - USE cp_dbcsr_api, ONLY: & - dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_distribution_type, dbcsr_get_info, & - dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, dbcsr_iterator_start, & - dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, dbcsr_release, dbcsr_scale, & - dbcsr_type, dbcsr_type_no_symmetry - USE cp_dbcsr_contrib, ONLY: dbcsr_get_diag - USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& - copy_fm_to_dbcsr - USE cp_fm_types, ONLY: cp_fm_create,& - cp_fm_release,& - cp_fm_type - USE gw_large_cell_Gamma_ri_rs, ONLY: contract_A_B_A,& - hadamard_product_inplace,& - release_dbcsr_topology_and_matrices,& - setup_square_topology - USE gw_large_cell_gamma, ONLY: multiply_fm_W_MIC_time_with_Minv_Gamma - USE gw_non_periodic_ri_rs, ONLY: atomic_basis_at_grid_point,& - compute_coeff_Z_lP,& - precompute_ri_rs_radii,& - ri_rs_grid_assembler - USE kinds, ONLY: dp - USE machine, ONLY: m_walltime - USE message_passing, ONLY: mp_para_env_type - USE mp2_ri_2c, ONLY: RI_2c_integral_mat - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type - USE qs_environment_types, ONLY: qs_environment_type -#include "../base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rt_bse_ri_rs' - - PUBLIC :: rt_bse_ri_rs_ensure_grid, & - rt_bse_ri_rs_ensure_V_grid, & - rt_bse_ri_rs_ensure_W0_grid, & - compute_sigma_ri_rs, & - compute_sigma_ri_rs_complex, & - compute_hartree_ri_rs, & - compute_hartree_ri_rs_complex, & - compute_hartree_ri_rs_from_diag, & - hartree_potential_from_diag_ri_rs - -CONTAINS - -! ************************************************************************************************** -!> \brief Make sure the AO collocation φ_µ(r_l) (mat_phi_mu_l) and the RI fit coefficients -!> Z_lP (mat_Z_lP) are populated in memory. -!> If GW was run with RI-RS the grid is already built; otherwise build it here so the -!> AO-RI GW + RI-RS RT-BSE combination is possible. -!> \param bs_env ... -!> \param qs_env ... -! ************************************************************************************************** - SUBROUTINE rt_bse_ri_rs_ensure_grid(bs_env, qs_env) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(qs_environment_type), POINTER :: qs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_bse_ri_rs_ensure_grid' - - INTEGER :: handle - REAL(KIND=dp) :: t1 - - CALL timeset(routineN, handle) - - IF (bs_env%ri_rs%grid_built) THEN - CALL timestop(handle) - RETURN - END IF - - t1 = m_walltime() - - CALL ri_rs_grid_assembler(qs_env, bs_env, bs_env%ri_rs%grid_points) - ! Per-atom AO/RI screening radii required by the screened grid-fill and d_lP routines; the - ! GW RI-RS driver populates these, but the standalone RT-BSE grid build must do so itself. - IF (.NOT. ALLOCATED(bs_env%ri_rs%radius_ao_per_atom)) THEN - CALL precompute_ri_rs_radii(qs_env, bs_env) - END IF - CALL atomic_basis_at_grid_point(qs_env, bs_env, bs_env%ri_rs%grid_points, & - bs_env%ri_rs%mat_phi_mu_l) - CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & - bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) - - bs_env%ri_rs%grid_built = .TRUE. - - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & - 'Built RI-RS grid for RT-BSE (no GW_RI_RS used),', ' Execution time', & - m_walltime() - t1, ' s' - WRITE (bs_env%unit_nr, '(A)') ' ' - END IF - - CALL timestop(handle) - - END SUBROUTINE rt_bse_ri_rs_ensure_grid - -! ************************************************************************************************** -!> \brief Build V^aux_PQ = [M^-1 V^tr M^-1]_PQ (truncated Coulomb in the RI basis, M^-1-sandwiched -!> to match the W^MIC convention). The grid Coulomb V_ll' = sum_PQ Z_lP V^aux_PQ Z_l'Q is -!> never materialized -- the Hartree stage applies it factorized: -!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' -!> Needed by RT-BSE RI-RS Hartree. -!> \param bs_env ... -!> \param qs_env ... -! ************************************************************************************************** - SUBROUTINE rt_bse_ri_rs_ensure_V_grid(bs_env, qs_env) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(qs_environment_type), POINTER :: qs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_bse_ri_rs_ensure_V_grid' - - INTEGER :: handle - INTEGER, DIMENSION(:), POINTER :: blk_aux, dist_row_aux - REAL(KIND=dp) :: t1 - TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma - TYPE(dbcsr_distribution_type) :: dist_aux_aux - - CALL timeset(routineN, handle) - - IF (bs_env%ri_rs%V_grid_built) THEN - CALL timestop(handle) - RETURN - END IF - - CALL rt_bse_ri_rs_ensure_grid(bs_env, qs_env) - t1 = m_walltime() - - CALL setup_square_topology(bs_env%ri_rs%mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) - - CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & - bs_env%trunc_coulomb, do_kpoints=.FALSE.) - ! Apply M^-1 sandwich to match the W^MIC convention; same scale as W^c when both used. - CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) - - ! Store the M^-1-sandwiched RI-basis Coulomb; the grid kernel Z V Z^T is applied factorized. - CALL dbcsr_create(bs_env%ri_rs%mat_V_aux_rtbse, "V_aux_rtbse", dist_aux_aux, & - dbcsr_type_no_symmetry, blk_aux, blk_aux) - CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), bs_env%ri_rs%mat_V_aux_rtbse, & - keep_sparsity=.FALSE.) - - bs_env%ri_rs%V_grid_built = .TRUE. - - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & - 'Precomputed RT-BSE RI-RS V_aux kernel,', ' Execution time', & - m_walltime() - t1, ' s' - WRITE (bs_env%unit_nr, '(A)') ' ' - END IF - - CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux) - CALL cp_fm_release(fm_Vtr_Gamma) - - CALL timestop(handle) - - END SUBROUTINE rt_bse_ri_rs_ensure_V_grid - -! ************************************************************************************************** -!> \brief Build W^0_ll' = sum_PQ Z_lP (V + W^c(ω=0))_PQ Z_l'Q (statically screened W on the grid). -!> Needed by RT-BSE RI-RS SEX/COH. Reuses bs_env%fm_W_MIC_freq_zero which must already -!> contain M^-1 W^c(ω=0) M^-1 (built by either GW path under the BSE rtp_method gate). -!> W^0 enters only through the Hadamard ρ^grid ∘ W^0 -- its elements are needed, so it is -!> the one persistent grid×grid object of the kernel layer. -!> \param bs_env ... -!> \param qs_env ... -! ************************************************************************************************** - SUBROUTINE rt_bse_ri_rs_ensure_W0_grid(bs_env, qs_env) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(qs_environment_type), POINTER :: qs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_bse_ri_rs_ensure_W0_grid' - - INTEGER :: handle - INTEGER, DIMENSION(:), POINTER :: blk_aux, blk_grid, dist_col_grid, & - dist_row_aux - REAL(KIND=dp) :: t1 - TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma - TYPE(dbcsr_distribution_type) :: dist_aux_aux, dist_grid_grid - TYPE(dbcsr_type) :: matrix_V_aux, matrix_W_aux - - CALL timeset(routineN, handle) - - IF (bs_env%ri_rs%W0_grid_built) THEN - CALL timestop(handle) - RETURN - END IF - - ! W(w=0) is built by the GW step only under its RTBSE rtp_method gate; reaching this consumer - ! without it means gate and consumer disagree. Abort rather than read a never-created cp_fm. - IF (.NOT. ASSOCIATED(bs_env%fm_W_MIC_freq_zero%matrix_struct)) THEN - CALL cp_abort(__LOCATION__, & - "RT-BSE RI-RS kernel needs the screened interaction W(w=0), which the GW "// & - "step did not build. Select the RT-BSE propagator with '&RTBSE' or "// & - "'&RTBSE RTBSE', not '&RTBSE TDDFT'.") - END IF - - CALL rt_bse_ri_rs_ensure_grid(bs_env, qs_env) - t1 = m_walltime() - - CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, & - dist_col_grid) - CALL setup_square_topology(bs_env%ri_rs%mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) - - CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & - bs_env%trunc_coulomb, do_kpoints=.FALSE.) - CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) - - CALL dbcsr_create(matrix_V_aux, "V_aux_rtbse_W0", dist_aux_aux, dbcsr_type_no_symmetry, & - blk_aux, blk_aux) - CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.FALSE.) - - CALL dbcsr_create(matrix_W_aux, "W_aux_rtbse", dist_aux_aux, dbcsr_type_no_symmetry, & - blk_aux, blk_aux) - CALL copy_fm_to_dbcsr(bs_env%fm_W_MIC_freq_zero, matrix_W_aux, keep_sparsity=.FALSE.) - CALL dbcsr_add(matrix_W_aux, matrix_V_aux, 1.0_dp, 1.0_dp) - - CALL dbcsr_create(bs_env%ri_rs%mat_W0_grid_rtbse, "W0_grid_rtbse", dist_grid_grid, & - dbcsr_type_no_symmetry, blk_grid, blk_grid) - CALL contract_A_B_A("N", "T", bs_env%ri_rs%mat_Z_lP, matrix_W_aux, & - bs_env%ri_rs%mat_W0_grid_rtbse, bs_env%eps_filter) - - bs_env%ri_rs%W0_grid_built = .TRUE. - bs_env%ri_rs%rtbse_kernels_ready = .TRUE. - - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & - 'Precomputed RT-BSE RI-RS W0_grid kernel,', ' Execution time', & - m_walltime() - t1, ' s' - WRITE (bs_env%unit_nr, '(A)') ' ' - END IF - - CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid) - CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux, & - m1=matrix_V_aux, m2=matrix_W_aux) - CALL cp_fm_release(fm_Vtr_Gamma) - - CALL timestop(handle) - - END SUBROUTINE rt_bse_ri_rs_ensure_W0_grid - -! ************************************************************************************************** -!> \brief AO-domain SEX: Σ_µν = pref * sum_ll' φ_lµ [ρ^grid ∘ W^0]_ll' φ_l'ν, -!> ρ^grid_ll' = sum_µν φ_lµ Δρ_µν φ_l'ν. -!> The grid×grid ρ^grid is intrinsic to SEX -- the Hadamard needs W^0's elements, so no -!> factorized application exists (unlike the Hartree V_ll'). Real input, real output; -!> used for COH (input S^-1) and the init reference (ρ^0); dynamic Δρ goes through the -!> complex variant. Mirrors the AO-RI get_sigma(rtbse_env, sigma_fm, prefactor, rho_fm) API. -!> \param bs_env ... -!> \param sigma_AO_fm result, AO x AO -!> \param prefactor scaling applied to the final result -!> \param rho_AO_fm input density-like matrix, AO x AO -!> \param grid_diag_accum ... -! ************************************************************************************************** - SUBROUTINE compute_sigma_ri_rs(bs_env, sigma_AO_fm, prefactor, rho_AO_fm, & - grid_diag_accum) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(cp_fm_type), INTENT(INOUT) :: sigma_AO_fm - REAL(KIND=dp), INTENT(IN) :: prefactor - TYPE(cp_fm_type), INTENT(IN) :: rho_AO_fm - REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: grid_diag_accum(:) - - CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_sigma_ri_rs' - - INTEGER :: handle, n_grid - INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_grid, & - dist_row_ao - REAL(KIND=dp), ALLOCATABLE :: diag_local(:) - TYPE(dbcsr_distribution_type) :: dist_ao_ao, dist_grid_grid - TYPE(dbcsr_type) :: matrix_rho_AO, matrix_rho_grid, & - matrix_Sigma_AO - - CALL timeset(routineN, handle) - - CPASSERT(bs_env%ri_rs%W0_grid_built) - - CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) - CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, & - dist_col_grid) - - CALL dbcsr_create(matrix_rho_AO, "rho_AO_ri_rs", dist_ao_ao, dbcsr_type_no_symmetry, & - blk_ao, blk_ao) - CALL copy_fm_to_dbcsr(rho_AO_fm, matrix_rho_AO, keep_sparsity=.FALSE.) - - ! ρ^grid_ll' = sum_µν φ_lµ Δρ_µν φ_l'ν (the SEX-intrinsic grid×grid transient) - CALL dbcsr_create(matrix_rho_grid, "rho_grid_ri_rs", dist_grid_grid, & - dbcsr_type_no_symmetry, blk_grid, blk_grid) - ! No eps_filter on the SEX projections: a Δρ-dependent block drop breaks kernel - ! self-adjointness (L non-Hermitian). The W0 Hadamard below supplies the symmetric, - ! Δρ-independent grid sparsity, so unfiltered projections stay sparse via W0. - ! PERF(rirs-selfadjoint): a retain_sparsity-to-W0 build (dbcsr_multiply) gives identical - ! numbers with W0-sparse memory; NOT YET APPLIED, needs a perf test. - CALL contract_A_B_A("N", "T", bs_env%ri_rs%mat_phi_mu_l, matrix_rho_AO, & - matrix_rho_grid, 0.0_dp) - - ! Harvest n_l = diag(ρ^grid) BEFORE the in-place Hadamard destroys it; the Hartree reuses it - ! (compute_hartree_ri_rs_from_diag) instead of rebuilding φρφ^T. Bare accumulate (caller - ! pre-zeroes): the cross-spin Hartree density is the spin SUM of these, and spin_degeneracy is - ! applied to the V_H OUTPUT (post-filter, bit-identical) -- never to the diagonal, which would - ! shift the stage-3 eps_filter cut (coarse-filter sensitivity). - IF (PRESENT(grid_diag_accum)) THEN - n_grid = SIZE(grid_diag_accum) - ALLOCATE (diag_local(n_grid)) - diag_local = 0.0_dp - CALL dbcsr_get_diag(matrix_rho_grid, diag_local) - CALL bs_env%para_env%sum(diag_local) - grid_diag_accum(:) = grid_diag_accum(:) + diag_local(:) - DEALLOCATE (diag_local) - END IF - - ! ρ^grid_ll' <- ρ^grid_ll' * W^0_ll' (in place; blocks without a W^0 partner zeroed) - CALL hadamard_product_inplace(matrix_rho_grid, bs_env%ri_rs%mat_W0_grid_rtbse, & - 1.0_dp) - - ! Σ_µν = sum_ll' φ_lµ [ρ^grid ∘ W^0]_ll' φ_l'ν - CALL dbcsr_create(matrix_Sigma_AO, template=matrix_rho_AO) - ! Unfiltered for self-adjointness (see the forward projection above; PERF note there). - CALL contract_A_B_A("T", "N", bs_env%ri_rs%mat_phi_mu_l, matrix_rho_grid, & - matrix_Sigma_AO, 0.0_dp) - - CALL dbcsr_scale(matrix_Sigma_AO, prefactor) - CALL copy_dbcsr_to_fm(matrix_Sigma_AO, sigma_AO_fm) - - CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, & - m1=matrix_rho_AO, m2=matrix_Sigma_AO) - CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid, & - m1=matrix_rho_grid) - - CALL timestop(handle) - - END SUBROUTINE compute_sigma_ri_rs - -! ************************************************************************************************** -!> \brief Complex-input AO SEX via Re/Im split: the kernel is real, so complex linearity holds as -!> Σ[Δρ] = Σ[Re Δρ] + i Σ[Im Δρ]. Required for non-Hermitian Δρ inputs -!> (TDA OV-only / ABBA OV+VO). -!> \param bs_env ... -!> \param sigma_AO_cfm result, AO x AO (complex) -!> \param prefactor scaling applied to the final result -!> \param rho_AO_cfm input AO x AO complex matrix -!> \param grid_diag_re_accum optional: accumulate diag(φ.Re(ρ).φ^T) (bare; for the Hartree reuse) -!> \param grid_diag_im_accum optional: accumulate diag(φ.Im(ρ).φ^T) (bare; for the Hartree reuse) -! ************************************************************************************************** - SUBROUTINE compute_sigma_ri_rs_complex(bs_env, sigma_AO_cfm, prefactor, rho_AO_cfm, & - grid_diag_re_accum, grid_diag_im_accum) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(cp_cfm_type), INTENT(INOUT) :: sigma_AO_cfm - REAL(KIND=dp), INTENT(IN) :: prefactor - TYPE(cp_cfm_type), INTENT(IN) :: rho_AO_cfm - REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: grid_diag_re_accum(:), & - grid_diag_im_accum(:) - - CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_sigma_ri_rs_complex' - - INTEGER :: handle - TYPE(cp_cfm_type) :: cfm_real_part - TYPE(cp_fm_type) :: fm_rho, fm_sigma - - CALL timeset(routineN, handle) - - CALL cp_fm_create(fm_rho, bs_env%fm_s_Gamma%matrix_struct) - CALL cp_fm_create(fm_sigma, bs_env%fm_s_Gamma%matrix_struct) - CALL cp_cfm_create(cfm_real_part, bs_env%fm_s_Gamma%matrix_struct) - - ! Re/Im each harvest into their own accumulator; absent optionals propagate as absent. - CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargetr=fm_rho) - CALL compute_sigma_ri_rs(bs_env, fm_sigma, prefactor, fm_rho, & - grid_diag_accum=grid_diag_re_accum) - CALL cp_fm_to_cfm(msourcer=fm_sigma, mtarget=cfm_real_part) - - CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargeti=fm_rho) - CALL compute_sigma_ri_rs(bs_env, fm_sigma, prefactor, fm_rho, & - grid_diag_accum=grid_diag_im_accum) - CALL cp_fm_to_cfm(msourcei=fm_sigma, mtarget=sigma_AO_cfm) - - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), sigma_AO_cfm, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), cfm_real_part) - - CALL cp_fm_release(fm_rho) - CALL cp_fm_release(fm_sigma) - CALL cp_cfm_release(cfm_real_part) - - CALL timestop(handle) - - END SUBROUTINE compute_sigma_ri_rs_complex - -! ************************************************************************************************** -!> \brief AO-domain Hartree via RI-RS: -!> n_l = sum_µν φ_lµ Δρ_µν φ_lν = (φ ρ φ^T)_ll (diagonal of materialized grid×grid) ; -!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (factorized, stage 2) ; -!> V^H_µν = sum_l φ_lµ v_l φ_lν (diagonal-only row-scale, stage 3) -!> Real input, real output; complex inputs go through compute_hartree_ri_rs_complex. -!> \param bs_env ... -!> \param rho_AO_fm input AO x AO density matrix -!> \param V_H_AO_fm output AO x AO Hartree potential -! ************************************************************************************************** - SUBROUTINE compute_hartree_ri_rs(bs_env, rho_AO_fm, V_H_AO_fm) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(cp_fm_type), INTENT(IN) :: rho_AO_fm - TYPE(cp_fm_type), INTENT(INOUT) :: V_H_AO_fm - - CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_hartree_ri_rs' - - INTEGER :: handle, n_grid - INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_grid, & - dist_row_ao - REAL(KIND=dp), ALLOCATABLE :: n_vec(:) - TYPE(dbcsr_distribution_type) :: dist_ao_ao, dist_grid_grid - TYPE(dbcsr_type) :: matrix_rho_AO, matrix_rho_grid - - CALL timeset(routineN, handle) - - CPASSERT(bs_env%ri_rs%V_grid_built) - - CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) - CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, & - dist_col_grid) - - CALL dbcsr_create(matrix_rho_AO, "rho_AO_hartree", dist_ao_ao, dbcsr_type_no_symmetry, & - blk_ao, blk_ao) - CALL copy_fm_to_dbcsr(rho_AO_fm, matrix_rho_AO, keep_sparsity=.FALSE.) - - n_grid = SUM(blk_grid) - ALLOCATE (n_vec(n_grid)) - - ! stage 1: n_l = (φ ρ φ^T)_ll. A grid×AO row-dot (iterate φρ, look up φ) silently drops - ! off-rank pairs at ≥2 ranks — φ is sparse and the product is not co-located with φ — so - ! materialize φρφ^T and take its diagonal, co-location-safe like the SEX grid kernel. - CALL dbcsr_create(matrix_rho_grid, "rho_grid_hartree", dist_grid_grid, & - dbcsr_type_no_symmetry, blk_grid, blk_grid) - ! No eps_filter: a Δρ-dependent diagonal-block drop zeroes n_l inconsistently between OV - ! pairs and breaks Hartree self-adjointness (L non-Hermitian). - ! PERF(rirs-selfadjoint): this full grid×grid is built only for its diagonal n_l; a - ! diagonal-only build would avoid it. NOT YET APPLIED, needs a perf test. - CALL contract_A_B_A("N", "T", bs_env%ri_rs%mat_phi_mu_l, matrix_rho_AO, & - matrix_rho_grid, 0.0_dp) - n_vec = 0.0_dp - CALL dbcsr_get_diag(matrix_rho_grid, n_vec) - CALL bs_env%para_env%sum(n_vec) - CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid, & - m1=matrix_rho_grid) - CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, & - m1=matrix_rho_AO) - - ! stages 2-3: factorized Coulomb v = Z V^aux Z^T n, then V^H = φ^T diag(v) φ. - CALL hartree_potential_from_diag_ri_rs(bs_env, n_vec, V_H_AO_fm) - - DEALLOCATE (n_vec) - - CALL timestop(handle) - - END SUBROUTINE compute_hartree_ri_rs - -! ************************************************************************************************** -!> \brief Hartree stages 2-3 from a precomputed grid density n_l (skips the stage-1 φρφ^T build): -!> v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (factorized Coulomb) ; -!> V^H_µν = sum_l φ_lµ v_l φ_lν (Φ_lν = v_l φ_lν rowscale, then V^H = φ^T Φ). -!> n_l is harvested as diag(φρφ^T) inside compute_sigma_ri_rs (the SEX grid kernel), so the -!> Hartree never rebuilds the grid×grid product. Real in/out. -!> \param bs_env ... -!> \param n_vec grid density n_l (length n_grid, replicated) -!> \param V_H_AO_fm output AO x AO Hartree potential -! ************************************************************************************************** - SUBROUTINE hartree_potential_from_diag_ri_rs(bs_env, n_vec, V_H_AO_fm) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), INTENT(IN) :: n_vec(:) - TYPE(cp_fm_type), INTENT(INOUT) :: V_H_AO_fm - - CHARACTER(LEN=*), PARAMETER :: routineN = 'hartree_potential_from_diag_ri_rs' - - INTEGER :: handle - INTEGER, DIMENSION(:), POINTER :: blk_ao, dist_row_ao - REAL(KIND=dp), ALLOCATABLE :: u_ri(:), v_vec(:), w_ri(:) - TYPE(dbcsr_distribution_type) :: dist_ao_ao - TYPE(dbcsr_type) :: matrix_Phi, matrix_V_H_AO - - CALL timeset(routineN, handle) - - CPASSERT(bs_env%ri_rs%V_grid_built) - - CALL setup_square_topology(bs_env%ri_rs%mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) - ALLOCATE (v_vec(SIZE(n_vec))) - - ! stage 2: v_l = sum_PQl' Z_lP V^aux_PQ Z_l'Q n_l' (factorized; helper zeroes each output) - ALLOCATE (w_ri(bs_env%n_RI), u_ri(bs_env%n_RI)) - ! w_Q = sum_l Z_lQ n_l - CALL dbcsr_matvec_replicated(bs_env%ri_rs%mat_Z_lP, n_vec, w_ri, bs_env%para_env, & - transposed=.TRUE.) - ! u_P = sum_Q V^aux_PQ w_Q - CALL dbcsr_matvec_replicated(bs_env%ri_rs%mat_V_aux_rtbse, w_ri, u_ri, bs_env%para_env) - ! v_l = sum_P Z_lP u_P - CALL dbcsr_matvec_replicated(bs_env%ri_rs%mat_Z_lP, u_ri, v_vec, bs_env%para_env) - DEALLOCATE (w_ri, u_ri) - - ! stage 3: V^H_µν = sum_l φ_lµ v_l φ_lν (Φ_lν = v_l φ_lν rowscale, then V^H = φ^T Φ) - CALL dbcsr_create(matrix_Phi, template=bs_env%ri_rs%mat_phi_mu_l) - CALL dbcsr_copy(matrix_Phi, bs_env%ri_rs%mat_phi_mu_l) - CALL dbcsr_scale_rows_replicated(matrix_Phi, v_vec) - - CALL dbcsr_create(matrix_V_H_AO, "V_H_AO_hartree", dist_ao_ao, dbcsr_type_no_symmetry, & - blk_ao, blk_ao) - ! No eps_filter: a Δρ-dependent block drop breaks Hartree kernel self-adjointness. - CALL dbcsr_multiply("T", "N", 1.0_dp, bs_env%ri_rs%mat_phi_mu_l, matrix_Phi, & - 0.0_dp, matrix_V_H_AO, filter_eps=0.0_dp) - CALL dbcsr_release(matrix_Phi) - - CALL copy_dbcsr_to_fm(matrix_V_H_AO, V_H_AO_fm) - - DEALLOCATE (v_vec) - - CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, & - m1=matrix_V_H_AO) - - CALL timestop(handle) - - END SUBROUTINE hartree_potential_from_diag_ri_rs - -! ************************************************************************************************** -!> \brief Complex Hartree from precomputed grid diagonals: V^H = V^H[n_re] + i V^H[n_im], each via -!> hartree_potential_from_diag_ri_rs (stages 2-3 only). n_re/n_im are the spin-summed grid -!> densities harvested in the SEX kernel; this is the cross-spin / TDA complex consumer that -!> replaces compute_hartree_ri_rs_complex when SEX already built the grid. n_im optional: when -!> absent the result is purely real (matches the Re-only real-input Hartree). -!> \param bs_env ... -!> \param n_re grid density Re part (length n_grid, replicated) -!> \param V_H_AO_cfm output AO x AO complex Hartree potential -!> \param n_im optional grid density Im part (length n_grid, replicated) -! ************************************************************************************************** - SUBROUTINE compute_hartree_ri_rs_from_diag(bs_env, n_re, V_H_AO_cfm, n_im) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), INTENT(IN) :: n_re(:) - TYPE(cp_cfm_type), INTENT(INOUT) :: V_H_AO_cfm - REAL(KIND=dp), INTENT(IN), OPTIONAL :: n_im(:) - - CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_hartree_ri_rs_from_diag' - - INTEGER :: handle - TYPE(cp_cfm_type) :: cfm_real_part - TYPE(cp_fm_type) :: fm_v - - CALL timeset(routineN, handle) - - CALL cp_fm_create(fm_v, bs_env%fm_s_Gamma%matrix_struct) - - CALL hartree_potential_from_diag_ri_rs(bs_env, n_re, fm_v) - IF (PRESENT(n_im)) THEN - CALL cp_cfm_create(cfm_real_part, bs_env%fm_s_Gamma%matrix_struct) - CALL cp_fm_to_cfm(msourcer=fm_v, mtarget=cfm_real_part) - CALL hartree_potential_from_diag_ri_rs(bs_env, n_im, fm_v) - CALL cp_fm_to_cfm(msourcei=fm_v, mtarget=V_H_AO_cfm) - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), V_H_AO_cfm, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), cfm_real_part) - CALL cp_cfm_release(cfm_real_part) - ELSE - CALL cp_fm_to_cfm(msourcer=fm_v, mtarget=V_H_AO_cfm) - END IF - - CALL cp_fm_release(fm_v) - - CALL timestop(handle) - - END SUBROUTINE compute_hartree_ri_rs_from_diag - -! ************************************************************************************************** -!> \brief Complex-input Hartree potential via RI-RS. Re/Im split: feed each part to the real -!> compute_hartree_ri_rs and reassemble. Real-input Hartree on a non-Hermitian input -!> would silently drop Im and break Hermitian conjugacy of OV+VO contributions in TDA. -!> \param bs_env ... -!> \param rho_AO_cfm input AO x AO complex density-like matrix -!> \param V_H_AO_cfm output AO x AO complex Hartree potential -! ************************************************************************************************** - SUBROUTINE compute_hartree_ri_rs_complex(bs_env, rho_AO_cfm, V_H_AO_cfm) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(cp_cfm_type), INTENT(IN) :: rho_AO_cfm - TYPE(cp_cfm_type), INTENT(INOUT) :: V_H_AO_cfm - - CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_hartree_ri_rs_complex' - - INTEGER :: handle - TYPE(cp_cfm_type) :: cfm_real_part - TYPE(cp_fm_type) :: fm_rho, fm_v - - CALL timeset(routineN, handle) - - CALL cp_fm_create(fm_rho, bs_env%fm_s_Gamma%matrix_struct) - CALL cp_fm_create(fm_v, bs_env%fm_s_Gamma%matrix_struct) - CALL cp_cfm_create(cfm_real_part, bs_env%fm_s_Gamma%matrix_struct) - - CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargetr=fm_rho) - CALL compute_hartree_ri_rs(bs_env, fm_rho, fm_v) - CALL cp_fm_to_cfm(msourcer=fm_v, mtarget=cfm_real_part) - - CALL cp_cfm_to_fm(msource=rho_AO_cfm, mtargeti=fm_rho) - CALL compute_hartree_ri_rs(bs_env, fm_rho, fm_v) - CALL cp_fm_to_cfm(msourcei=fm_v, mtarget=V_H_AO_cfm) - - CALL cp_cfm_scale_and_add(CMPLX(1.0_dp, 0.0_dp, kind=dp), V_H_AO_cfm, & - CMPLX(1.0_dp, 0.0_dp, kind=dp), cfm_real_part) - - CALL cp_fm_release(fm_rho) - CALL cp_fm_release(fm_v) - CALL cp_cfm_release(cfm_real_part) - - CALL timestop(handle) - - END SUBROUTINE compute_hartree_ri_rs_complex - -! ************************************************************************************************** -!> \brief Scale each row of a dbcsr matrix by a replicated full-length vector: -!> block(ir,ic) <- vec(global_row(ir)) * block(ir,ic). Value mutation only. -!> \param matrix ... -!> \param vec full-length replicated row-scaling vector -! ************************************************************************************************** - SUBROUTINE dbcsr_scale_rows_replicated(matrix, vec) - - TYPE(dbcsr_type), INTENT(INOUT) :: matrix - REAL(KIND=dp), INTENT(IN) :: vec(:) - - INTEGER :: col_blk, ic, ir, nblkrows_total, & - row_blk, row_off - INTEGER, ALLOCATABLE :: row_offset(:) - INTEGER, DIMENSION(:), POINTER :: row_blk_size - REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk - TYPE(dbcsr_iterator_type) :: iter - - CALL dbcsr_get_info(matrix, nblkrows_total=nblkrows_total, row_blk_size=row_blk_size) - ALLOCATE (row_offset(nblkrows_total + 1)) - row_offset(1) = 0 - DO ir = 1, nblkrows_total - row_offset(ir + 1) = row_offset(ir) + row_blk_size(ir) - END DO - - CALL dbcsr_iterator_start(iter, matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, row_blk, col_blk, blk) - row_off = row_offset(row_blk) - DO ic = 1, SIZE(blk, 2) - DO ir = 1, SIZE(blk, 1) - blk(ir, ic) = vec(row_off + ir)*blk(ir, ic) - END DO - END DO - END DO - CALL dbcsr_iterator_stop(iter) - - DEALLOCATE (row_offset) - - END SUBROUTINE dbcsr_scale_rows_replicated - -! ************************************************************************************************** -!> \brief Replicated matvec: vec_out = matrix * vec_in (or matrix^T * vec_in if transposed) for a -!> possibly rectangular distributed dbcsr matrix and replicated full-length vectors. -!> Iterates over local blocks and reduces. -!> \param matrix distributed dbcsr matrix (may be rectangular) -!> \param vec_in full input vector, replicated on all ranks (column length, or row length if transposed) -!> \param vec_out full output vector, replicated on all ranks (zeroed on entry; sum-reduced on exit) -!> \param para_env ... -!> \param transposed if .TRUE. compute vec_out = matrix^T * vec_in -! ************************************************************************************************** - SUBROUTINE dbcsr_matvec_replicated(matrix, vec_in, vec_out, para_env, transposed) - - TYPE(dbcsr_type), INTENT(INOUT) :: matrix - REAL(KIND=dp), INTENT(IN) :: vec_in(:) - REAL(KIND=dp), INTENT(INOUT) :: vec_out(:) - TYPE(mp_para_env_type), POINTER :: para_env - LOGICAL, INTENT(IN), OPTIONAL :: transposed - - INTEGER :: col_blk, col_off, ic, ir, & - nblkcols_total, nblkrows_total, & - row_blk, row_off - INTEGER, ALLOCATABLE :: col_offset(:), row_offset(:) - INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size - LOGICAL :: my_trans - REAL(KIND=dp), DIMENSION(:, :), POINTER :: block - TYPE(dbcsr_iterator_type) :: iter - - my_trans = .FALSE. - IF (PRESENT(transposed)) my_trans = transposed - - CALL dbcsr_get_info(matrix, nblkrows_total=nblkrows_total, & - nblkcols_total=nblkcols_total, & - row_blk_size=row_blk_size, col_blk_size=col_blk_size) - - ALLOCATE (row_offset(nblkrows_total + 1), col_offset(nblkcols_total + 1)) - row_offset(1) = 0 - DO ir = 1, nblkrows_total - row_offset(ir + 1) = row_offset(ir) + row_blk_size(ir) - END DO - col_offset(1) = 0 - DO ic = 1, nblkcols_total - col_offset(ic + 1) = col_offset(ic) + col_blk_size(ic) - END DO - - vec_out(:) = 0.0_dp - - CALL dbcsr_iterator_start(iter, matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, row_blk, col_blk, block) - row_off = row_offset(row_blk) - col_off = col_offset(col_blk) - IF (my_trans) THEN - DO ic = 1, SIZE(block, 2) - DO ir = 1, SIZE(block, 1) - vec_out(col_off + ic) = vec_out(col_off + ic) + & - block(ir, ic)*vec_in(row_off + ir) - END DO - END DO - ELSE - DO ic = 1, SIZE(block, 2) - DO ir = 1, SIZE(block, 1) - vec_out(row_off + ir) = vec_out(row_off + ir) + & - block(ir, ic)*vec_in(col_off + ic) - END DO - END DO - END IF - END DO - CALL dbcsr_iterator_stop(iter) - - DEALLOCATE (row_offset, col_offset) - - CALL para_env%sum(vec_out) - - END SUBROUTINE dbcsr_matvec_replicated - -END MODULE rt_bse_ri_rs diff --git a/src/emd/rt_bse_types.F b/src/emd/rt_bse_types.F index 07e1e64872..7688b6c8d8 100644 --- a/src/emd/rt_bse_types.F +++ b/src/emd/rt_bse_types.F @@ -17,9 +17,6 @@ MODULE rt_bse_types cp_fm_release, & cp_fm_create, & cp_fm_set_all - USE cp_fm_struct, ONLY: cp_fm_struct_type, & - cp_fm_struct_create, & - cp_fm_struct_release USE cp_cfm_types, ONLY: cp_cfm_type, & cp_cfm_set_all, & cp_cfm_create, & @@ -41,24 +38,16 @@ MODULE rt_bse_types USE qs_environment_types, ONLY: qs_environment_type, & get_qs_env USE force_env_types, ONLY: force_env_type - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type, & - eps_qp_gap, & - max_qp_gap + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type USE rt_propagation_types, ONLY: rt_prop_type USE rt_propagation_utils, ONLY: warn_section_unused USE gw_integrals, ONLY: build_3c_integral_block USE gw_large_cell_Gamma, ONLY: compute_3c_integrals - USE gw_utils, ONLY: rtbse_resolve_rirs_flag USE qs_tensors, ONLY: neighbor_list_3c_destroy USE libint_2c_3c, ONLY: libint_potential_type USE input_constants, ONLY: use_mom_ref_coac, & do_bch, & - do_exact, & - rtp_bse_ham_g0w0, & - rtp_method_bse_linearized - USE bse_util, ONLY: determine_cutoff_indices - USE cp_log_handling, ONLY: cp_to_string - USE physcon, ONLY: evolt + do_exact USE mathconstants, ONLY: z_zero USE input_section_types, ONLY: section_vals_type, & section_vals_val_get, & @@ -97,22 +86,20 @@ MODULE rt_bse_types !> \param n_occ Number of occupied orbitals, spin dependent !> \param spin_degeneracy Number of electrons per orbital !> \param field Electric field calculated at the given timestep -!> \param moments Moment operators (2nd index = spin) along cartesian directions - centered at zero charge - used for plotting -!> \param moments_field Moment operators (2nd index = spin) along cartesian directions - used to coupling to the field - +!> \param moments Moment operators along cartesian directions - centered at zero charge - used for plotting +!> \param moments_field Moment operators along cartesian directions - used to coupling to the field - !> origin bound to unit cell !> \param sim_step Current step of the simulation !> \param sim_start Starting step of the simulation !> \param sim_nsteps Number of steps of the simulation !> \param sim_time Current time of the simulation !> \param sim_dt Timestep of the simulation -!> \param sim_dt_restart Original-run timestep read from the trace on restart (< 0 when not a restart) !> \param etrs_threshold Self-consistency threshold for enforced time reversal symmetry propagation !> \param exp_accuracy Threshold for matrix exponential calculation !> \param dft_control DFT control parameters !> \param ham_effective Real and imaginary part of the effective Hamiltonian used to propagate !> the density matrix -!> \param ham_reference Reference Hamiltonian, which does not change in the -!> propagation = DFT+G0W0 - initial Hartree - initial COHSEX +!> \param ham_reference Reference Hamiltonian, which does not change in the propagation = DFT+G0W0 - initial Hartree - initial COHSEX !> \param ham_workspace Workspace matrices for use with the Hamiltonian propagation - storage of !> exponential propagators etc. !> \param rho Density matrix at the current time step @@ -152,79 +139,21 @@ MODULE rt_bse_types n_ao = -1, & n_RI = -1 INTEGER, DIMENSION(2) :: n_occ = -1 - ! Active MO window for linearized RT-BSE truncation. When no truncation is requested, - ! first_active_mo=1, last_active_mo=n_ao, and mo_active=n_ao. The window is the - ! combined inclusive bound that covers both spin channels. - INTEGER :: first_active_mo = 1, & - last_active_mo = -1, & - mo_active = -1 - REAL(KIND=dp) :: rtbse_energy_cutoff_occ = -1.0_dp, & - rtbse_energy_cutoff_empty = -1.0_dp - LOGICAL :: active_mo_truncation = .FALSE. - LOGICAL :: linearized = .FALSE. - ! Tamm-Dancoff approximation switch (linearized RT-BSE only). - LOGICAL :: tda_active = .FALSE. - ! First-peak shift for the TDA path (linearized RT-BSE only). - ! Shifts active-MO single-particle diagonals by +Omega_0/2 (occ) / -Omega_0/2 (virt) - ! with Omega_0 = eps_min_ai so the lowest active OV mode oscillates at zero in the - ! rotating frame (RK4-exact for peak 1). omega_max becomes the full active OV width - ! Delta = eps_max_ai - eps_min_ai. The resulting rotating-frame density is undone - ! at I/O so observables stay lab-frame. - LOGICAL :: tda_shift_to_first_peak = .FALSE. - REAL(kind=dp) :: omega_shift = 0.0_dp - ! Debug-only kernel switches shared by initialization and propagation. - LOGICAL :: debug_disable_hartree = .FALSE., & - debug_disable_sex = .FALSE. - ! RI framework for the linRTBSE Hartree + screened-exchange kernels, set by the KERNEL_RI - ! input keyword (DEFAULT inherits bs_env%do_gw_ri_rs; RS/AO force; full RT-BSE forced AO). - ! .TRUE. = RI-RS grid kernels, .FALSE. = AO-RI. The required grid and V_grid/W0_grid - ! kernels are built on demand and reused across steps. - LOGICAL :: rirs_kernel = .FALSE. - ! Liouvillian eigenvalue diagnostic (TDA + n_spin=1 only). When .TRUE., at job - ! init the linearized RT-BSE assembles the OV-subspace Liouvillian by probing - ! apply_liouvillian_to_drho with canonical OV basis vectors and diagonalizes - ! via cp_cfm_heevd. In TDA this equals the Casida-A eigenvalue problem. - ! Run once, no propagation impact. - LOGICAL :: diagnose_liouvillian_eig = .FALSE. - ! Whether to enforce max_dt within stability region of rk4 - LOGICAL :: enforce_max_dt = .FALSE. - ! Owned fm structures sized to the active MO window. Equal to the full n_ao x n_ao - ! when no truncation is active. - TYPE(cp_fm_struct_type), POINTER :: fm_struct_mo_active => NULL() - ! n_ao x mo_active fm struct used for C_active and AO<->MO rectangular intermediates. - TYPE(cp_fm_struct_type), POINTER :: fm_struct_ao_mo_active => NULL() - ! Liouvillian-diagnostic struct: (N_OV_joint x N_OV_joint), spin blocks stacked, on the - ! same BLACS context as fm_struct_mo_active. Allocated only when diagnose_liouvillian_eig=.TRUE.. - TYPE(cp_fm_struct_type), POINTER :: fm_struct_ov_pairs => NULL() - ! Truncated MO coefficient slabs C_active(:,:) of size n_ao x mo_active for each spin - ! (only allocated for the linearized path). - TYPE(cp_fm_type), DIMENSION(:), POINTER :: C_active => NULL() - ! Rectangular n_ao x mo_active scratch used by linearized AO<->MO transforms. - TYPE(cp_fm_type), DIMENSION(:), POINTER :: ao_mo_workspace => NULL() REAL(kind=dp) :: spin_degeneracy = 2 REAL(kind=dp), DIMENSION(3) :: field = 0.0_dp - TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: moments => NULL(), & + TYPE(cp_fm_type), DIMENSION(:), POINTER :: moments => NULL(), & moments_field => NULL() INTEGER :: sim_step = 0, & sim_start = 0, & - ! Needed to continue runs by loading previous moments trace + ! Needed for continuation runs for loading of previous moments trace sim_start_orig = 0, & sim_nsteps = -1, & ! Default reference point type for output moments ! Field moments always use zero reference moment_ref_type = use_mom_ref_coac - ! Restart output bookkeeping: RESTART.trace header+prefix and (linearized) C_active are - ! (re)written on the first output_restart call of a run, then .trace is appended per step. - LOGICAL :: restart_trace_written = .FALSE., & - restart_C_written = .FALSE. REAL(kind=dp), DIMENSION(:), POINTER :: user_moment_ref_point => NULL() REAL(kind=dp) :: sim_time = 0.0_dp, & sim_dt = 0.1_dp, & - ! Original-run dt from the trace header on restart (< 0 when not - ! a restart); ENFORCE_MAX_DT reuses it instead of recomputing dt - sim_dt_restart = -1.0_dp, & - maximum_timestep = -1.0_dp, & - omega_max = -1.0_dp, & etrs_threshold = 1.0e-7_dp, & exp_accuracy = 1.0e-10_dp, & ft_damping = 0.0_dp, & @@ -241,7 +170,6 @@ MODULE rt_bse_types rho_section => NULL(), & ft_section => NULL(), & pol_section => NULL(), & - eig_section => NULL(), & moments_section => NULL(), & rtp_section => NULL() LOGICAL :: restart_extracted = .FALSE. @@ -249,64 +177,16 @@ MODULE rt_bse_types ! Different indices signify different spins TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_effective => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_reference => NULL() - !Only for linearised RTBSE - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_reference_singleparticle => NULL() - ! Active single-particle energies = diag(ham_reference_singleparticle), replicated over all - ! ranks. Drives the [H^0,rho]_mn = (eps_m - eps_n) rho_mn element-wise commutator (mo_active x n_spin). - REAL(kind=dp), DIMENSION(:, :), POINTER :: eps_active => NULL() - ! Original run's active eigenvalues stashed from RESTART.trace at read time; compared against - ! the recomputed eps_active once the Hamiltonian is built (consistency heads-up), then freed. - REAL(kind=dp), DIMENSION(:, :), POINTER :: eps_active_restart => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: ham_workspace => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: sigma_SEX => NULL() TYPE(cp_fm_type), DIMENSION(:), POINTER :: sigma_COH => NULL(), & hartree_curr => NULL() - ! AO-sized scratch buffers used in the linearized RT-BSE path so that the MO-sized - ! sigma_COH/sigma_SEX/hartree_curr matrices above can be allocated on - ! fm_struct_mo_active. Only allocated when linearized=.TRUE.. - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: sigma_SEX_ao => NULL() - TYPE(cp_fm_type), DIMENSION(:), POINTER :: hartree_curr_ao => NULL() - ! Open-shell cross-spin Hartree (TDA AO-RI), single shared AO buffers built once per - ! RK4 stage: rho_total_ao_scratch (fm_s struct, matches rho_ao_scratch for the spin sum); - ! hartree_total_ao = V_H[sum] (fm_ks struct, matches sigma_SEX_ao as the Hartree output). - TYPE(cp_cfm_type) :: rho_total_ao_scratch = cp_cfm_type(), & - hartree_total_ao = cp_cfm_type() - ! RI-RS Hartree diagonal reuse: spin-summed grid density n_l = diag(phi.rho.phi^T), harvested - ! from the SEX rho_grid (before its Hadamard, scaled by spin_degeneracy) and consumed by - ! compute_hartree_ri_rs_from_diag so Hartree never rebuilds the grid product. Re/Im; sized - ! n_grid; allocated in initialize_hartree_potential when rirs_kernel. rtbse_env-owned (not - ! bs_env%ri_rs) to avoid aliasing bs_env when passed through get_sigma_complex. - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: hartree_diag_re, hartree_diag_im - ! mo_active x mo_active real workspace pair used in MO-side transforms (linearized only). - TYPE(cp_fm_type), DIMENSION(:), POINTER :: real_workspace_mo => NULL() - ! Liouvillian-diagnostic scratch (allocated only when diagnose_liouvillian_eig=.TRUE.). - ! drho_probe(:) / L_drho(:) are per-spin arrays on fm_struct_mo_active: the joint TDA - ! diagnostic probes one spin and reads the Liouvillian response on every spin block. - ! L_pairs / eigvecs_pairs live on fm_struct_ov_pairs (N_OV_joint x N_OV_joint, the spin - ! blocks stacked). A_mat / B_mat / AmB_scratch / ApB_scratch are ABBA-only blocks holding - ! A, B, (A-B) -> (A-B)^{1/2}, and (A+B) for the Furche reduction; allocated only - ! when .NOT. tda_active (n_spin=1; TDA path uses L_pairs alone). - ! eigenvalues_liouvillian holds the N_OV_joint real eigenvalues from cp_cfm_heevd. - TYPE(cp_cfm_type) :: L_pairs = cp_cfm_type(), & - eigvecs_pairs = cp_cfm_type(), & - A_mat = cp_cfm_type(), & - B_mat = cp_cfm_type(), & - AmB_scratch = cp_cfm_type(), & - ApB_scratch = cp_cfm_type() - REAL(kind=dp), DIMENSION(:), POINTER :: eigenvalues_liouvillian => NULL() TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho => NULL(), & rho_new => NULL(), & rho_new_last => NULL(), & rho_M => NULL(), & - rho_orig => NULL(), & - rho_ao_scratch => NULL(), & - rho_delta_mo => NULL(), & - drho_probe => NULL(), & - L_drho => NULL() - ! Workspace for rk4 in linearized RTBSE - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rk4_coefficients => NULL() - + rho_orig => NULL() TYPE(cp_fm_type) :: S_inv_fm = cp_fm_type(), & S_fm = cp_fm_type() ! Many routines require overlap in the complex format @@ -317,8 +197,6 @@ MODULE rt_bse_types TYPE(cp_cfm_type), DIMENSION(:), POINTER :: rho_workspace => NULL() ! Many methods use real and imaginary parts separately - prevent unnecessary reallocation TYPE(cp_fm_type), DIMENSION(:), POINTER :: real_workspace => NULL() - ! AO-sized complex scratch used to stage the real part in get_sigma_complex. - TYPE(cp_cfm_type), DIMENSION(:), POINTER :: sigma_complex_workspace => NULL() ! Workspace required for exact matrix exponentiation REAL(kind=dp), DIMENSION(:), POINTER :: real_eigvals => NULL() COMPLEX(kind=dp), DIMENSION(:), POINTER :: exp_eigvals => NULL() @@ -368,29 +246,26 @@ CONTAINS ! ************************************************************************************************** !> \brief Allocates structures and prepares rtbse_env for run !> \param rtbse_env rtbse_env_type that is initialised -!> \param force_env Force environment - entry point of the calculation -!> \param linearized Optional; when present and .TRUE., configure the environment for the linearized RT-BSE path +!> \param qs_env Entry point of the calculation !> \author Stepan Marek !> \date 02.2024 ! ************************************************************************************************** - SUBROUTINE create_rtbse_env(rtbse_env, force_env, linearized) + SUBROUTINE create_rtbse_env(rtbse_env, qs_env, force_env) TYPE(rtbse_env_type), POINTER :: rtbse_env + TYPE(qs_environment_type), POINTER :: qs_env TYPE(force_env_type), POINTER :: force_env - LOGICAL, OPTIONAL :: linearized TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(rt_prop_type), POINTER :: rtp TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s TYPE(mo_set_type), DIMENSION(:), POINTER :: mos - INTEGER :: i, k, n_ov, i_spin + INTEGER :: i, k TYPE(section_vals_type), POINTER :: input, bs_sec, md_sec - TYPE(cp_fm_struct_type), POINTER :: mo_struct ! Allocate the storage for the gwbse environment - NULLIFY (rtbse_env, mo_struct) + NULLIFY (rtbse_env) ALLOCATE (rtbse_env) - IF (PRESENT(linearized)) rtbse_env%linearized = linearized ! Extract the other types first - CALL get_qs_env(force_env%qs_env, & + CALL get_qs_env(qs_env, & bs_env=bs_env, & rtp=rtp, & matrix_s=matrix_s, & @@ -403,14 +278,6 @@ CONTAINS END IF ! Number of spins rtbse_env%n_spin = bs_env%n_spin - ! Open shell (n_spin>1) is only implemented and tested for the linearized - ! propagation; the full RT-BSE open-shell path is untested. - IF (rtbse_env%n_spin > 1 .AND. .NOT. rtbse_env%linearized) THEN - CALL cp_abort(__LOCATION__, & - "Open-shell (n_spin>1) RT-BSE is only implemented and tested for the "// & - "linearized propagation. Set DFT%REAL_TIME_PROPAGATION%RTBSE%LRRTBSE "// & - ".TRUE.; the full (non-linearized) open-shell RT-BSE path is untested.") - END IF ! Number of atomic orbitals rtbse_env%n_ao = bs_env%n_ao ! Number of auxiliary basis orbitals @@ -438,74 +305,6 @@ CONTAINS i_val=rtbse_env%etrs_max_iter) CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%MAT_EXP", & i_val=rtbse_env%mat_exp_method) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%ENERGY_CUTOFF_OCC", & - r_val=rtbse_env%rtbse_energy_cutoff_occ) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%ENERGY_CUTOFF_EMPTY", & - r_val=rtbse_env%rtbse_energy_cutoff_empty) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%TDA", & - l_val=rtbse_env%tda_active) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%TDA_SHIFT_TO_FIRST_PEAK", & - l_val=rtbse_env%tda_shift_to_first_peak) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%ENFORCE_MAX_DT", & - l_val=rtbse_env%enforce_max_dt) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%DEBUG_DISABLE_HARTREE", & - l_val=rtbse_env%debug_disable_hartree) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%DEBUG_DISABLE_SEX", & - l_val=rtbse_env%debug_disable_sex) - ! RI-RS kernel switch (KERNEL_RI: DEFAULT=do_gw_ri_rs, RS/AO force, full-RTBSE force-off) - ! is resolved by the shared helper so de_init_bs_env reaches the same verdict when - ! deciding whether to retain nl_3c. - CALL rtbse_resolve_rirs_flag(force_env%qs_env, bs_env, rirs_kernel=rtbse_env%rirs_kernel) - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%DIAGNOSE_LIOUVILLIAN_EIG", & - l_val=rtbse_env%diagnose_liouvillian_eig) - - IF (.NOT. rtbse_env%dft_control%rtp_control%rtp_method == rtp_method_bse_linearized) THEN - rtbse_env%rtbse_energy_cutoff_occ = -1.0_dp - rtbse_env%rtbse_energy_cutoff_empty = -1.0_dp - rtbse_env%enforce_max_dt = .FALSE. - rtbse_env%debug_disable_hartree = .FALSE. - rtbse_env%debug_disable_sex = .FALSE. - rtbse_env%tda_shift_to_first_peak = .FALSE. - ! rirs_kernel is already forced .FALSE. here by rtbse_resolve_rirs_flag. - rtbse_env%diagnose_liouvillian_eig = .FALSE. - END IF - ! First-peak shift only makes sense within TDA; force-disable otherwise. - IF (.NOT. rtbse_env%tda_active) rtbse_env%tda_shift_to_first_peak = .FALSE. - rtbse_env%omega_shift = 0.0_dp - - IF (rtbse_env%tda_active .AND. .NOT. rtbse_env%linearized) THEN - CPABORT("RTBSE TDA keyword requires LINEARIZED_BSE_PROPAGATION=.TRUE.") - END IF - ! Open shell: omega_shift would be referenced to a non-physical cross-spin - ! pseudo-gap (global MIN/MAX over both spins); abort until made per-spin. - IF (rtbse_env%tda_shift_to_first_peak .AND. rtbse_env%n_spin > 1) THEN - CALL cp_abort(__LOCATION__, & - "TDA_SHIFT_TO_FIRST_PEAK is not implemented for open-shell (n_spin>1) "// & - "systems - the first-peak gap estimate would mix spin channels. "// & - "Set TDA_SHIFT_TO_FIRST_PEAK=.FALSE. for open-shell runs.") - END IF - CALL check_qp_gap_sanity(rtbse_env, bs_env) - CALL determine_active_mo_window(rtbse_env, bs_env) - ! Owned active-MO matrix structure (currently identical to the full n_ao x n_ao struct - ! when no truncation is active; will be used by the linearized RT-BSE allocation path). - NULLIFY (rtbse_env%fm_struct_mo_active) - CALL cp_fm_struct_create(rtbse_env%fm_struct_mo_active, & - bs_env%fm_ks_Gamma(1)%matrix_struct%para_env, & - bs_env%fm_ks_Gamma(1)%matrix_struct%context, & - rtbse_env%mo_active, rtbse_env%mo_active) - ! Rectangular n_ao x mo_active struct used for C_active and AO<->MO intermediates - NULLIFY (rtbse_env%fm_struct_ao_mo_active) - CALL cp_fm_struct_create(rtbse_env%fm_struct_ao_mo_active, & - bs_env%fm_ks_Gamma(1)%matrix_struct%para_env, & - bs_env%fm_ks_Gamma(1)%matrix_struct%context, & - rtbse_env%n_ao, rtbse_env%mo_active) - ! Choose the matrix struct used for MO-side persistent matrices. - ! Linearized RT-BSE: mo_active x mo_active. Full RT-BSE: full AO struct (unchanged). - IF (rtbse_env%linearized) THEN - mo_struct => rtbse_env%fm_struct_mo_active - ELSE - mo_struct => bs_env%fm_ks_Gamma(1)%matrix_struct - END IF ! Output unit number, recovered from the post_scf_bandstructure_type rtbse_env%unit_nr = bs_env%unit_nr ! Sim start index and total number of steps as well @@ -532,7 +331,6 @@ CONTAINS rtbse_env%rho_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%DENSITY_MATRIX") rtbse_env%ft_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%MOMENTS_FT") rtbse_env%pol_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%POLARIZABILITY") - rtbse_env%eig_section => section_vals_get_subs_vals(rtbse_env%rtp_section, "PRINT%LIOUVILLIAN_EIG") ! Warn the user about print sections which are not yet implemented in the RTBSE run CALL warn_section_unused(rtbse_env%rtp_section, "PRINT%CURRENT", & "CURRENT print section not yet implemented for RTBSE.") @@ -544,8 +342,8 @@ CONTAINS "PROJECTION_MO print section not yet implemented for RTBSE.") CALL warn_section_unused(rtbse_env%rtp_section, "PRINT%RESTART_HISTORY", & "RESTART_HISTORY print section not yet implemented for RTBSE.") - ! References to the parent qs_env / bs_env - rtbse_env%qs_env => force_env%qs_env + ! DEBUG : References to previous environments + rtbse_env%qs_env => qs_env rtbse_env%bs_env => bs_env ! Padé refinement rtbse_env%pade_requested = rtbse_env%dft_control%rtp_control%pade_requested @@ -564,69 +362,45 @@ CONTAINS END DO END IF - ! Allocate moments matrices. - ! In linearized RT-BSE these store the MO-active transformed dipole moments; - ! in full RT-BSE they remain AO-sized (initialized from overlap template). + ! Allocate moments matrices NULLIFY (rtbse_env%moments) - ALLOCATE (rtbse_env%moments(3, rtbse_env%n_spin)) + ALLOCATE (rtbse_env%moments(3)) NULLIFY (rtbse_env%moments_field) - ALLOCATE (rtbse_env%moments_field(3, rtbse_env%n_spin)) - DO i_spin = 1, rtbse_env%n_spin - DO k = 1, 3 - CALL cp_fm_create(rtbse_env%moments(k, i_spin), mo_struct) - CALL cp_fm_create(rtbse_env%moments_field(k, i_spin), mo_struct) - END DO + ALLOCATE (rtbse_env%moments_field(3)) + DO k = 1, 3 + ! Matrices are created from overlap template + ! Values are initialized in initialize_rtbse_env + CALL cp_fm_create(rtbse_env%moments(k), bs_env%fm_s_Gamma%matrix_struct) + CALL cp_fm_create(rtbse_env%moments_field(k), bs_env%fm_s_Gamma%matrix_struct) END DO - ! Allocate space for density propagation and other operations. - ! In linearized RT-BSE these workspaces are MO-active sized; in full RT-BSE - ! they remain at the full AO size. + ! Allocate space for density propagation and other operations NULLIFY (rtbse_env%rho_workspace) ALLOCATE (rtbse_env%rho_workspace(4)) DO i = 1, SIZE(rtbse_env%rho_workspace) - CALL cp_cfm_create(rtbse_env%rho_workspace(i), mo_struct) + CALL cp_cfm_create(rtbse_env%rho_workspace(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_cfm_set_all(rtbse_env%rho_workspace(i), CMPLX(0.0, 0.0, kind=dp)) END DO - - ! TODO: gate workspace allocation so methods skip workspaces they don't need - ! Allocate real workspace NULLIFY (rtbse_env%real_workspace) - IF (rtbse_env%linearized) THEN + SELECT CASE (rtbse_env%mat_exp_method) + CASE (do_exact) + ALLOCATE (rtbse_env%real_workspace(4)) + CASE (do_bch) ALLOCATE (rtbse_env%real_workspace(2)) - ELSE - SELECT CASE (rtbse_env%mat_exp_method) - CASE (do_exact) - ALLOCATE (rtbse_env%real_workspace(4)) - CASE (do_bch) - ALLOCATE (rtbse_env%real_workspace(2)) - CASE DEFAULT - CPABORT("Only exact and BCH matrix propagation implemented in RT-BSE") - END SELECT - END IF + CASE DEFAULT + CPABORT("Only exact and BCH matrix propagation implemented in RT-BSE") + END SELECT DO i = 1, SIZE(rtbse_env%real_workspace) CALL cp_fm_create(rtbse_env%real_workspace(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_fm_set_all(rtbse_env%real_workspace(i), 0.0_dp) END DO - NULLIFY (rtbse_env%sigma_complex_workspace) - ALLOCATE (rtbse_env%sigma_complex_workspace(1)) - CALL cp_cfm_create(rtbse_env%sigma_complex_workspace(1), bs_env%fm_ks_Gamma(1)%matrix_struct) - CALL cp_cfm_set_all(rtbse_env%sigma_complex_workspace(1), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - ! Allocate density matrix (MO-active sized when linearized; AO-sized otherwise) + ! Allocate density matrix NULLIFY (rtbse_env%rho) ALLOCATE (rtbse_env%rho(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%rho(i), matrix_struct=mo_struct) + CALL cp_cfm_create(rtbse_env%rho(i), matrix_struct=bs_env%fm_s_Gamma%matrix_struct) END DO - ! Allocate additional space for AO density matrix - ! in linearised RTBSE, where default is MO - IF (rtbse_env%linearized) THEN - NULLIFY (rtbse_env%rho_ao_scratch) - ALLOCATE (rtbse_env%rho_ao_scratch(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%rho_ao_scratch(i), matrix_struct=bs_env%fm_s_Gamma%matrix_struct) - END DO - END IF ! Create the inverse overlap matrix, for use in density propagation ! Start by creating the actual overlap matrix CALL cp_fm_create(rtbse_env%S_fm, bs_env%fm_s_Gamma%matrix_struct) @@ -634,32 +408,19 @@ CONTAINS CALL cp_cfm_create(rtbse_env%S_cfm, bs_env%fm_s_Gamma%matrix_struct) ! Create the single particle hamiltonian - ! Allocate workspace (MO-active sized in linearized RT-BSE; AO sized otherwise) + ! Allocate workspace NULLIFY (rtbse_env%ham_workspace) ALLOCATE (rtbse_env%ham_workspace(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_workspace(i), mo_struct) + CALL cp_cfm_create(rtbse_env%ham_workspace(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_cfm_set_all(rtbse_env%ham_workspace(i), CMPLX(0.0, 0.0, kind=dp)) END DO ! Now onto the Hamiltonian itself - ! full RTBSE: Contains energy differences and Hartree/COHSEX ρ_0 parts - ! linearised RTBSE: Contains only the Hartree/SEX ρ_0 parts as Δε * Δρ(t) need to be updated NULLIFY (rtbse_env%ham_reference) ALLOCATE (rtbse_env%ham_reference(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_reference(i), mo_struct) + CALL cp_cfm_create(rtbse_env%ham_reference(i), bs_env%fm_ks_Gamma(i)%matrix_struct) END DO - ! Single particle Hamiltonian (Δε * Δρ(t)) for updates during timesteps in LR-RTBSE - IF (rtbse_env%linearized) THEN - NULLIFY (rtbse_env%ham_reference_singleparticle) - ALLOCATE (rtbse_env%ham_reference_singleparticle(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_reference_singleparticle(i), mo_struct) - END DO - NULLIFY (rtbse_env%eps_active) - ALLOCATE (rtbse_env%eps_active(rtbse_env%mo_active, rtbse_env%n_spin)) - rtbse_env%eps_active(:, :) = 0.0_dp - END IF ! Create the matrices and workspaces for ETRS propagation NULLIFY (rtbse_env%ham_effective) @@ -673,30 +434,17 @@ CONTAINS ALLOCATE (rtbse_env%rho_M(rtbse_env%n_spin)) ALLOCATE (rtbse_env%rho_orig(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%ham_effective(i), mo_struct) + CALL cp_cfm_create(rtbse_env%ham_effective(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_cfm_set_all(rtbse_env%ham_effective(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_new(i), mo_struct) + CALL cp_cfm_create(rtbse_env%rho_new(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_cfm_set_all(rtbse_env%rho_new(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_new_last(i), mo_struct) + CALL cp_cfm_create(rtbse_env%rho_new_last(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_cfm_set_all(rtbse_env%rho_new_last(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_M(i), mo_struct) + CALL cp_cfm_create(rtbse_env%rho_M(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_cfm_set_all(rtbse_env%rho_M(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_cfm_create(rtbse_env%rho_orig(i), mo_struct) + CALL cp_cfm_create(rtbse_env%rho_orig(i), bs_env%fm_ks_Gamma(1)%matrix_struct) END DO - !For LR-RTBSE we need RK4 coefficients - create new workspace - IF (rtbse_env%linearized) THEN - ! Indexed by SPIN, not by RK4 stage: the spin loop is inner to each stage (do_rk4_stage), so every - ! spin's current-stage k must be live at once, but only one stage's k per spin - each is folded - ! into rho_end and the next stage density before the next stage overwrites it. Hence size n_spin. - NULLIFY (rtbse_env%rk4_coefficients) - ALLOCATE (rtbse_env%rk4_coefficients(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%rk4_coefficients(i), mo_struct) - CALL cp_cfm_set_all(rtbse_env%rk4_coefficients(i), CMPLX(0.0, 0.0, kind=dp)) - END DO - END IF - ! Fields for exact diagonalisation NULLIFY (rtbse_env%real_eigvals) ALLOCATE (rtbse_env%real_eigvals(rtbse_env%n_ao)) @@ -714,9 +462,7 @@ CONTAINS NULLIFY (rtbse_env%time_trace) ALLOCATE (rtbse_env%time_trace(rtbse_env%sim_nsteps + 1), source=0.0_dp) - ! Allocate self-energy parts and dynamic Hartree potential. - ! In linearized RT-BSE these matrices hold the MO-active-sized result of the - ! AO->MO transform; the AO-sized buffer is allocated as sigma_*_ao below. + ! Allocate self-energy parts and dynamic Hartree potential NULLIFY (rtbse_env%hartree_curr) NULLIFY (rtbse_env%sigma_SEX) NULLIFY (rtbse_env%sigma_COH) @@ -724,111 +470,19 @@ CONTAINS ALLOCATE (rtbse_env%sigma_SEX(rtbse_env%n_spin)) ALLOCATE (rtbse_env%sigma_COH(rtbse_env%n_spin)) DO i = 1, rtbse_env%n_spin - CALL cp_fm_create(rtbse_env%sigma_COH(i), mo_struct) - CALL cp_cfm_create(rtbse_env%sigma_SEX(i), mo_struct) - CALL cp_fm_create(rtbse_env%hartree_curr(i), mo_struct) + CALL cp_fm_create(rtbse_env%sigma_COH(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_cfm_create(rtbse_env%sigma_SEX(i), bs_env%fm_ks_Gamma(1)%matrix_struct) + CALL cp_fm_create(rtbse_env%hartree_curr(i), bs_env%fm_ks_Gamma(1)%matrix_struct) CALL cp_fm_set_all(rtbse_env%sigma_COH(i), 0.0_dp) CALL cp_cfm_set_all(rtbse_env%sigma_SEX(i), CMPLX(0.0, 0.0, kind=dp)) CALL cp_fm_set_all(rtbse_env%hartree_curr(i), 0.0_dp) END DO - ! AO-sized scratch buffers used by the linearized RT-BSE path - IF (rtbse_env%linearized) THEN - NULLIFY (rtbse_env%hartree_curr_ao) - NULLIFY (rtbse_env%sigma_SEX_ao) - ALLOCATE (rtbse_env%hartree_curr_ao(rtbse_env%n_spin)) - ALLOCATE (rtbse_env%sigma_SEX_ao(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%sigma_SEX_ao(i), bs_env%fm_ks_Gamma(1)%matrix_struct) - CALL cp_fm_create(rtbse_env%hartree_curr_ao(i), bs_env%fm_ks_Gamma(1)%matrix_struct) - CALL cp_cfm_set_all(rtbse_env%sigma_SEX_ao(i), CMPLX(0.0, 0.0, kind=dp)) - CALL cp_fm_set_all(rtbse_env%hartree_curr_ao(i), 0.0_dp) - END DO - ! mo_active x mo_active real workspace pair for MO-side intermediates - NULLIFY (rtbse_env%real_workspace_mo) - ALLOCATE (rtbse_env%real_workspace_mo(2)) - DO i = 1, SIZE(rtbse_env%real_workspace_mo) - CALL cp_fm_create(rtbse_env%real_workspace_mo(i), rtbse_env%fm_struct_mo_active) - CALL cp_fm_set_all(rtbse_env%real_workspace_mo(i), 0.0_dp) - END DO - NULLIFY (rtbse_env%ao_mo_workspace) - ALLOCATE (rtbse_env%ao_mo_workspace(1)) - CALL cp_fm_create(rtbse_env%ao_mo_workspace(1), rtbse_env%fm_struct_ao_mo_active) - CALL cp_fm_set_all(rtbse_env%ao_mo_workspace(1), 0.0_dp) - ! Truncated MO coefficient slabs C_active (n_ao x mo_active) for each spin. - ! Filled in initialize_rtbse_env from bs_env%fm_mo_coeff_Gamma via submatrix copy. - NULLIFY (rtbse_env%C_active) - ALLOCATE (rtbse_env%C_active(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_fm_create(rtbse_env%C_active(i), rtbse_env%fm_struct_ao_mo_active) - CALL cp_fm_set_all(rtbse_env%C_active(i), 0.0_dp) - END DO - ! Masked-copy staging scratch for the builder (all propagation paths including closed-shell ABBA). - ! Also used as conjugate-transpose scratch in the TDA consumer. - NULLIFY (rtbse_env%rho_delta_mo) - ALLOCATE (rtbse_env%rho_delta_mo(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%rho_delta_mo(i), rtbse_env%fm_struct_mo_active) - CALL cp_cfm_set_all(rtbse_env%rho_delta_mo(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - ! Shared AO Hartree buffers: widened from (tda_active .OR. n_spin>1) so n_spin=1 ABBA - ! (diagnostic + propagator) gets a dedicated buffer instead of aliasing sigma_SEX_ao. - IF (.NOT. rtbse_env%debug_disable_hartree) THEN - CALL cp_cfm_create(rtbse_env%rho_total_ao_scratch, bs_env%fm_s_Gamma%matrix_struct) - CALL cp_cfm_create(rtbse_env%hartree_total_ao, bs_env%fm_ks_Gamma(1)%matrix_struct) - CALL cp_cfm_set_all(rtbse_env%rho_total_ao_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_cfm_set_all(rtbse_env%hartree_total_ao, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END IF - ! Liouvillian-eigenvalue diagnostic state. n_spin=1 enforced upstream. - ! Shared scratch (TDA + ABBA) allocated on diagnose_liouvillian_eig=T; - ! ABBA-only A/B/A±B blocks added below under .NOT. tda_active. Mirror of the - ! existing shared-scratch pattern, with the extra tda_active gate as the deviation. - IF (rtbse_env%diagnose_liouvillian_eig) THEN - ! Joint OV dimension: the spin blocks are stacked (n_spin=1 -> the old single-spin - ! size). drho_probe/L_drho stay mo_active-sized per spin; L_pairs is N_OV_joint. - n_ov = 0 - DO i = 1, rtbse_env%n_spin - n_ov = n_ov + (rtbse_env%n_occ(i) - rtbse_env%first_active_mo + 1)* & - (rtbse_env%last_active_mo - rtbse_env%n_occ(i)) - END DO - NULLIFY (rtbse_env%fm_struct_ov_pairs) - CALL cp_fm_struct_create(rtbse_env%fm_struct_ov_pairs, & - bs_env%fm_ks_Gamma(1)%matrix_struct%para_env, & - bs_env%fm_ks_Gamma(1)%matrix_struct%context, & - n_ov, n_ov) - ALLOCATE (rtbse_env%drho_probe(rtbse_env%n_spin)) - ALLOCATE (rtbse_env%L_drho(rtbse_env%n_spin)) - DO i = 1, rtbse_env%n_spin - CALL cp_cfm_create(rtbse_env%drho_probe(i), rtbse_env%fm_struct_mo_active) - CALL cp_cfm_create(rtbse_env%L_drho(i), rtbse_env%fm_struct_mo_active) - CALL cp_cfm_set_all(rtbse_env%drho_probe(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_cfm_set_all(rtbse_env%L_drho(i), CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END DO - CALL cp_cfm_create(rtbse_env%L_pairs, rtbse_env%fm_struct_ov_pairs) - CALL cp_cfm_create(rtbse_env%eigvecs_pairs, rtbse_env%fm_struct_ov_pairs) - CALL cp_cfm_set_all(rtbse_env%L_pairs, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_cfm_set_all(rtbse_env%eigvecs_pairs, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - NULLIFY (rtbse_env%eigenvalues_liouvillian) - ALLOCATE (rtbse_env%eigenvalues_liouvillian(n_ov)) - rtbse_env%eigenvalues_liouvillian = 0.0_dp - ! ABBA-only Furche-reduction scratch (A, B, A-B->sqrt, A+B). - IF (.NOT. rtbse_env%tda_active) THEN - CALL cp_cfm_create(rtbse_env%A_mat, rtbse_env%fm_struct_ov_pairs) - CALL cp_cfm_create(rtbse_env%B_mat, rtbse_env%fm_struct_ov_pairs) - CALL cp_cfm_create(rtbse_env%AmB_scratch, rtbse_env%fm_struct_ov_pairs) - CALL cp_cfm_create(rtbse_env%ApB_scratch, rtbse_env%fm_struct_ov_pairs) - CALL cp_cfm_set_all(rtbse_env%A_mat, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_cfm_set_all(rtbse_env%B_mat, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_cfm_set_all(rtbse_env%AmB_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - CALL cp_cfm_set_all(rtbse_env%ApB_scratch, CMPLX(0.0_dp, 0.0_dp, kind=dp)) - END IF - END IF - END IF ! Allocate workspaces for get_sigma - CALL create_sigma_workspace(rtbse_env) + CALL create_sigma_workspace(rtbse_env, qs_env) ! Depending on the chosen methods, allocate extra workspace - CALL create_hartree_ri_workspace(rtbse_env) + CALL create_hartree_ri_workspace(rtbse_env, qs_env) END SUBROUTINE create_rtbse_env @@ -864,22 +518,13 @@ CONTAINS CALL cp_cfm_release_pa1(rtbse_env%sigma_SEX) CALL cp_fm_release(rtbse_env%hartree_curr) CALL cp_cfm_release_pa1(rtbse_env%ham_reference) - IF (ASSOCIATED(rtbse_env%ham_reference_singleparticle)) THEN - CALL cp_cfm_release_pa1(rtbse_env%ham_reference_singleparticle) - END IF - IF (ASSOCIATED(rtbse_env%eps_active)) DEALLOCATE (rtbse_env%eps_active) - IF (ASSOCIATED(rtbse_env%eps_active_restart)) DEALLOCATE (rtbse_env%eps_active_restart) CALL cp_cfm_release_pa1(rtbse_env%rho) CALL cp_cfm_release_pa1(rtbse_env%rho_workspace) CALL cp_cfm_release_pa1(rtbse_env%rho_new) CALL cp_cfm_release_pa1(rtbse_env%rho_new_last) CALL cp_cfm_release_pa1(rtbse_env%rho_M) CALL cp_cfm_release_pa1(rtbse_env%rho_orig) - IF (ASSOCIATED(rtbse_env%rk4_coefficients)) THEN - CALL cp_cfm_release_pa1(rtbse_env%rk4_coefficients) - END IF CALL cp_fm_release(rtbse_env%real_workspace) - IF (ASSOCIATED(rtbse_env%sigma_complex_workspace)) CALL cp_cfm_release_pa1(rtbse_env%sigma_complex_workspace) CALL cp_fm_release(rtbse_env%S_inv_fm) CALL cp_fm_release(rtbse_env%S_fm) CALL cp_cfm_release(rtbse_env%S_cfm) @@ -902,209 +547,33 @@ CONTAINS ! Deallocate the neighbour list that is not deallocated in gw anymore IF (ASSOCIATED(rtbse_env%bs_env%nl_3c%ij_list)) CALL neighbor_list_3c_destroy(rtbse_env%bs_env%nl_3c) - ! Release linearized-only AO scratches and MO-side workspaces - IF (ASSOCIATED(rtbse_env%rho_ao_scratch)) CALL cp_cfm_release_pa1(rtbse_env%rho_ao_scratch) - IF (ASSOCIATED(rtbse_env%sigma_SEX_ao)) CALL cp_cfm_release_pa1(rtbse_env%sigma_SEX_ao) - IF (ASSOCIATED(rtbse_env%hartree_curr_ao)) CALL cp_fm_release(rtbse_env%hartree_curr_ao) - IF (ASSOCIATED(rtbse_env%real_workspace_mo)) CALL cp_fm_release(rtbse_env%real_workspace_mo) - IF (ASSOCIATED(rtbse_env%ao_mo_workspace)) CALL cp_fm_release(rtbse_env%ao_mo_workspace) - IF (ASSOCIATED(rtbse_env%C_active)) CALL cp_fm_release(rtbse_env%C_active) - IF (ASSOCIATED(rtbse_env%rho_delta_mo)) CALL cp_cfm_release_pa1(rtbse_env%rho_delta_mo) - ! Release shared bare-Hartree scratch. Mirror the alloc gate exactly (linearized .AND. - ! .NOT. debug_disable_hartree, every shell incl closed-shell ABBA) — the old - ! (tda_active .OR. n_spin>1) gate leaked both buffers on the closed-shell ABBA path. - IF (rtbse_env%linearized .AND. .NOT. rtbse_env%debug_disable_hartree) THEN - CALL cp_cfm_release(rtbse_env%rho_total_ao_scratch) - CALL cp_cfm_release(rtbse_env%hartree_total_ao) - END IF - ! Release the RI-RS Hartree diagonal-reuse accumulators (allocated in initialize_hartree_potential). - IF (ALLOCATED(rtbse_env%hartree_diag_re)) DEALLOCATE (rtbse_env%hartree_diag_re) - IF (ALLOCATED(rtbse_env%hartree_diag_im)) DEALLOCATE (rtbse_env%hartree_diag_im) - ! Release Liouvillian-diagnostic scratch (only when the diagnostic was requested). - IF (rtbse_env%diagnose_liouvillian_eig) THEN - IF (ASSOCIATED(rtbse_env%drho_probe)) CALL cp_cfm_release_pa1(rtbse_env%drho_probe) - IF (ASSOCIATED(rtbse_env%L_drho)) CALL cp_cfm_release_pa1(rtbse_env%L_drho) - CALL cp_cfm_release(rtbse_env%L_pairs) - CALL cp_cfm_release(rtbse_env%eigvecs_pairs) - IF (ASSOCIATED(rtbse_env%eigenvalues_liouvillian)) DEALLOCATE (rtbse_env%eigenvalues_liouvillian) - IF (.NOT. rtbse_env%tda_active) THEN - CALL cp_cfm_release(rtbse_env%A_mat) - CALL cp_cfm_release(rtbse_env%B_mat) - CALL cp_cfm_release(rtbse_env%AmB_scratch) - CALL cp_cfm_release(rtbse_env%ApB_scratch) - END IF - IF (ASSOCIATED(rtbse_env%fm_struct_ov_pairs)) THEN - CALL cp_fm_struct_release(rtbse_env%fm_struct_ov_pairs) - END IF - END IF - ! Release owned active-MO matrix structures - IF (ASSOCIATED(rtbse_env%fm_struct_mo_active)) THEN - CALL cp_fm_struct_release(rtbse_env%fm_struct_mo_active) - END IF - IF (ASSOCIATED(rtbse_env%fm_struct_ao_mo_active)) THEN - CALL cp_fm_struct_release(rtbse_env%fm_struct_ao_mo_active) - END IF ! Deallocate the storage for the environment itself DEALLOCATE (rtbse_env) ! Nullify to make sure it is not used again NULLIFY (rtbse_env) END SUBROUTINE release_rtbse_env - -! ************************************************************************************************** -!> \brief Abort if the quasiparticle spectrum handed to the propagator is inverted or has diverged. -!> -!> Tests the fundamental gap per spin channel - not E(HOMO+1) - E(HOMO), since G0W0 reorders levels - -!> on the very array the propagator consumes. Under RTBSE_HAMILTONIAN KS the quasiparticle energies -!> never enter the propagator, so a broken G0W0 spectrum is irrelevant there and does not abort. -!> \param rtbse_env RT-BSE environment with n_ao, n_occ, n_spin, ham_reference_type populated. -!> \param bs_env Bandstructure environment providing the eigenvalues. -! ************************************************************************************************** - SUBROUTINE check_qp_gap_sanity(rtbse_env, bs_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - INTEGER :: homo, ispin - REAL(KIND=dp) :: gap, gap_scf - - IF (rtbse_env%ham_reference_type /= rtp_bse_ham_g0w0) RETURN - - DO ispin = 1, rtbse_env%n_spin - homo = rtbse_env%n_occ(ispin) - IF (homo < 1 .OR. homo >= rtbse_env%n_ao) CYCLE - - gap = MINVAL(bs_env%eigenval_G0W0(homo + 1:rtbse_env%n_ao, 1, ispin)) - & - MAXVAL(bs_env%eigenval_G0W0(1:homo, 1, ispin)) - gap_scf = MINVAL(bs_env%eigenval_scf_Gamma(homo + 1:rtbse_env%n_ao, ispin)) - & - MAXVAL(bs_env%eigenval_scf_Gamma(1:homo, ispin)) - - ! requiring a healthy SCF gap keeps the inversion test from firing on a genuine metal - IF (gap < -eps_qp_gap .AND. gap_scf > eps_qp_gap) THEN - CALL cp_abort(__LOCATION__, & - "RTBSE: G0W0 gap of spin "//TRIM(ADJUSTL(cp_to_string(ispin)))// & - " is negative ("//TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))// & - " eV): propagating an inverted spectrum is meaningless. Check the GW "// & - "numerical parameters, or use RTBSE_HAMILTONIAN KS.") - ELSE IF (ABS(gap) > max_qp_gap) THEN - CALL cp_abort(__LOCATION__, & - "RTBSE: G0W0 gap of spin "//TRIM(ADJUSTL(cp_to_string(ispin)))// & - " is implausibly large ("// & - TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))//" eV): the GW step "// & - "has likely diverged. Check the GW numerical parameters, or use "// & - "RTBSE_HAMILTONIAN KS.") - END IF - END DO - - END SUBROUTINE check_qp_gap_sanity - -! ************************************************************************************************** -!> \brief Determine the combined active MO window for linearized RT-BSE truncation. -!> -!> Evaluates BSE-like cutoff indices per spin from the requested single-particle spectrum -!> (G0W0 or KS Gamma-point eigenvalues) and collapses them into a single combined window -!> covering both spin channels by choosing the most inclusive bounds. Issues a CPWARN if the -!> spin-resolved cutoff candidates differ. When cutoffs are disabled (or the run is not -!> linearized RT-BSE), the window is set to the full MO range. -!> \param rtbse_env RT-BSE environment with cutoff values, n_ao, n_occ, n_spin, ham_reference_type -!> already populated. -!> \param bs_env Bandstructure environment providing the eigenvalues. -! ************************************************************************************************** - SUBROUTINE determine_active_mo_window(rtbse_env, bs_env) - TYPE(rtbse_env_type), POINTER :: rtbse_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - CHARACTER(LEN=*), PARAMETER :: routineN = "determine_active_mo_window" - - INTEGER :: handle, ispin, n_ao_full, n_virt - INTEGER :: homo_red, virt_red, homo_incl, virt_incl - INTEGER :: combined_first_occ, combined_last_virt - INTEGER :: first_occ_prev, last_virt_prev - LOGICAL :: spins_differ, do_truncation - REAL(KIND=dp) :: cutoff_occ, cutoff_empty - - CALL timeset(routineN, handle) - - n_ao_full = rtbse_env%n_ao - cutoff_occ = rtbse_env%rtbse_energy_cutoff_occ - cutoff_empty = rtbse_env%rtbse_energy_cutoff_empty - do_truncation = rtbse_env%linearized .AND. (cutoff_occ > 0.0_dp .OR. cutoff_empty > 0.0_dp) - - ! Default: full MO window - rtbse_env%first_active_mo = 1 - rtbse_env%last_active_mo = n_ao_full - rtbse_env%mo_active = n_ao_full - rtbse_env%active_mo_truncation = .FALSE. - - IF (.NOT. do_truncation) THEN - CALL timestop(handle) - RETURN - END IF - - combined_first_occ = n_ao_full - combined_last_virt = 1 - first_occ_prev = -1 - last_virt_prev = -1 - spins_differ = .FALSE. - - DO ispin = 1, rtbse_env%n_spin - n_virt = n_ao_full - rtbse_env%n_occ(ispin) - ! Cut on the DFT axis, as LRBSE does: it is ascending by construction, so the window is a - ! well-defined contiguous MO range, which is all C_active can extract. The G0W0 axis is - ! not ordered. - CALL determine_cutoff_indices(bs_env%eigenval_scf_Gamma(:, ispin), & - rtbse_env%n_occ(ispin), n_virt, & - homo_red, virt_red, homo_incl, virt_incl, & - cutoff_occ, cutoff_empty) - ! Translate the per-spin candidate to global MO indices [homo_incl, homo + virt_incl] - IF (ispin > 1) THEN - IF (homo_incl /= first_occ_prev .OR. (rtbse_env%n_occ(ispin) + virt_incl) /= last_virt_prev) THEN - spins_differ = .TRUE. - END IF - END IF - first_occ_prev = homo_incl - last_virt_prev = rtbse_env%n_occ(ispin) + virt_incl - combined_first_occ = MIN(combined_first_occ, homo_incl) - combined_last_virt = MAX(combined_last_virt, rtbse_env%n_occ(ispin) + virt_incl) - END DO - - IF (spins_differ) THEN - CPWARN("RTBSE: spin-resolved active MO cutoff candidates differ; using combined window.") - END IF - - rtbse_env%first_active_mo = combined_first_occ - rtbse_env%last_active_mo = combined_last_virt - rtbse_env%mo_active = combined_last_virt - combined_first_occ + 1 - rtbse_env%active_mo_truncation = (rtbse_env%mo_active < n_ao_full) - - CALL timestop(handle) - END SUBROUTINE determine_active_mo_window - ! ************************************************************************************************** !> \brief Allocates the workspaces for Hartree RI method !> \note RI method calculates the Hartree contraction without the use of DBT, as it cannot emulate vectors !> \param rtbse_env +!> \param qs_env Quickstep environment - entry point of calculation !> \author Stepan Marek !> \date 05.2024 ! ************************************************************************************************** - SUBROUTINE create_hartree_ri_workspace(rtbse_env) + SUBROUTINE create_hartree_ri_workspace(rtbse_env, qs_env) TYPE(rtbse_env_type) :: rtbse_env + TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env - ! Skip the AO-RI Hartree scratch when the RT-BSE Hartree path is fully RI-RS. - ! In that case rho_dbcsr / v_ao_dbcsr / int_3c_array are never read. - ! get_sigma_real (AO-RI SX) used to borrow rho_dbcsr as a workspace; that - ! cross-dependency was removed by giving get_sigma_real its own local - ! dbcsr scratch (see rt_bse.F::get_sigma_real). rho_dbcsr is now AO-RI - ! Hartree only, as its name suggests. - IF (rtbse_env%rirs_kernel) RETURN - - CALL get_qs_env(rtbse_env%qs_env, bs_env=bs_env) + CALL get_qs_env(qs_env, bs_env=bs_env) CALL dbcsr_create(rtbse_env%rho_dbcsr, name="Sparse density", template=bs_env%mat_ao_ao%matrix) CALL dbcsr_create(rtbse_env%v_ao_dbcsr, name="Sparse Hartree", template=bs_env%mat_ao_ao%matrix) CALL create_hartree_ri_3c(rtbse_env%rho_dbcsr, rtbse_env%int_3c_array, rtbse_env%n_ao, rtbse_env%n_RI, & bs_env%basis_set_AO, bs_env%basis_set_RI, bs_env%i_RI_start_from_atom, & - bs_env%ri_metric, rtbse_env%qs_env, rtbse_env%unit_nr) + bs_env%ri_metric, qs_env, rtbse_env%unit_nr) END SUBROUTINE create_hartree_ri_workspace ! ************************************************************************************************** !> \brief Separated method for allocating the 3c integrals for RI Hartree @@ -1206,31 +675,27 @@ CONTAINS SUBROUTINE release_hartree_ri_workspace(rtbse_env) TYPE(rtbse_env_type) :: rtbse_env - ! Mirror the gate in create_hartree_ri_workspace and the v_dbcsr gate in - ! initialize_hartree_potential. With one KERNEL_RI switch the AO-RI Hartree - ! scratch (3c integrals + dbcsr work + v_dbcsr) is created iff `.NOT. rirs_kernel`. - IF (.NOT. rtbse_env%rirs_kernel) THEN - DEALLOCATE (rtbse_env%int_3c_array) - CALL dbcsr_release(rtbse_env%rho_dbcsr) - CALL dbcsr_release(rtbse_env%v_ao_dbcsr) - CALL dbcsr_release(rtbse_env%v_dbcsr) - END IF + DEALLOCATE (rtbse_env%int_3c_array) + + CALL dbcsr_release(rtbse_env%rho_dbcsr) + + CALL dbcsr_release(rtbse_env%v_dbcsr) + + CALL dbcsr_release(rtbse_env%v_ao_dbcsr) + END SUBROUTINE release_hartree_ri_workspace ! ************************************************************************************************** !> \brief Allocates the workspaces for self-energy determination routine !> \param rtbse_env Structure for holding information and workspace structures +!> \param qs_env Quickstep environment - entry point of calculation !> \author Stepan Marek !> \date 02.2024 ! ************************************************************************************************** - SUBROUTINE create_sigma_workspace(rtbse_env) + SUBROUTINE create_sigma_workspace(rtbse_env, qs_env) TYPE(rtbse_env_type) :: rtbse_env + TYPE(qs_environment_type), POINTER :: qs_env - ! Skip the AO-RI sigma scratch (W matrix + 3c integrals + work tensors) - ! when the RT-BSE SEX path is fully RI-RS — these workspaces are read - ! only by get_sigma in the `.NOT. rirs_kernel` branches. - IF (rtbse_env%rirs_kernel) RETURN - - CALL create_sigma_workspace_qs_only(rtbse_env%qs_env, rtbse_env%screened_dbt, rtbse_env%w_dbcsr, & + CALL create_sigma_workspace_qs_only(qs_env, rtbse_env%screened_dbt, rtbse_env%w_dbcsr, & rtbse_env%t_3c_w, rtbse_env%t_3c_work_RI_AO__AO, & rtbse_env%t_3c_work2_RI_AO__AO, rtbse_env%greens_dbt) END SUBROUTINE create_sigma_workspace @@ -1280,9 +745,6 @@ CONTAINS SUBROUTINE release_sigma_workspace(rtbse_env) TYPE(rtbse_env_type) :: rtbse_env - ! Mirror the gate in create_sigma_workspace. - IF (rtbse_env%rirs_kernel) RETURN - CALL dbt_destroy(rtbse_env%t_3c_w) CALL dbt_destroy(rtbse_env%t_3c_work_RI_AO__AO) CALL dbt_destroy(rtbse_env%t_3c_work2_RI_AO__AO) diff --git a/src/emd/rt_delta_pulse.F b/src/emd/rt_delta_pulse.F index f768c0abae..8bf9e04b2e 100644 --- a/src/emd/rt_delta_pulse.F +++ b/src/emd/rt_delta_pulse.F @@ -159,9 +159,8 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_old=mos_old, mos_new=mos_new) IF (rtp_control%apply_delta_pulse) THEN - IF (dft_control%qs_control%dftb) THEN + IF (dft_control%qs_control%dftb) & CALL build_dftb_overlap(qs_env, 1, matrix_s) - END IF IF (rtp_control%periodic) THEN IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T40))") & diff --git a/src/emd/rt_projection_mo_utils.F b/src/emd/rt_projection_mo_utils.F index 60ea2ff4aa..36e8080ca9 100644 --- a/src/emd/rt_projection_mo_utils.F +++ b/src/emd/rt_projection_mo_utils.F @@ -103,10 +103,9 @@ CONTAINS i_val=proj_mo%ref_nlumo) ! Relevent only in EMD - IF (.NOT. rtp_control%fixed_ions) THEN + IF (.NOT. rtp_control%fixed_ions) & CALL section_vals_val_get(proj_mo_section, "PROPAGATE_REF", i_rep_section=i_rep, & l_val=proj_mo%propagate_ref) - END IF ! If no reference .wfn is provided, using the restart SCF file: IF (proj_mo%ref_mo_file_name == "DEFAULT") THEN @@ -137,12 +136,11 @@ CONTAINS CALL section_vals_val_get(proj_mo_section, "TD_MO_SPIN", i_rep_section=i_rep, & i_val=proj_mo%td_mo_spin) - IF (proj_mo%td_mo_spin > SIZE(mos)) THEN + IF (proj_mo%td_mo_spin > SIZE(mos)) & CALL cp_abort(__LOCATION__, & "You asked to project the time dependent BETA spin while the "// & "real time DFT run has only one spin defined. "// & "Please set TD_MO_SPIN to 1 or use UKS.") - END IF CALL section_vals_val_get(proj_mo_section, "TD_MO_INDEX", i_rep_section=i_rep, & i_vals=tmp_ints) @@ -162,11 +160,10 @@ CONTAINS ALLOCATE (proj_mo%td_mo_occ(SIZE(proj_mo%td_mo_index))) proj_mo%td_mo_occ(:) = 0.0_dp DO j_td = 1, SIZE(proj_mo%td_mo_index) - IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) THEN + IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) & CALL cp_abort(__LOCATION__, & "The MO number available in the Time Dependent run "// & "is smaller than the MO number you have required in TD_MO_INDEX.") - END IF proj_mo%td_mo_occ(j_td) = mos(proj_mo%td_mo_spin)%occupation_numbers(proj_mo%td_mo_index(j_td)) END DO END IF @@ -240,10 +237,9 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(proj_mo%ref_mo_file_name), exist=is_file) - IF (.NOT. is_file) THEN + IF (.NOT. is_file) & CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(proj_mo%ref_mo_file_name)) - END IF CALL open_file(file_name=proj_mo%ref_mo_file_name, & file_action="READ", & @@ -258,11 +254,10 @@ CONTAINS IF (para_env%is_source()) CALL close_file(unit_number=restart_unit) - IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) THEN + IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) & CALL cp_abort(__LOCATION__, & "Projection on spin BETA is not possible as the reference wavefunction "// & "only has one spin channel. Use a reference .wfn calculated with UKS/LSD, or set REF_MO_SPIN to 1") - END IF ! Store only the mos required nbr_mo_max = mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%ncol_global @@ -274,21 +269,19 @@ CONTAINS END DO ELSE DO i_ref = 1, SIZE(proj_mo%ref_mo_index) - IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) THEN + IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) & CALL cp_abort(__LOCATION__, & "The number of MOs available in the reference wavefunction "// & "is smaller than the MO number you have requested in REF_MO_INDEX.") - END IF END DO END IF nbr_ref_mo = SIZE(proj_mo%ref_mo_index) - IF (nbr_ref_mo > nbr_mo_max) THEN + IF (nbr_ref_mo > nbr_mo_max) & CALL cp_abort(__LOCATION__, & "The total number of requested MOs is larger than what is available in the reference wavefunction. "// & "If you are trying to project onto virtual states, make sure they are included in the .wfn file "// & "e.g., by the ADDED_MOS keyword in the SCF section of the input when calculating your reference.") - END IF ! Store ALLOCATE (proj_mo%mo_ref(nbr_ref_mo)) @@ -297,16 +290,14 @@ CONTAINS nrow_global=mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%nrow_global, & ncol_global=1) - IF (dft_control%rtp_control%fixed_ions) THEN + IF (dft_control%rtp_control%fixed_ions) & CALL cp_fm_create(mo_coeff_temp, mo_ref_fmstruct, 'mo_ref') - END IF DO mo_index = 1, nbr_ref_mo real_mo_index = proj_mo%ref_mo_index(mo_index) - IF (real_mo_index > nbr_mo_max) THEN + IF (real_mo_index > nbr_mo_max) & CALL cp_abort(__LOCATION__, & "One of reference mo index is larger then the total number of available mo in the .wfn file.") - END IF ! fill with the reference mo values CALL cp_fm_create(proj_mo%mo_ref(mo_index), mo_ref_fmstruct, 'mo_ref') @@ -333,9 +324,8 @@ CONTAINS DEALLOCATE (mo_ref_temp) CALL cp_fm_struct_release(mo_ref_fmstruct) - IF (dft_control%rtp_control%fixed_ions) THEN + IF (dft_control%rtp_control%fixed_ions) & CALL cp_fm_release(mo_coeff_temp) - END IF END SUBROUTINE read_reference_mo_from_wfn @@ -382,9 +372,8 @@ CONTAINS ! Does not compute the projection if not the required time step IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & print_mo_section, ""), & - cp_p_file)) THEN + cp_p_file)) & RETURN - END IF IF (.NOT. dft_control%rtp_control%fixed_ions) THEN CALL get_qs_env(qs_env, & diff --git a/src/emd/rt_propagation_ft.F b/src/emd/rt_propagation_ft.F index fee7959fd0..f3b5021231 100644 --- a/src/emd/rt_propagation_ft.F +++ b/src/emd/rt_propagation_ft.F @@ -111,7 +111,7 @@ CONTAINS POINTER :: ft_samples, samples, samples_input INTEGER :: handle, i, i0, j, nsamples, nseries, stat LOGICAL :: subtract_initial - REAL(kind=dp) :: damping, delta_t, t0, t_total + REAL(kind=dp) :: damping, t0, t_total TYPE(fft_plan_type) :: fft_plan ! For value and result series: Index 1 - different series, Index 2 - single series entry @@ -120,9 +120,6 @@ CONTAINS ! Start with t0 t0 = 0.0_dp IF (PRESENT(t0_opt)) t0 = t0_opt - IF (SIZE(time_series) < 2) THEN - CPABORT("multi_fft requires at least two time samples.") - END IF ! Determine zero index i0 = 1 DO i = 1, SIZE(time_series) @@ -133,18 +130,8 @@ CONTAINS END DO ! Determine nsamples nsamples = SIZE(time_series) - i0 + 1 - IF (nsamples < 2) THEN - CPABORT("multi_fft requires at least two samples in the selected time window.") - END IF ! Determine total time t_total = time_series(SIZE(time_series)) - time_series(i0) - delta_t = time_series(i0 + 1) - time_series(i0) - IF (t_total /= t_total .OR. ABS(t_total) >= HUGE(t_total) .OR. t_total <= 0.0_dp) THEN - CPABORT("multi_fft detected an abnormal total time window (NaN/Inf/non-positive).") - END IF - IF (delta_t /= delta_t .OR. ABS(delta_t) >= HUGE(delta_t) .OR. delta_t <= 0.0_dp) THEN - CPABORT("multi_fft detected an abnormal timestep (NaN/Inf/non-positive).") - END IF ! Now can determine default damping damping = 4.0_dp/(t_total) ! Damping option supplied in au units of time @@ -156,9 +143,6 @@ CONTAINS damping = 0.0_dp END IF END IF - IF (damping /= damping .OR. ABS(damping) >= HUGE(damping)) THEN - CPABORT("multi_fft detected an abnormal damping factor (NaN/Inf).") - END IF ! subtract initial subtract_initial = .TRUE. subtract_value = 0.0_dp @@ -175,10 +159,6 @@ CONTAINS ! Calculate the omega series values, ordered from negative to positive IF (PRESENT(omega_series)) THEN CALL fft_freqs(nsamples, t_total, omega_series, fft_ordering_opt=.FALSE.) - IF (ANY(omega_series /= omega_series) .OR. & - ANY(ABS(omega_series) >= HUGE(omega_series))) THEN - CPABORT("multi_fft produced abnormal frequencies (NaN/Inf).") - END IF END IF ! Use FFTW3 library @@ -207,7 +187,7 @@ CONTAINS CALL fft_create_plan_1dm(fft_plan, fft_library("FFTW3"), -1, .FALSE., nsamples, nseries, samples, ft_samples, 3) ! Carry out the transform ! Scale by dt - to transform to an integral - CALL fft_1dm(fft_plan, samples_input, ft_samples, delta_t, stat) + CALL fft_1dm(fft_plan, samples_input, ft_samples, time_series(2) - time_series(1), stat) IF (stat /= 0) THEN ! Failed fftw3 - go to backup ! Uses value_series and result_series - no need to reassign data @@ -227,12 +207,6 @@ CONTAINS result_series(i, :) = ft_samples((i - 1)*nsamples + 1:i*nsamples) END DO END IF - IF (ANY(REAL(result_series, kind=dp) /= REAL(result_series, kind=dp)) .OR. & - ANY(AIMAG(result_series) /= AIMAG(result_series)) .OR. & - ANY(ABS(REAL(result_series, kind=dp)) >= HUGE(1.0_dp)) .OR. & - ANY(ABS(AIMAG(result_series)) >= HUGE(1.0_dp))) THEN - CPABORT("multi_fft produced abnormal Fourier amplitudes (NaN/Inf).") - END IF ! Deallocate CALL fft_dealloc(samples) CALL fft_dealloc(ft_samples) diff --git a/src/emd/rt_propagation_methods.F b/src/emd/rt_propagation_methods.F index 95cde86d30..fe656f3197 100644 --- a/src/emd/rt_propagation_methods.F +++ b/src/emd/rt_propagation_methods.F @@ -165,14 +165,12 @@ CONTAINS ! either in the lengh or velocity gauge. ! should be called after qs_energies_init and before qs_ks_update_qs_env IF (dft_control%apply_efield_field) THEN - IF (ANY(cell%perd(1:3) /= 0)) THEN + IF (ANY(cell%perd(1:3) /= 0)) & CPABORT("Length gauge (efield) and periodicity are not compatible") - END IF CALL efield_potential_lengh_gauge(qs_env) ELSE IF (rtp_control%velocity_gauge) THEN - IF (dft_control%apply_vector_potential) THEN + IF (dft_control%apply_vector_potential) & CALL update_vector_potential(qs_env, dft_control) - END IF CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) END IF @@ -410,9 +408,8 @@ CONTAINS DO i = 1, SIZE(exp_H_new) CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_new(i)%matrix, 0.0_dp, prefac) - IF (propagator == do_em) THEN + IF (propagator == do_em) & CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_old(i)%matrix, 1.0_dp, prefac) - END IF END DO CALL timestop(handle) diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index 4a6e8db128..1cee221fad 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -197,23 +197,19 @@ CONTAINS REAL(n_electrons, dp) WRITE (UNIT=output_unit, FMT="((T3,A,T59,F22.14))") & "Total energy:", rtp%energy_new - IF (run_type == ehrenfest) THEN + IF (run_type == ehrenfest) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old - END IF - IF (run_type == real_time_propagation) THEN + "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old + IF (run_type == real_time_propagation) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to initial state:", rtp%energy_new - rtp%energy_old - END IF - IF (PRESENT(delta_iter)) THEN + "Energy difference to initial state:", rtp%energy_new - rtp%energy_old + IF (PRESENT(delta_iter)) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,E20.6))") & - "Convergence:", delta_iter - END IF + "Convergence:", delta_iter IF (rtp%converged) THEN - IF (run_type == real_time_propagation) THEN + IF (run_type == real_time_propagation) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,F12.2))") & - "Time needed for propagation:", used_time - END IF + "Time needed for propagation:", used_time WRITE (UNIT=output_unit, FMT="(/,(T3,A,3X,F16.14))") & "CONVERGENCE REACHED", rtp%energy_new - rtp%energy_old END IF @@ -224,25 +220,22 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_new=mos_new) CALL rt_calculate_orthonormality(orthonormality, & mos_new, matrix_s(1)%matrix) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, FMT="(/,(T3,A,T60,F20.10))") & - "Max deviation from orthonormalization:", orthonormality - END IF + "Max deviation from orthonormalization:", orthonormality END IF END IF - IF (output_unit > 0) THEN + IF (output_unit > 0) & CALL m_flush(output_unit) - END IF CALL cp_print_key_finished_output(output_unit, logger, rtp_section, & "PRINT%PROGRAM_RUN_INFO") IF (rtp%converged) THEN dft_section => section_vals_get_subs_vals(input, "DFT") IF (BTEST(cp_print_key_should_output(logger%iter_info, & - dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) THEN + dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) & CALL print_field_applied(qs_env, dft_section) - END IF CALL make_moment(qs_env) IF (BTEST(cp_print_key_should_output(logger%iter_info, & dft_section, "REAL_TIME_PROPAGATION%PRINT%E_CONSTITUENTS"), cp_p_file)) THEN @@ -413,10 +406,9 @@ CONTAINS rtp%energy_old = rtp%energy_new - IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) THEN + IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) & CALL cp_abort(__LOCATION__, "EMD did not converge, either increase MAX_ITER "// & "or use a smaller TIMESTEP") - END IF END SUBROUTINE rt_prop_output @@ -846,7 +838,7 @@ CONTAINS CHARACTER(len=14) :: ext CHARACTER(len=2) :: sdir INTEGER :: dir, handle, print_unit - INTEGER, DIMENSION(:), POINTER :: stride + INTEGER, DIMENSION(:), POINTER :: stride(:) LOGICAL :: mpi_io TYPE(cp_logger_type), POINTER :: logger TYPE(current_env_type) :: current_env @@ -894,7 +886,7 @@ CONTAINS IF (dir == 1) THEN sdir = "-x" - ELSE IF (dir == 2) THEN + ELSEIF (dir == 2) THEN sdir = "-y" ELSE sdir = "-z" @@ -1289,18 +1281,15 @@ CONTAINS INTEGER, OPTIONAL :: info_opt TYPE(cell_type), OPTIONAL, POINTER :: cell - CHARACTER(len=*), PARAMETER :: routineN = 'print_ft' - CHARACTER(len=11), DIMENSION(2) :: file_extensions CHARACTER(len=20), ALLOCATABLE, DIMENSION(:) :: headers CHARACTER(len=21) :: prefix CHARACTER(len=5) :: prefix_format COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:) :: omegas_complex, omegas_pade - COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: field_results, field_results_pade, & - pol_results, pol_results_pade, pol_results_pade_spin_total, pol_results_spin_total, & - results, results_pade, results_pade_spin_total, results_spin_total, value_series - INTEGER :: ft_unit, handle, i, idx_omega_zero, & - info_unit, k, k_static, n, n_elems, & + COMPLEX(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: field_results, field_results_pade, & + pol_results, pol_results_pade, & + results, results_pade, value_series + INTEGER :: ft_unit, i, info_unit, k, n, n_elems, & n_pade, nspin LOGICAL :: do_moments_ft, do_polarizability REAL(kind=dp) :: damping, t0 @@ -1309,7 +1298,6 @@ CONTAINS TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: moment_ft_section, pol_section - CALL timeset(routineN, handle) ! For results, using spin * direction for first index, e.g. for nspin = 2 ! results(1,:) = (spin=1 and direction=1,:), ! results(5,:) = (spin=2 and direction=2,:) @@ -1404,40 +1392,6 @@ CONTAINS END IF CALL cp_print_key_finished_output(ft_unit, logger, moment_ft_section) END DO - ! Spin-summed total moments FT (open shell only; inert for nspin=1) - IF (nspin > 1) THEN - ALLOCATE (results_spin_total(3, n)) - results_spin_total(:, :) = (0.0_dp, 0.0_dp) - DO i = 1, nspin - DO k = 1, 3 - results_spin_total(k, :) = results_spin_total(k, :) + results(3*(i - 1) + k, :) - END DO - END DO - ft_unit = cp_print_key_unit_nr(logger, moment_ft_section, extension="_SPIN_TOTAL.dat", & - file_form="FORMATTED", file_position="REWIND") - IF (ft_unit > 0) THEN - ALLOCATE (headers(7)) - headers(2) = " x,real [at.u.]" - headers(3) = " x,imag [at.u.]" - headers(4) = " y,real [at.u.]" - headers(5) = " y,imag [at.u.]" - headers(6) = " z,real [at.u.]" - headers(7) = " z,imag [at.u.]" - IF (info_unit == ft_unit) THEN - headers(1) = "# Energy [eV]" - prefix = " MOMENTS_FT|" - prefix_format = "(A12)" - CALL print_rt_file(ft_unit, headers, omegas, results_spin_total, & - prefix, prefix_format, evolt) - ELSE - headers(1) = "# omega [at.u.]" - CALL print_rt_file(ft_unit, headers, omegas, results_spin_total) - END IF - DEALLOCATE (headers) - END IF - CALL cp_print_key_finished_output(ft_unit, logger, moment_ft_section) - DEALLOCATE (results_spin_total) - END IF END IF IF (rtc%pade_requested .AND. (do_moments_ft .OR. do_polarizability)) THEN @@ -1481,39 +1435,6 @@ CONTAINS DEALLOCATE (headers) END IF END DO - ! Spin-summed total moments-FT Padé (open shell only; inert for nspin=1) - IF (nspin > 1) THEN - ALLOCATE (results_pade_spin_total(3, n_pade)) - results_pade_spin_total(:, :) = (0.0_dp, 0.0_dp) - DO i = 1, nspin - DO k = 1, 3 - results_pade_spin_total(k, :) = results_pade_spin_total(k, :) + results_pade(3*(i - 1) + k, :) - END DO - END DO - ft_unit = cp_print_key_unit_nr(logger, moment_ft_section, extension="_PADE_SPIN_TOTAL.dat", & - file_form="FORMATTED", file_position="REWIND") - IF (ft_unit > 0) THEN - ALLOCATE (headers(7)) - headers(2) = " x,real,pade [at.u.]" - headers(3) = " x,imag,pade [at.u.]" - headers(4) = " y,real,pade [at.u.]" - headers(5) = " y,imag,pade [at.u.]" - headers(6) = " z,real,pade [at.u.]" - headers(7) = " z,imag,pade [at.u.]" - IF (info_unit == ft_unit) THEN - headers(1) = "# Energy [eV]" - prefix = " MOMENTS_FT_PADE|" - prefix_format = "(A17)" - CALL print_rt_file(ft_unit, headers, omegas_pade_real, results_pade_spin_total, & - prefix, prefix_format, evolt) - ELSE - headers(1) = "# omega [at.u.]" - CALL print_rt_file(ft_unit, headers, omegas_pade_real, results_pade_spin_total) - END IF - DEALLOCATE (headers) - END IF - DEALLOCATE (results_pade_spin_total) - END IF END IF IF (do_polarizability) THEN @@ -1554,77 +1475,7 @@ CONTAINS DEALLOCATE (headers) END IF CALL cp_print_key_finished_output(ft_unit, logger, pol_section) - ! Static polarizability alpha(0): pol_results at the FFT-grid omega - ! closest to zero. Re is alpha(0); Im should be machine-zero (sanity). - IF (info_unit > 0) THEN - idx_omega_zero = MINLOC(ABS(omegas), DIM=1) - IF (i == 1) THEN - WRITE (info_unit, '(A,T22,A,T28,A,T36,A,T59,A)') & - " STATIC_POL|", "spin", "element", "Re [a.u.]", "Im [a.u.]" - END IF - DO k_static = 1, n_elems - WRITE (info_unit, '(A,T22,I4,T28,I3,",",I3,T36,ES22.10E3,T59,ES22.10E3)') & - " STATIC_POL|", i, & - rtc%print_pol_elements(k_static, 1), & - rtc%print_pol_elements(k_static, 2), & - REAL(pol_results(k_static, idx_omega_zero), kind=dp), & - AIMAG(pol_results(k_static, idx_omega_zero)) - END DO - END IF END DO - ! Spin-summed total polarizability (open shell only; inert for nspin=1). - ! Field is spin-independent, so (sum_s moments_s)/field == sum_s (moments_s/field). - IF (nspin > 1) THEN - ALLOCATE (pol_results_spin_total(n_elems, n)) - pol_results_spin_total(:, :) = (0.0_dp, 0.0_dp) - DO k = 1, n_elems - DO i = 1, nspin - pol_results_spin_total(k, :) = pol_results_spin_total(k, :) + & - results(3*(i - 1) + rtc%print_pol_elements(k, 1), :) - END DO - pol_results_spin_total(k, :) = pol_results_spin_total(k, :)/ & - (field_results(rtc%print_pol_elements(k, 2), :) + & - 1.0e-10*field_results(rtc%print_pol_elements(k, 2), 2)) - END DO - ft_unit = cp_print_key_unit_nr(logger, pol_section, extension="_SPIN_TOTAL.dat", & - file_form="FORMATTED", file_position="REWIND") - IF (ft_unit > 0) THEN - ALLOCATE (headers(2*n_elems + 1)) - DO k = 1, n_elems - WRITE (headers(2*k), "(A16,I2,I2)") "real pol. elem.", & - rtc%print_pol_elements(k, 1), & - rtc%print_pol_elements(k, 2) - WRITE (headers(2*k + 1), "(A16,I2,I2)") "imag pol. elem.", & - rtc%print_pol_elements(k, 1), & - rtc%print_pol_elements(k, 2) - END DO - IF (info_unit == ft_unit) THEN - headers(1) = "# Energy [eV]" - prefix = " POLARIZABILITY|" - prefix_format = "(A16)" - CALL print_rt_file(ft_unit, headers, omegas, pol_results_spin_total, & - prefix, prefix_format, evolt) - ELSE - headers(1) = "# omega [at.u.]" - CALL print_rt_file(ft_unit, headers, omegas, pol_results_spin_total) - END IF - DEALLOCATE (headers) - END IF - CALL cp_print_key_finished_output(ft_unit, logger, pol_section) - ! Static polarizability total (header row already emitted by the per-spin block) - IF (info_unit > 0) THEN - idx_omega_zero = MINLOC(ABS(omegas), DIM=1) - DO k_static = 1, n_elems - WRITE (info_unit, '(A,T22,A,T28,I3,",",I3,T36,ES22.10E3,T59,ES22.10E3)') & - " STATIC_POL|", "TOT", & - rtc%print_pol_elements(k_static, 1), & - rtc%print_pol_elements(k_static, 2), & - REAL(pol_results_spin_total(k_static, idx_omega_zero), kind=dp), & - AIMAG(pol_results_spin_total(k_static, idx_omega_zero)) - END DO - END IF - DEALLOCATE (pol_results_spin_total) - END IF END IF ! Padé polarizability @@ -1680,46 +1531,6 @@ CONTAINS END IF CALL cp_print_key_finished_output(ft_unit, logger, pol_section) END DO - ! Spin-summed total Padé polarizability (open shell only; inert for nspin=1) - IF (nspin > 1) THEN - ALLOCATE (pol_results_pade_spin_total(n_elems, n_pade)) - pol_results_pade_spin_total(:, :) = (0.0_dp, 0.0_dp) - DO k = 1, n_elems - DO i = 1, nspin - pol_results_pade_spin_total(k, :) = pol_results_pade_spin_total(k, :) + & - results_pade(3*(i - 1) + rtc%print_pol_elements(k, 1), :) - END DO - pol_results_pade_spin_total(k, :) = pol_results_pade_spin_total(k, :)/( & - field_results_pade(rtc%print_pol_elements(k, 2), :) + & - field_results_pade(rtc%print_pol_elements(k, 2), 2)*1.0e-10_dp) - END DO - ft_unit = cp_print_key_unit_nr(logger, pol_section, extension="_PADE_SPIN_TOTAL.dat", & - file_form="FORMATTED", file_position="REWIND") - IF (ft_unit > 0) THEN - ALLOCATE (headers(2*n_elems + 1)) - DO k = 1, n_elems - WRITE (headers(2*k), "(A16,I2,I2)") "re,pade,pol.", & - rtc%print_pol_elements(k, 1), & - rtc%print_pol_elements(k, 2) - WRITE (headers(2*k + 1), "(A16,I2,I2)") "im,pade,pol.", & - rtc%print_pol_elements(k, 1), & - rtc%print_pol_elements(k, 2) - END DO - IF (info_unit == ft_unit) THEN - headers(1) = "# Energy [eV]" - prefix = " POLARIZABILITY_PADE|" - prefix_format = "(A21)" - CALL print_rt_file(ft_unit, headers, omegas_pade_real, pol_results_pade_spin_total, & - prefix, prefix_format, evolt) - ELSE - headers(1) = "# omega [at.u.]" - CALL print_rt_file(ft_unit, headers, omegas_pade_real, pol_results_pade_spin_total) - END IF - DEALLOCATE (headers) - END IF - CALL cp_print_key_finished_output(ft_unit, logger, pol_section) - DEALLOCATE (pol_results_pade_spin_total) - END IF DEALLOCATE (field_results_pade) DEALLOCATE (pol_results_pade) END IF @@ -1740,9 +1551,6 @@ CONTAINS DEALLOCATE (results) DEALLOCATE (omegas) END IF - - CALL timestop(handle) - END SUBROUTINE print_ft ! ************************************************************************************************** diff --git a/src/emd/rt_propagation_utils.F b/src/emd/rt_propagation_utils.F index 431a2fefee..6e6997f20e 100644 --- a/src/emd/rt_propagation_utils.F +++ b/src/emd/rt_propagation_utils.F @@ -318,10 +318,9 @@ CONTAINS dft_section=dft_section) CALL set_uniform_occupation_mo_array(mo_array, nspin) - IF (dft_control%rtp_control%apply_wfn_mix_init_restart) THEN + IF (dft_control%rtp_control%apply_wfn_mix_init_restart) & CALL wfn_mix(mo_array, particle_set, dft_section, qs_kind_set, para_env, output_unit, & for_rtp=.TRUE.) - END IF DO ispin = 1, nspin CALL calculate_density_matrix(mo_array(ispin), p_rmpv(ispin)%matrix) @@ -424,9 +423,8 @@ CONTAINS DO mo = 1, mo_array(ispin)%nmo IF (mo_array(ispin)%occupation_numbers(mo) /= 0.0 .AND. & mo_array(ispin)%occupation_numbers(mo) /= 1.0 .AND. & - mo_array(ispin)%occupation_numbers(mo) /= 2.0) THEN + mo_array(ispin)%occupation_numbers(mo) /= 2.0) & is_uniform = .FALSE. - END IF END DO mo_array(ispin)%uniform_occupation = is_uniform END DO diff --git a/src/emd/rt_propagator_init.F b/src/emd/rt_propagator_init.F index 7d1cbfd570..69e42afdd0 100644 --- a/src/emd/rt_propagator_init.F +++ b/src/emd/rt_propagator_init.F @@ -161,7 +161,7 @@ CONTAINS DO imat = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(imat), mos_next(imat)) END DO - ELSE IF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN + ELSEIF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN ELSE IF (rtp%linear_scaling) THEN CALL compute_exponential_sparse(exp_H_new, propagator_matrix, rtp_control, rtp) diff --git a/src/energy_corrections.F b/src/energy_corrections.F index e79c921c09..e0ea3c5191 100644 --- a/src/energy_corrections.F +++ b/src/energy_corrections.F @@ -1726,7 +1726,7 @@ CONTAINS IF (dft_control%do_admm_mo) THEN CPASSERT(.NOT. qs_env%run_rtp) CALL admm_mo_calc_rho_aux(qs_env) - ELSE IF (dft_control%do_admm_dm) THEN + ELSEIF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF diff --git a/src/environment.F b/src/environment.F index dfc1ca86d0..f981bdf787 100644 --- a/src/environment.F +++ b/src/environment.F @@ -470,9 +470,8 @@ CONTAINS iw = cp_print_key_unit_nr(logger, root_section, "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG", & extension=".Log") - IF (iw > 0) THEN + IF (iw > 0) & CALL globenv%gaussian_rng_stream%write(iw, write_all=.TRUE.) - END IF CALL cp_print_key_finished_output(iw, logger, root_section, & "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG") @@ -595,9 +594,8 @@ CONTAINS IF (trace .AND. (.NOT. trace_master .OR. para_env%mepos == 0)) THEN unit_nr = -1 - IF (logger%para_env%is_source() .OR. .NOT. trace_master) THEN + IF (logger%para_env%is_source() .OR. .NOT. trace_master) & unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) - END IF WRITE (tracing_string, "(I6.6,A1,I6.6)") para_env%mepos, ":", para_env%num_pe IF (ASSOCIATED(trace_routines)) THEN CALL timings_setup_tracing(trace_max, unit_nr, tracing_string, trace_routines) @@ -684,9 +682,8 @@ CONTAINS CPABORT("FARMING program supports only NONE as run type") END IF - IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) THEN + IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) & CPABORT("TEST program supports only NONE as run type") - END IF CALL m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree) MemTotal_avr = MemTotal @@ -1234,9 +1231,8 @@ CONTAINS IF (ierr /= 0) CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') ELSE READ (txt(1:n), FMT="(I2,A1,I2,A1,I2)", IOSTAT=ierr) hours, c1, minutes, c2, seconds - IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") THEN + IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") & CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') - END IF walltime = 3600.0_dp*REAL(hours, dp) + 60.0_dp*REAL(minutes, dp) + REAL(seconds, dp) END IF END SUBROUTINE cp2k_get_walltime @@ -1335,18 +1331,15 @@ CONTAINS IF (cg_mode /= CALLGRAPH_NONE) THEN CALL section_vals_val_get(root_section, "GLOBAL%CALLGRAPH_FILE_NAME", c_val=cg_filename) IF (LEN_TRIM(cg_filename) == 0) cg_filename = TRIM(logger%iter_info%project_name) - IF (cg_mode == CALLGRAPH_ALL) THEN - !incorporate mpi-rank into filename + IF (cg_mode == CALLGRAPH_ALL) & !incorporate mpi-rank into filename cg_filename = TRIM(cg_filename)//"_"//TRIM(ADJUSTL(cp_to_string(para_env%mepos))) - END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,3X,A)") "Writing callgraph to: "//TRIM(cg_filename)//".callgraph" WRITE (UNIT=iw, FMT="()") WRITE (UNIT=iw, FMT="(T2,A)") "-------------------------------------------------------------------------------" END IF - IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) THEN + IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) & CALL timings_report_callgraph(TRIM(cg_filename)//".callgraph") - END IF END IF CALL cp_print_key_finished_output(iw, logger, root_section, & diff --git a/src/eri_mme/eri_mme_error_control.F b/src/eri_mme/eri_mme_error_control.F index 645678d1f4..4c8a63e1c6 100644 --- a/src/eri_mme/eri_mme_error_control.F +++ b/src/eri_mme/eri_mme_error_control.F @@ -92,15 +92,13 @@ CONTAINS max_iter = 100 - IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) THEN + IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) & CALL cp_abort(__LOCATION__, "difference of boundaries for cutoff "// & "(MAX - MIN) must be greater than cutoff precision.") - END IF - IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) THEN + IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) & CALL cp_abort(__LOCATION__, & "relative delta to modify initial cutoff interval (DELTA) must be in (0, 1)") - END IF cutoff_lr(1) = cutoff_l cutoff_lr(2) = cutoff_r @@ -115,11 +113,10 @@ CONTAINS ! 1) find valid initial values for bisection DO iter1 = 1, max_iter + 1 - IF (iter1 > max_iter) THEN + IF (iter1 > max_iter) & CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine initial "// & "cutoff interval has been exceeded.") - END IF cutoff_lr(1) = MAX(cutoff_lr(1), 0.5_dp*G_min**2) ! approx.) is hit @@ -147,10 +144,9 @@ CONTAINS "ERI_MME| Step, cutoff (min, max, mid), err(minimax), err(cutoff), err diff" DO iter2 = 1, max_iter + 1 - IF (iter2 > max_iter) THEN + IF (iter2 > max_iter) & CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine cutoff has been exceeded") - END IF cutoff_mid = 0.5_dp*(cutoff_lr(1) + cutoff_lr(2)) CALL cutoff_minimax_error(cutoff_mid, hmat, h_inv, vol, G_min, zet_min, l_mm, zet_max, l_max_zet, & @@ -341,10 +337,9 @@ CONTAINS gr = 0.5_dp*(SQRT(5.0_dp) - 1.0_dp) ! golden ratio ! Find valid starting values for golden section search DO iter = 1, max_iter + 1 - IF (iter > max_iter) THEN + IF (iter > max_iter) & CALL cp_abort(__LOCATION__, "Maximum number of iterations for finding "// & "exponent maximizing cutoff error has been exceeded.") - END IF CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_max_tmp, C, err_ctff_curr, para_env) IF (err_ctff_prev >= err_ctff_curr) THEN diff --git a/src/eri_mme/eri_mme_gaussian.F b/src/eri_mme/eri_mme_gaussian.F index 1cde9784a6..fea8e96a21 100644 --- a/src/eri_mme/eri_mme_gaussian.F +++ b/src/eri_mme/eri_mme_gaussian.F @@ -133,7 +133,7 @@ CONTAINS CPASSERT(G_max > G_min) IF (potential_prv == eri_mme_coulomb .OR. potential_prv == eri_mme_longrange) THEN minimax_Rc = (G_max/G_min)**2 - ELSE IF (potential_prv == eri_mme_yukawa) THEN + ELSEIF (potential_prv == eri_mme_yukawa) THEN minimax_Rc = (G_max**2 + pot_par**2)/(G_min**2 + pot_par**2) END IF @@ -165,9 +165,9 @@ CONTAINS IF (PRESENT(err_minimax)) THEN IF (potential_prv == eri_mme_coulomb) THEN err_minimax = err_minimax/G_min**2 - ELSE IF (potential_prv == eri_mme_yukawa) THEN + ELSEIF (potential_prv == eri_mme_yukawa) THEN err_minimax = err_minimax/(G_min**2 + pot_par**2) - ELSE IF (potential_prv == eri_mme_longrange) THEN + ELSEIF (potential_prv == eri_mme_longrange) THEN err_minimax = err_minimax/G_min**2 ! approx. of Coulomb err_minimax = err_minimax*EXP(-G_min**2/pot_par**2) ! exponential factor END IF diff --git a/src/eri_mme/eri_mme_lattice_summation.F b/src/eri_mme/eri_mme_lattice_summation.F index a5f8da4731..4fd3228772 100644 --- a/src/eri_mme/eri_mme_lattice_summation.F +++ b/src/eri_mme/eri_mme_lattice_summation.F @@ -89,7 +89,7 @@ CONTAINS IF (PRESENT(G_rad)) G_rad = exp_radius(l_max, alpha_G, sum_precision, 1.0_dp, epsabs=G_res) IF (PRESENT(R_rad)) R_rad = exp_radius(l_max, alpha_R, sum_precision, 1.0_dp, epsabs=R_res) - END SUBROUTINE eri_mme_2c_get_rads + END SUBROUTINE ! ************************************************************************************************** !> \brief Get summation radii for 3c integrals @@ -149,7 +149,7 @@ CONTAINS R_rads_3(2) = exp_radius(la_max + lb_max + lc_max, alpha_R, sum_precision, 1.0_dp, R_res) END IF - END SUBROUTINE eri_mme_3c_get_rads + END SUBROUTINE ! ************************************************************************************************** !> \brief Get summation bounds for 2c integrals @@ -212,7 +212,7 @@ CONTAINS n_sum_3d(2) = nsum_2c_rspace_3d(ns_R, la_max, lb_max) END IF - END SUBROUTINE eri_mme_2c_get_bounds + END SUBROUTINE ! ************************************************************************************************** !> \brief Get summation bounds for 3c integrals @@ -326,7 +326,7 @@ CONTAINS n_sum_3d(3) = nsum_3c_rspace_3d(ns3_R1, ns3_R2, la_max, lb_max, lc_max) END IF - END SUBROUTINE eri_mme_3c_get_bounds + END SUBROUTINE ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -341,7 +341,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_1d nsum_2c_gspace_1d = NINT(ns_G*(2*exp_w + (l + m + 1)*5), KIND=int_8) - END FUNCTION nsum_2c_gspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in G space in 1 dimension @@ -380,7 +380,7 @@ CONTAINS END DO END DO - S_G(:) = REAL(S_G_c(0:l_max)*i_pow([(l, l=0, l_max)]))*inv_lgth + S_G(:) = REAL(S_G_c(0:l_max)*i_pow((/(l, l=0, l_max)/)))*inv_lgth END SUBROUTINE pgf_sum_2c_gspace_1d ! ************************************************************************************************** @@ -396,7 +396,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_3d nsum_2c_gspace_3d = NINT(ns_G*(2*exp_w + ncoset(l + m)*7), KIND=int_8) - END FUNCTION nsum_2c_gspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief As pgf_sum_2c_gspace_1d but 3d sum required for non-orthorhombic cells @@ -495,7 +495,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_1d nsum_2c_rspace_1d = NINT(ns_R*(exp_w + (l + m + 1)*3), KIND=int_8) - END FUNCTION nsum_2c_rspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in R space in 1 dimension @@ -553,7 +553,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_3d nsum_2c_rspace_3d = NINT(ns_R*(exp_w + ncoset(l + m)*(4 + ncoset(l + m)*4)), KIND=int_8) - END FUNCTION nsum_2c_rspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief As pgf_sum_2c_rspace_1d but 3d sum required for non-orthorhombic cells @@ -611,8 +611,7 @@ CONTAINS END DO DO lco = 1, ncoset(l_max) CALL get_l(lco, l, lx, ly, lz) - ! cost: 4 flops - S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot + S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot ! cost: 4 flops END DO END DO END DO @@ -795,7 +794,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_gspace_1d nsum_3c_gspace_1d = 15 - END FUNCTION nsum_3c_gspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -811,7 +810,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_product_3c_gspace_1d nsum_product_3c_gspace_1d = MIN(19, NINT(ns_G*(3 + ns_R*2))) - END FUNCTION nsum_product_3c_gspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -827,7 +826,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_rspace_1d nsum_3c_rspace_1d = NINT(MIN((4 + ns_R1*2), ns_R1*(ns_R2 + 1)), KIND=int_8) - END FUNCTION nsum_3c_rspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -955,7 +954,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE pgf_sum_3c_rspace_1d_generic + END SUBROUTINE ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -1010,7 +1009,7 @@ CONTAINS #:for l in range(0, l_tot_max) #:for k in range(0, l+2) #:if k0 - h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# + h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# #:else h_to_c_${k}$_${l+1}$ = 0.0_dp #:endif @@ -1088,15 +1087,15 @@ CONTAINS #:for l in range(0,l_max+1) #:for t in range(0,l+m+2) #:if l < l_max - E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}# +c2*E_${t}$_${l}$_${m}$&#{endif}# #{if t0 and t<=l-1+m}#-${2*l}$*E_${t}$_${l-1}$_${m}$#{endif}#) #:endif #:if m < m_max - E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}#+c3*E_${t}$_${l}$_${m}$&#{endif}# - #{if t0 and t<=m-1+l}#-${2*m}$*E_${t}$_${l}$_${m-1}$#{endif}#) #:endif #:endfor @@ -1116,7 +1115,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE pgf_sum_3c_rspace_1d_${l_max}$_${m_max}$_${n_max}$_exp_${prop_exp}$ + END SUBROUTINE #:endfor #:endfor #:endfor @@ -1266,7 +1265,7 @@ CONTAINS nsum_3c_gspace_3d = NINT(ns_G1*ns_G2*(5*exp_w + ncoset(l)*ncoset(m)*ncoset(n)*4), KIND=int_8) - END FUNCTION nsum_3c_gspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1428,7 +1427,7 @@ CONTAINS END SELECT S_G = REAL(S_G_c, KIND=dp)/vol**2 - END SUBROUTINE pgf_sum_3c_gspace_3d + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -1544,7 +1543,7 @@ CONTAINS 3*nsum_gaussian_overlap(l, m, 1) + & ncoset(l)*ncoset(m)*(ncoset(l + m)*4 + ncoset(n)*8)), & KIND=int_8) - END FUNCTION nsum_product_3c_gspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1765,7 +1764,7 @@ CONTAINS ncoset(l + m)*2 + ncoset(n)*ncoset(l + m)*4)), & KIND=int_8) - END FUNCTION nsum_3c_rspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1963,7 +1962,7 @@ CONTAINS ELSE nsum_gaussian_overlap = nsum_gaussian_overlap + loop*32 END IF - END FUNCTION nsum_gaussian_overlap + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1982,7 +1981,7 @@ CONTAINS IF (PRESENT(lx)) lx = indco(1, lco) IF (PRESENT(ly)) ly = indco(2, lco) IF (PRESENT(lz)) lz = indco(3, lco) - END SUBROUTINE get_l + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -1994,10 +1993,10 @@ CONTAINS COMPLEX(KIND=dp) :: i_pow COMPLEX(KIND=dp), DIMENSION(0:3), PARAMETER :: & - ip = [(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)] + ip = (/(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)/) i_pow = ip(MOD(i, 4)) - END FUNCTION i_pow + END FUNCTION END MODULE eri_mme_lattice_summation diff --git a/src/eri_mme/eri_mme_test.F b/src/eri_mme/eri_mme_test.F index 923b19c2c9..f67388aac6 100644 --- a/src/eri_mme/eri_mme_test.F +++ b/src/eri_mme/eri_mme_test.F @@ -158,9 +158,8 @@ CONTAINS acc_check = .TRUE. END IF - IF (.NOT. acc_check) THEN + IF (.NOT. acc_check) & CPABORT("Actual error greater than upper bound estimate.") - END IF END IF END IF diff --git a/src/eri_mme/eri_mme_types.F b/src/eri_mme/eri_mme_types.F index 25f94e1ae1..2f40d28ab0 100644 --- a/src/eri_mme/eri_mme_types.F +++ b/src/eri_mme/eri_mme_types.F @@ -127,9 +127,8 @@ CONTAINS CHARACTER(len=2) :: string WRITE (string, '(I2)') n_minimax_max - IF (n_minimax > n_minimax_max) THEN + IF (n_minimax > n_minimax_max) & CPABORT("The maximum allowed number of minimax points N_MINIMAX is "//TRIM(string)) - END IF param%n_minimax = n_minimax param%n_grids = 1 diff --git a/src/et_coupling_proj.F b/src/et_coupling_proj.F index dae0f3d119..f387e74c79 100644 --- a/src/et_coupling_proj.F +++ b/src/et_coupling_proj.F @@ -150,9 +150,8 @@ CONTAINS IF (ASSOCIATED(ec)) THEN - IF (ASSOCIATED(ec%fermi)) THEN + IF (ASSOCIATED(ec%fermi)) & DEALLOCATE (ec%fermi) - END IF IF (ASSOCIATED(ec%m_transf)) THEN CALL cp_fm_release(matrix=ec%m_transf) DEALLOCATE (ec%m_transf) @@ -167,9 +166,8 @@ CONTAINS IF (ASSOCIATED(ec%block)) THEN DO i = 1, SIZE(ec%block) - IF (ASSOCIATED(ec%block(i)%atom)) THEN + IF (ASSOCIATED(ec%block(i)%atom)) & DEALLOCATE (ec%block(i)%atom) - END IF IF (ASSOCIATED(ec%block(i)%mo)) THEN DO j = 1, SIZE(ec%block(i)%mo) CALL deallocate_mo_set(ec%block(i)%mo(j)) @@ -244,9 +242,8 @@ CONTAINS DO i = 1, n_atoms CALL get_atomic_kind(particle_set(i)%atomic_kind, kind_number=j) CALL get_qs_kind(qs_kind_set(j), basis_set=ao_basis_set) - IF (.NOT. ASSOCIATED(ao_basis_set)) THEN + IF (.NOT. ASSOCIATED(ao_basis_set)) & CPABORT('Unsupported basis set type. ') - END IF CALL get_gto_basis_set(gto_basis_set=ao_basis_set, & nset=n_set, nshell=n_shell, l=ang_mom_id) DO j = 1, n_set @@ -303,9 +300,8 @@ CONTAINS ! Count unique atoms DO j = 1, SIZE(atom_id) ! Check atom ID validity - IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) THEN + IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) & CPABORT('invalid fragment atom ID ('//TRIM(ADJUSTL(cp_to_string(atom_id(j))))//')') - END IF ! Check if the atom is not in previously-defined blocks found = .FALSE. DO k = 1, i - 1 @@ -350,15 +346,12 @@ CONTAINS END DO ! Clean memory - IF (ASSOCIATED(atom_nf)) THEN + IF (ASSOCIATED(atom_nf)) & DEALLOCATE (atom_nf) - END IF - IF (ASSOCIATED(atom_ps)) THEN + IF (ASSOCIATED(atom_ps)) & DEALLOCATE (atom_ps) - END IF - IF (ASSOCIATED(t)) THEN + IF (ASSOCIATED(t)) & DEALLOCATE (t) - END IF END SUBROUTINE set_block_data @@ -416,9 +409,8 @@ CONTAINS ! Routine name for debug purposes ! Local variables - IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) THEN + IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) & CPABORT('cannot reorder Hamiltonian, working-matrix structure is not equivalent') - END IF ! Matrix-element reordering nr = 1 @@ -680,9 +672,8 @@ CONTAINS END DO ! Clean memory - IF (ALLOCATED(dat)) THEN + IF (ALLOCATED(dat)) & DEALLOCATE (dat) - END IF END SUBROUTINE hamiltonian_block_diag @@ -727,9 +718,8 @@ CONTAINS END IF END DO - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT('MO-fraction atom ID not defined in the block') - END IF ! sum MO coefficients from the atom DO k = 1, blk_at(j)%n_ao @@ -783,9 +773,8 @@ CONTAINS IF (n > 0) THEN - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(/,T3,A/)') 'Block state fractions:' - END IF ! Number of AO functions CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) @@ -820,9 +809,8 @@ CONTAINS IF (ASSOCIATED(list_mo)) THEN IF (j > 1) THEN - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, *) - END IF END IF DO l = 1, SIZE(list_mo) @@ -832,15 +820,13 @@ CONTAINS list_mo(l), list_at) c2 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(2), & list_mo(l), list_at) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(I5,A,I5,2F20.10)') j, ' /', list_mo(l), c1, c2 - END IF ELSE c1 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(1), & list_mo(l), list_at) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(I5,A,I5,F20.10)') j, ' /', list_mo(l), c1 - END IF END IF END DO @@ -887,9 +873,8 @@ CONTAINS ! Routine name for debug purposes prnt_fm = .FALSE. - IF (PRESENT(fermi)) THEN + IF (PRESENT(fermi)) & prnt_fm = fermi - END IF IF (output_unit > 0) THEN @@ -899,13 +884,11 @@ CONTAINS IF (n_spins > 1) THEN mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) THEN + IF (PRESENT(mx_mo_a)) & mx_a = MIN(mo(1)%nmo, mx_mo_a) - END IF mx_b = mo(2)%nmo - IF (PRESENT(mx_mo_b)) THEN + IF (PRESENT(mx_mo_b)) & mx_b = MIN(mo(2)%nmo, mx_mo_b) - END IF n = MAX(mx_a, mx_b) DO i = 1, n @@ -935,9 +918,8 @@ CONTAINS ELSE mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) THEN + IF (PRESENT(mx_mo_a)) & mx_a = MIN(mo(1)%nmo, mx_mo_a) - END IF DO i = 1, mx_a WRITE (output_unit, '(T3,I10,2F12.4)') & @@ -1002,9 +984,8 @@ CONTAINS my_pos = "APPEND" END IF - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(/,T3,A/)') 'Printing coupling elements to output files' - END IF DO i = 1, ec%n_blocks DO j = i + 1, ec%n_blocks @@ -1123,16 +1104,15 @@ CONTAINS ALLOCATE (vec_t(n_mo)) CPASSERT(ASSOCIATED(vec_t)) CALL cp_fm_vectorssum(mat_t, vec_t) - vec_t = 1.0_dp/SQRT(vec_t) + vec_t = 1.0_dp/DSQRT(vec_t) CALL cp_fm_column_scale(mo%mo_coeff, vec_t) ! Clean memory CALL cp_fm_struct_release(fmstruct=fm_s) CALL cp_fm_release(matrix=mat_sc) CALL cp_fm_release(matrix=mat_t) - IF (ASSOCIATED(vec_t)) THEN + IF (ASSOCIATED(vec_t)) & DEALLOCATE (vec_t) - END IF END SUBROUTINE normalize_mo_vectors @@ -1242,28 +1222,24 @@ CONTAINS ! Number of states n_mo = mat_u%matrix_struct%nrow_global - IF (n_mo /= mat_u%matrix_struct%ncol_global) THEN + IF (n_mo /= mat_u%matrix_struct%ncol_global) & CPABORT('block state matrix is not square') - END IF - IF (n_mo /= SIZE(vec_e)) THEN + IF (n_mo /= SIZE(vec_e)) & CPABORT('inconsistent number of states / energies') - END IF ! Maximal occupancy CALL get_qs_env(qs_env, dft_control=dft_cntrl) mx_occ = 2.0_dp - IF (dft_cntrl%nspins > 1) THEN + IF (dft_cntrl%nspins > 1) & mx_occ = 1.0_dp - END IF ! Number of electrons n_el = ec%block(id)%n_electrons IF (dft_cntrl%nspins > 1) THEN n_el = n_el/2 IF (MOD(ec%block(id)%n_electrons, 2) == 1) THEN - IF (spin == 1) THEN + IF (spin == 1) & n_el = n_el + 1 - END IF END IF END IF @@ -1542,9 +1518,8 @@ CONTAINS ! Parallel calculation - master thread master = .FALSE. - IF (output_unit > 0) THEN + IF (output_unit > 0) & master = .TRUE. - END IF ! Header IF (master) THEN @@ -1628,23 +1603,20 @@ CONTAINS CPABORT('ET_COUPLING not implemented with kpoints') ELSE ! no K-points - IF (master) THEN + IF (master) & WRITE (output_unit, '(T3,A)') 'No K-point sampling (Gamma point only)' - END IF END IF IF (dft_cntrl%nspins == 2) THEN - IF (master) THEN + IF (master) & WRITE (output_unit, '(/,T3,A)') 'Spin-polarized calculation' - END IF !<--- Open shell / No K-points ------------------------------------------------>! ! State eneries of the whole system - IF (mo(1)%nao /= mo(2)%nao) THEN + IF (mo(1)%nao /= mo(2)%nao) & CPABORT('different number of alpha/beta AO basis functions') - END IF IF (master) THEN WRITE (output_unit, '(/,T3,A,I10)') & 'Number of AO basis functions = ', mo(1)%nao @@ -1676,9 +1648,8 @@ CONTAINS ELSE - IF (master) THEN + IF (master) & WRITE (output_unit, '(/,T3,A)') 'Spin-restricted calculation' - END IF !<--- Close shell / No K-points ----------------------------------------------->! diff --git a/src/ewald_spline_util.F b/src/ewald_spline_util.F index 74f69713b4..9ebfcab6e5 100644 --- a/src/ewald_spline_util.F +++ b/src/ewald_spline_util.F @@ -398,10 +398,10 @@ CONTAINS END DO Na = SQRT(dxTerm*dxTerm + dyTerm*dyTerm + dzTerm*dzTerm) dn = Eval_d_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) - Nn = NORM2(dn) + Nn = SQRT(DOT_PRODUCT(dn, dn)) Fterm = Eval_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) tmp1 = ABS(Term - Fterm) - tmp2 = NORM2(dn - [dxTerm, dyTerm, dzTerm]) + tmp2 = SQRT(DOT_PRODUCT(dn - [dxTerm, dyTerm, dzTerm], dn - [dxTerm, dyTerm, dzTerm])) errf = errf + tmp1 maxerrorf = MAX(maxerrorf, tmp1) errd = errd + tmp2 diff --git a/src/ewalds.F b/src/ewalds.F index b10f460437..c5df25968f 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -364,9 +364,9 @@ CONTAINS charges) TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set(:) TYPE(distribution_1d_type), POINTER :: local_particles - REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self + REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self(:) REAL(KIND=dp), DIMENSION(:), POINTER :: charges INTEGER :: ewald_type, ii, iparticle_kind, & diff --git a/src/ewalds_multipole.F b/src/ewalds_multipole.F index 96abbf552e..06a4c1f867 100644 --- a/src/ewalds_multipole.F +++ b/src/ewalds_multipole.F @@ -61,17 +61,6 @@ MODULE ewalds_multipole IMPLICIT NONE PRIVATE - TYPE charge_mono_type - REAL(KIND=dp), DIMENSION(:), & - POINTER :: charge => NULL() - REAL(KIND=dp), DIMENSION(:, :), & - POINTER :: pos => NULL() - END TYPE charge_mono_type - TYPE multi_charge_type - TYPE(charge_mono_type), DIMENSION(:), & - POINTER :: charge_typ => NULL() - END TYPE multi_charge_type - LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_r_space = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_g_space = .FALSE. @@ -1287,6 +1276,16 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, iw, debug_r_space) + TYPE charge_mono_type + REAL(KIND=dp), DIMENSION(:), & + POINTER :: charge + REAL(KIND=dp), DIMENSION(:, :), & + POINTER :: pos + END TYPE charge_mono_type + TYPE multi_charge_type + TYPE(charge_mono_type), DIMENSION(:), & + POINTER :: charge_typ + END TYPE multi_charge_type TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(fist_nonbond_env_type), POINTER :: nonbond_env @@ -1608,7 +1607,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = NORM2(rm) + r = SQRT(DOT_PRODUCT(rm, rm)) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1647,7 +1646,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = NORM2(rm) + r = SQRT(DOT_PRODUCT(rm, rm)) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1728,7 +1727,7 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%charge(2)) ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 2)) CALL random_stream%fill(rvec) - rvec = rvec/(2.0_dp*NORM2(rvec))*dx + rvec = rvec/(2.0_dp*SQRT(DOT_PRODUCT(rvec, rvec)))*dx multipoles(i)%charge_typ(isize)%charge(1) = echarge multipoles(i)%charge_typ(isize)%pos(1:3, 1) = rvec multipoles(i)%charge_typ(isize)%charge(2) = -echarge @@ -1743,9 +1742,9 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 4)) CALL random_stream%fill(rvec1) CALL random_stream%fill(rvec2) - rvec1 = rvec1/NORM2(rvec1) + rvec1 = rvec1/SQRT(DOT_PRODUCT(rvec1, rvec1)) rvec2 = rvec2 - DOT_PRODUCT(rvec2, rvec1)*rvec1 - rvec2 = rvec2/NORM2(rvec2) + rvec2 = rvec2/SQRT(DOT_PRODUCT(rvec2, rvec2)) ! rvec1 = rvec1/2.0_dp*dx rvec2 = rvec2/2.0_dp*dx diff --git a/src/ewalds_multipole_sr.fypp b/src/ewalds_multipole_sr.fypp index 99d3e9d09d..4f8b2f528b 100644 --- a/src/ewalds_multipole_sr.fypp +++ b/src/ewalds_multipole_sr.fypp @@ -246,7 +246,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = EXP(-dampa_ij*r) + dampaexpi = dexp(-dampa_ij*r) dampfunci = dampsumfi*dampaexpi*dampfac_ij dampfuncdiffi = -dampa_ij*dampaexpi* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -267,7 +267,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = EXP(-dampa_ji*r) + dampaexpj = dexp(-dampa_ji*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ji dampfuncdiffj = -dampa_ji*dampaexpj* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & @@ -287,7 +287,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = EXP(-dampa_ij*r) + dampaexpj = dexp(-dampa_ij*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ij dampfuncdiffj = -dampa_ij*dampaexpj* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -308,7 +308,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = EXP(-dampa_ji*r) + dampaexpi = dexp(-dampa_ji*r) dampfunci = dampsumfi*dampaexpi*dampfac_ji dampfuncdiffi = -dampa_ji*dampaexpi* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & diff --git a/src/excited_states.F b/src/excited_states.F index 13329ec4db..a5ab99bb5d 100644 --- a/src/excited_states.F +++ b/src/excited_states.F @@ -112,9 +112,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=ex_env%debug_forces) ELSE ! KS-DFT diff --git a/src/exstates_types.F b/src/exstates_types.F index d7d535d6b9..1b9c77dd55 100644 --- a/src/exstates_types.F +++ b/src/exstates_types.F @@ -106,9 +106,8 @@ CONTAINS CALL cp_fm_release(ex_env%wfn_history%evect) CALL cp_fm_release(ex_env%wfn_history%cpmos) - IF (ALLOCATED(ex_env%gw_eigen)) THEN + IF (ALLOCATED(ex_env%gw_eigen)) & DEALLOCATE (ex_env%gw_eigen) - END IF DEALLOCATE (ex_env) diff --git a/src/f77_interface.F b/src/f77_interface.F index 28be264b2a..125ff2d120 100644 --- a/src/f77_interface.F +++ b/src/f77_interface.F @@ -755,12 +755,11 @@ CONTAINS ! Check that the order of the force_eval is the correct one CALL section_vals_val_get(force_env_sections, "METHOD", i_val=method_name_id, & i_rep_section=i_force_eval(1)) - IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) THEN + IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) & CALL cp_abort(__LOCATION__, & "In case of multiple force_eval the MAIN force_eval (the first in the list of FORCE_EVAL_ORDER or "// & "the one omitted from that order list) must be a MIXED_ENV type calculation. Please check your "// & "input file and possibly correct the MULTIPLE_FORCE_EVAL%FORCE_EVAL_ORDER. ") - END IF IF (method_name_id == do_mixed) THEN check = ASSOCIATED(force_env%mixed_env%sub_para_env) @@ -808,9 +807,8 @@ CONTAINS IF (method_name_id == do_qmmm) THEN qmmmx_section => section_vals_get_subs_vals(force_env_section, "QMMM%FORCE_MIXING") CALL section_vals_get(qmmmx_section, explicit=do_qmmm_force_mixing) - IF (do_qmmm_force_mixing) THEN - method_name_id = do_qmmmx - END IF ! QMMM Force-Mixing has its own (hidden) method_id + IF (do_qmmm_force_mixing) & + method_name_id = do_qmmmx ! QMMM Force-Mixing has its own (hidden) method_id END IF SELECT CASE (method_name_id) @@ -945,9 +943,8 @@ CONTAINS ! Release force_env_section IF (nforce_eval > 1) CALL section_vals_release(force_env_section) END DO - IF (use_multiple_para_env) THEN + IF (use_multiple_para_env) & CALL cp_rm_default_logger() - END IF DEALLOCATE (group_distribution) DEALLOCATE (i_force_eval) timer_env => get_timer_env() diff --git a/src/farming_methods.F b/src/farming_methods.F index eeb540f8e2..006de02994 100644 --- a/src/farming_methods.F +++ b/src/farming_methods.F @@ -304,7 +304,7 @@ CONTAINS WRITE (output_unit, "(T2,A)") & "FARMING| ---- WARNING ---- failed to open ("//TRIM(farming_env%restart_file_name)//"), starting at 1" END IF - CLOSE (iunit) + CLOSE (iunit, IOSTAT=stat) END IF CALL cp_print_key_finished_output(output_unit, logger, farming_section, & diff --git a/src/farming_types.F b/src/farming_types.F index 45820baede..3324a31dbb 100644 --- a/src/farming_types.F +++ b/src/farming_types.F @@ -38,8 +38,7 @@ MODULE farming_types LOGICAL :: restart = .FALSE. LOGICAL :: CYCLE = .FALSE. LOGICAL :: captain_minion = .FALSE. - ! user preference for partitioning the cpus - INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() + INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() ! user preference for partitioning the cpus CHARACTER(LEN=default_path_length) :: restart_file_name = "" ! restart file for farming CHARACTER(LEN=default_path_length) :: cwd = "" ! directory we started from INTEGER :: Njobs = -1 ! how many jobs to run diff --git a/src/fist_efield_methods.F b/src/fist_efield_methods.F index 86afa8d109..72be6551ad 100644 --- a/src/fist_efield_methods.F +++ b/src/fist_efield_methods.F @@ -103,7 +103,7 @@ CONTAINS END IF fieldpol = efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*efield%strength dfilter = efield%dfilter diff --git a/src/fist_environment_types.F b/src/fist_environment_types.F index ba016dd434..5a49675dc1 100644 --- a/src/fist_environment_types.F +++ b/src/fist_environment_types.F @@ -187,7 +187,7 @@ CONTAINS IF (PRESENT(subsys)) subsys => fist_env%subsys IF (PRESENT(efield)) efield => fist_env%efield - IF (ASSOCIATED(fist_env%subsys)) THEN + IF (ASSOCIATED(fist_env%subsys)) & CALL cp_subsys_get(fist_env%subsys, & atomic_kinds=atomic_kinds, & local_molecules=local_molecules, & @@ -200,7 +200,6 @@ CONTAINS multipoles=fist_multipoles, & results=results, & cell=cell) - END IF IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds%els diff --git a/src/fist_force.F b/src/fist_force.F index f2ab3a0281..2cff3aba15 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -735,7 +735,7 @@ CONTAINS shell_particle_set(i)%f(3) = fshell_total(3, i) + fgshell_coulomb(3, i) END DO - ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms @@ -767,7 +767,7 @@ CONTAINS shell_particle_set(i)%f(2) = fshell_total(2, i) shell_particle_set(i)%f(3) = fshell_total(3, i) END DO - ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms diff --git a/src/fist_intra_force.F b/src/fist_intra_force.F index 9838cd3333..882ca5fe8f 100644 --- a/src/fist_intra_force.F +++ b/src/fist_intra_force.F @@ -272,9 +272,9 @@ CONTAINS b32 = particle_set(index_c)%r - particle_set(index_b)%r b12 = pbc(b12, cell) b32 = pbc(b32, cell) - d12 = NORM2(b12) + d12 = SQRT(DOT_PRODUCT(b12, b12)) id12 = 1.0_dp/d12 - d32 = NORM2(b32) + d32 = SQRT(DOT_PRODUCT(b32, b32)) id32 = 1.0_dp/d32 dist = DOT_PRODUCT(b12, b32) theta = (dist*id12*id32) @@ -343,11 +343,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = NORM2(tm) + sm = SQRT(DOT_PRODUCT(tm, tm)) ism = 1.0_dp/sm - sn = NORM2(tn) + sn = SQRT(DOT_PRODUCT(tn, tn)) isn = 1.0_dp/sn - s32 = NORM2(t32) + s32 = SQRT(DOT_PRODUCT(t32, t32)) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -415,11 +415,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = NORM2(tm) + sm = SQRT(DOT_PRODUCT(tm, tm)) ism = 1.0_dp/sm - sn = NORM2(tn) + sn = SQRT(DOT_PRODUCT(tn, tn)) isn = 1.0_dp/sn - s32 = NORM2(t32) + s32 = SQRT(DOT_PRODUCT(t32, t32)) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -483,8 +483,8 @@ CONTAINS tm(1) = t32(2)*t12(3) - t12(2)*t32(3) tm(2) = -t32(1)*t12(3) + t12(1)*t32(3) tm(3) = t32(1)*t12(2) - t12(1)*t32(2) - sm = NORM2(tm) - s32 = NORM2(t32) + sm = SQRT(DOT_PRODUCT(tm, tm)) + s32 = SQRT(DOT_PRODUCT(t32, t32)) CALL force_opbends(opbend_list(iopbend)%opbend_kind%id_type, & s32, tm, t41, t42, t43, & opbend_list(iopbend)%opbend_kind%k, & diff --git a/src/fist_neighbor_list_control.F b/src/fist_neighbor_list_control.F index 0e23752054..f16cc70787 100644 --- a/src/fist_neighbor_list_control.F +++ b/src/fist_neighbor_list_control.F @@ -39,9 +39,14 @@ MODULE fist_neighbor_list_control section_vals_val_get USE kinds, ONLY: dp USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: & - ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & - pair_potential_pp_type, siepmann_type, tersoff_type + USE pair_potential_types, ONLY: ace_type,& + allegro_type,& + gal21_type,& + gal_type,& + nequip_type,& + pair_potential_pp_type,& + siepmann_type,& + tersoff_type USE particle_types, ONLY: particle_type #include "./base/base_uses.f90" @@ -231,9 +236,6 @@ CONTAINS IF (ANY(potparm%pot(ikind, jkind)%pot%type == nequip_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF - IF (ANY(potparm%pot(ikind, jkind)%pot%type == mace_type)) THEN - full_nl(ikind, jkind) = .TRUE. - END IF IF (ANY(potparm%pot(ikind, jkind)%pot%type == ace_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF diff --git a/src/fist_neighbor_lists.F b/src/fist_neighbor_lists.F index 34694b9879..803244aac8 100644 --- a/src/fist_neighbor_lists.F +++ b/src/fist_neighbor_lists.F @@ -685,7 +685,7 @@ CONTAINS ra(:) = pbc(particle_set(atom_a)%r, cell) rb(:) = pbc(particle_set(atom_b)%r, cell) rab = rb(:) - ra(:) + cell_v - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) IF (ilist <= neighbor_kind_pair%nscale) THEN WRITE (UNIT=output_unit, FMT="(T3,2(I6,3(1X,F10.6)),3(1X,I3),10X,F8.4,L4,F11.5,F9.5)") & atom_a, ra(1:3)*conv, & diff --git a/src/fist_nonbond_env_types.F b/src/fist_nonbond_env_types.F index 045df06365..c90883e177 100644 --- a/src/fist_nonbond_env_types.F +++ b/src/fist_nonbond_env_types.F @@ -23,8 +23,8 @@ MODULE fist_nonbond_env_types USE kinds, ONLY: default_string_length,& dp USE pair_potential_types, ONLY: & - ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & - pair_potential_pp_release, pair_potential_pp_type, siepmann_type, tersoff_type + ace_type, allegro_type, gal21_type, gal_type, nequip_type, pair_potential_pp_release, & + pair_potential_pp_type, siepmann_type, tersoff_type USE torch_api, ONLY: torch_model_release,& torch_model_type #include "./base/base_uses.f90" @@ -189,36 +189,29 @@ CONTAINS IF (PRESENT(rlist_lowsq)) rlist_lowsq => fist_nonbond_env%rlist_lowsq IF (PRESENT(ij_kind_full_fac)) ij_kind_full_fac => fist_nonbond_env%ij_kind_full_fac IF (PRESENT(nonbonded)) nonbonded => fist_nonbond_env%nonbonded - IF (PRESENT(r_last_update)) THEN + IF (PRESENT(r_last_update)) & r_last_update => fist_nonbond_env%r_last_update - END IF - IF (PRESENT(r_last_update_pbc)) THEN + IF (PRESENT(r_last_update_pbc)) & r_last_update_pbc => fist_nonbond_env%r_last_update_pbc - END IF - IF (PRESENT(rshell_last_update_pbc)) THEN + IF (PRESENT(rshell_last_update_pbc)) & rshell_last_update_pbc => fist_nonbond_env%rshell_last_update_pbc - END IF - IF (PRESENT(rcore_last_update_pbc)) THEN + IF (PRESENT(rcore_last_update_pbc)) & rcore_last_update_pbc => fist_nonbond_env%rcore_last_update_pbc - END IF - IF (PRESENT(cell_last_update)) THEN + IF (PRESENT(cell_last_update)) & cell_last_update => fist_nonbond_env%cell_last_update - END IF IF (PRESENT(lup)) lup = fist_nonbond_env%lup IF (PRESENT(aup)) aup = fist_nonbond_env%aup IF (PRESENT(ei_scale14)) ei_scale14 = fist_nonbond_env%ei_scale14 IF (PRESENT(vdw_scale14)) vdw_scale14 = fist_nonbond_env%vdw_scale14 - IF (PRESENT(shift_cutoff)) THEN + IF (PRESENT(shift_cutoff)) & shift_cutoff = fist_nonbond_env%shift_cutoff - END IF IF (PRESENT(do_electrostatics)) do_electrostatics = fist_nonbond_env%do_electrostatics IF (PRESENT(natom_types)) natom_types = fist_nonbond_env%natom_types IF (PRESENT(counter)) counter = fist_nonbond_env%counter IF (PRESENT(last_update)) last_update = fist_nonbond_env%last_update IF (PRESENT(num_update)) num_update = fist_nonbond_env%num_update - IF (PRESENT(long_range_correction)) THEN + IF (PRESENT(long_range_correction)) & long_range_correction = fist_nonbond_env%long_range_correction - END IF END SUBROUTINE fist_nonbond_env_get ! ************************************************************************************************** @@ -290,36 +283,29 @@ CONTAINS IF (PRESENT(charges)) fist_nonbond_env%charges => charges IF (PRESENT(rlist_lowsq)) fist_nonbond_env%rlist_lowsq => rlist_lowsq IF (PRESENT(nonbonded)) fist_nonbond_env%nonbonded => nonbonded - IF (PRESENT(r_last_update)) THEN + IF (PRESENT(r_last_update)) & fist_nonbond_env%r_last_update => r_last_update - END IF - IF (PRESENT(r_last_update_pbc)) THEN + IF (PRESENT(r_last_update_pbc)) & fist_nonbond_env%r_last_update_pbc => r_last_update_pbc - END IF - IF (PRESENT(rshell_last_update_pbc)) THEN + IF (PRESENT(rshell_last_update_pbc)) & fist_nonbond_env%rshell_last_update_pbc => rshell_last_update_pbc - END IF - IF (PRESENT(rcore_last_update_pbc)) THEN + IF (PRESENT(rcore_last_update_pbc)) & fist_nonbond_env%rcore_last_update_pbc => rcore_last_update_pbc - END IF - IF (PRESENT(cell_last_update)) THEN + IF (PRESENT(cell_last_update)) & fist_nonbond_env%cell_last_update => cell_last_update - END IF IF (PRESENT(lup)) fist_nonbond_env%lup = lup IF (PRESENT(aup)) fist_nonbond_env%aup = aup IF (PRESENT(ei_scale14)) fist_nonbond_env%ei_scale14 = ei_scale14 IF (PRESENT(vdw_scale14)) fist_nonbond_env%vdw_scale14 = vdw_scale14 - IF (PRESENT(shift_cutoff)) THEN + IF (PRESENT(shift_cutoff)) & fist_nonbond_env%shift_cutoff = shift_cutoff - END IF IF (PRESENT(do_electrostatics)) fist_nonbond_env%do_electrostatics = do_electrostatics IF (PRESENT(natom_types)) fist_nonbond_env%natom_types = natom_types IF (PRESENT(counter)) fist_nonbond_env%counter = counter IF (PRESENT(last_update)) fist_nonbond_env%last_update = last_update IF (PRESENT(num_update)) fist_nonbond_env%num_update = num_update - IF (PRESENT(long_range_correction)) THEN + IF (PRESENT(long_range_correction)) & fist_nonbond_env%long_range_correction = long_range_correction - END IF END SUBROUTINE fist_nonbond_env_set ! ************************************************************************************************** @@ -497,10 +483,6 @@ CONTAINS fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp END IF - IF (ANY(potparm%pot(idim, jdim)%pot%type == mace_type)) THEN - fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp - fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp - END IF IF (ANY(potparm%pot(idim, jdim)%pot%type == allegro_type)) THEN fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.F index 0d6680b31c..6de5a4894d 100644 --- a/src/fist_nonbond_force.F +++ b/src/fist_nonbond_force.F @@ -38,9 +38,9 @@ MODULE fist_nonbond_force USE message_passing, ONLY: mp_comm_type USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, gal21_type, gal_type, mace_type, nequip_type, & - nosh_nosh, nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, & - siepmann_type, tersoff_type + ace_type, allegro_type, deepmd_type, gal21_type, gal_type, nequip_type, nosh_nosh, & + nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, siepmann_type, & + tersoff_type USE particle_types, ONLY: particle_type USE shell_potential_types, ONLY: get_shell,& shell_kind_type @@ -231,7 +231,6 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & - .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = 0.5_dp*fac_ei @@ -723,7 +722,6 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & - .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = fac_ei*0.5_dp diff --git a/src/floquet_utils.F b/src/floquet_utils.F index 182c1a0e93..b5e0f05f72 100644 --- a/src/floquet_utils.F +++ b/src/floquet_utils.F @@ -303,7 +303,7 @@ CONTAINS ! E_factor(α) = (i E(α) exp(i·φ(α)))/(2ω) where α = x,y,z DO i_dir = 1, 3 - efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(COS(phi(i_dir)), SIN(phi(i_dir)), KIND=dp)/(2*omega) + efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(DCOS(phi(i_dir)), DSIN(phi(i_dir)), KIND=dp)/(2*omega) END DO DO i_dir = 1, 3 diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index 2ae9174c83..17c77dc1eb 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -439,9 +439,8 @@ CONTAINS ! * the source matrix is distributed across a number of processes, or ! * not all elements of the target matrix will be assigned, e.g. ! when the target matrix is larger then the source matrix - IF (do_zero) THEN + IF (do_zero) & CALL zcopy(SIZE(target_m), z_zero, 0, target_m(1, 1), 1) - END IF IF (tr_a) THEN DO j = start_col_local, end_col_local @@ -669,17 +668,14 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & CPABORT("internal local_data has different sizes") - END IF CALL zcopy(SIZE(source%local_data), source%local_data(1, 1), 1, destination%local_data(1, 1), 1) ELSE - IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) THEN + IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) & CPABORT("cannot copy between full matrixes of differen sizes") - END IF - IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) THEN + IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) & CPABORT("cannot copy between full matrixes of differen sizes") - END IF #if defined(__parallel) CALL pzcopy(source%matrix_struct%nrow_global* & source%matrix_struct%ncol_global, & @@ -1072,8 +1068,7 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another - ! routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends diff --git a/src/fm/cp_fm_diag_utils.F b/src/fm/cp_fm_diag_utils.F index d613da3fc9..8ac6dc147e 100644 --- a/src/fm/cp_fm_diag_utils.F +++ b/src/fm/cp_fm_diag_utils.F @@ -200,14 +200,12 @@ CONTAINS ncpu = num_pe_old - nzero ! Avoid layouts with odd number of CPUs (blacs grid layout will be square) - IF (ncpu > 2) THEN + IF (ncpu > 2) & ncpu = ncpu - MODULO(ncpu, 2) - END IF ! if there are no zero-width columns and the number of processors was even, leave it at that - IF (ncpu == num_pe_old) THEN + IF (ncpu == num_pe_old) & RETURN - END IF ! Iteratively search for the maximum number of CPUs for ELPA ! On each step, we test whether the blacs grid created with ncpu processes @@ -218,9 +216,8 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(ncpu, dp))) jpe = ncpu/ipe - IF (ipe*jpe /= ncpu) THEN + IF (ipe*jpe /= ncpu) & CYCLE - END IF IF (gcd(ipe, jpe) >= gcd_max) THEN npcol = jpe gcd_max = gcd(ipe, jpe) @@ -231,20 +228,17 @@ CONTAINS ! (snippet copied from cp_fm_struct.F:cp_fm_struct_create) nzero = 0 DO ipe = 0, npcol - 1 - IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) THEN + IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) & nzero = nzero + 1 - END IF END DO - IF (nzero == 0) THEN + IF (nzero == 0) & EXIT - END IF ncpu = ncpu - nzero - IF (ncpu > 2) THEN + IF (ncpu > 2) & ncpu = ncpu - MODULO(ncpu, 2) - END IF END DO END FUNCTION cp_fm_max_ncpu_non_zero_column @@ -429,9 +423,8 @@ CONTAINS eigenvectors_new = eigenvectors END IF - IF (PRESENT(redist_info)) THEN + IF (PRESENT(redist_info)) & redist_info = rdinfo - END IF #else MARK_USED(matrix) diff --git a/src/fm/cp_fm_elpa.F b/src/fm/cp_fm_elpa.F index 0fed54533c..c55f3ba75f 100644 --- a/src/fm/cp_fm_elpa.F +++ b/src/fm/cp_fm_elpa.F @@ -192,9 +192,8 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: one_stage, qr, should_print #if defined(__ELPA) - IF (elpa_init(20180525) /= ELPA_OK) THEN + IF (elpa_init(20180525) /= ELPA_OK) & CPABORT("The linked ELPA library does not support the required API version") - END IF IF (PRESENT(one_stage)) elpa_one_stage = one_stage IF (PRESENT(should_print)) elpa_print = should_print IF (PRESENT(qr)) elpa_qr = qr @@ -295,9 +294,8 @@ CONTAINS caller_is_elpa=.TRUE., redist_info=rdinfo) ! Call ELPA on CPUs that hold the new matrix - IF (ASSOCIATED(matrix_new%matrix_struct)) THEN + IF (ASSOCIATED(matrix_new%matrix_struct)) & CALL cp_fm_diag_elpa_base(matrix_new, eigenvectors_new, eigenvalues, rdinfo) - END IF ! Redistribute results and clean up CALL cp_fm_redistribute_end(matrix, eigenvectors, eigenvalues, matrix_new, eigenvectors_new) @@ -391,14 +389,12 @@ CONTAINS ! Matrix order must be even use_qr = elpa_qr .AND. (MODULO(n, 2) == 0) ! Matrix order and block size must be greater than or equal to 64 - IF (.NOT. elpa_qr_unsafe) THEN + IF (.NOT. elpa_qr_unsafe) & use_qr = use_qr .AND. (n >= 64) .AND. (nblk >= 64) - END IF ! Check if eigenvalues computed with elpa_qr_unsafe should be verified - IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) THEN + IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) & check_eigenvalues = .TRUE. - END IF CALL matrix%matrix_struct%para_env%bcast(check_eigenvalues) @@ -501,9 +497,8 @@ CONTAINS CALL elpa_obj%set("solver", & MERGE(ELPA_SOLVER_1STAGE, ELPA_SOLVER_2STAGE, elpa_one_stage), & success) - IF (success /= ELPA_OK) THEN + IF (success /= ELPA_OK) & CPABORT("Setting solver for ELPA failed") - END IF ! enabling the GPU must happen before setting the kernel SELECT CASE (elpa_kernel) @@ -544,9 +539,8 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (success /= ELPA_OK) THEN + IF (success /= ELPA_OK) & CPABORT("ELPA failed to diagonalize a matrix") - END IF IF (check_eigenvalues) THEN ! run again without QR @@ -554,13 +548,11 @@ CONTAINS CPASSERT(success == ELPA_OK) CALL elpa_obj%eigenvectors(matrix_noqr%local_data, eval_noqr, eigenvectors_noqr%local_data, success) - IF (success /= ELPA_OK) THEN + IF (success /= ELPA_OK) & CPABORT("ELPA failed to diagonalize a matrix even without QR decomposition") - END IF - IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) THEN + IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) & CPABORT("ELPA failed to calculate Eigenvalues with ELPA's QR decomposition") - END IF DEALLOCATE (eval_noqr) CALL cp_fm_release(matrix_noqr) diff --git a/src/fm/cp_fm_struct.F b/src/fm/cp_fm_struct.F index 3082c01518..717f915611 100644 --- a/src/fm/cp_fm_struct.F +++ b/src/fm/cp_fm_struct.F @@ -232,9 +232,8 @@ CONTAINS ALLOCATE (fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1) - 1)), & fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2) - 1))) - IF (.NOT. PRESENT(template_fmstruct)) THEN + IF (.NOT. PRESENT(template_fmstruct)) & fmstruct%first_p_pos = [0, 0] - END IF IF (PRESENT(first_p_pos)) fmstruct%first_p_pos = first_p_pos fmstruct%nrow_locals = 0 @@ -267,12 +266,10 @@ CONTAINS CALL m_flush(iunit) END IF - IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) THEN + IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) & CPABORT("sum of local cols not equal global cols") - END IF - IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) THEN + IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) & CPABORT("sum of local row not equal global rows") - END IF #else ! block = full matrix fmstruct%nrow_block = fmstruct%nrow_global @@ -284,11 +281,10 @@ CONTAINS fmstruct%local_leading_dimension = MAX(fmstruct%local_leading_dimension, & fmstruct%nrow_locals(fmstruct%context%mepos(1))) IF (PRESENT(local_leading_dimension)) THEN - IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) THEN + IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) & CALL cp_abort(__LOCATION__, "local_leading_dimension too small ("// & cp_to_string(local_leading_dimension)//"<"// & cp_to_string(fmstruct%local_leading_dimension)//")") - END IF fmstruct%local_leading_dimension = local_leading_dimension END IF diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 756ad2f27e..75d6c4e816 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -482,9 +482,8 @@ CONTAINS my_ncol = matrix%matrix_struct%ncol_global IF (PRESENT(ncol)) my_ncol = ncol - IF (ncol_global < (my_start_col + my_ncol - 1)) THEN + IF (ncol_global < (my_start_col + my_ncol - 1)) & CPABORT("ncol_global>=(my_start_col+my_ncol-1)") - END IF ALLOCATE (buff(nrow_global)) @@ -1269,7 +1268,7 @@ CONTAINS IF (PRESENT(dir)) THEN IF (dir == 'c' .OR. dir == 'C') THEN docol = .TRUE. - ELSE IF (dir == 'r' .OR. dir == 'R') THEN + ELSEIF (dir == 'r' .OR. dir == 'R') THEN docol = .FALSE. ELSE CPABORT('Wrong argument DIR') @@ -1327,12 +1326,11 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & CALL cp_abort(__LOCATION__, & "Cannot copy full matrix <"//TRIM(source%name)// & "> to full matrix <"//TRIM(destination%name)// & ">. The local_data blocks have different sizes.") - END IF CALL dcopy(SIZE(source%local_data, 1)*SIZE(source%local_data, 2), & source%local_data, 1, destination%local_data, 1) ELSE @@ -1474,21 +1472,17 @@ CONTAINS na = msource%matrix_struct%nrow_global nb = mtarget%matrix_struct%nrow_global ! nrow must be <= na and nb - IF (nrow > na) THEN + IF (nrow > na) & CPABORT("cannot copy because nrow > number of rows of source matrix") - END IF - IF (nrow > nb) THEN + IF (nrow > nb) & CPABORT("cannot copy because nrow > number of rows of target matrix") - END IF na = msource%matrix_struct%ncol_global nb = mtarget%matrix_struct%ncol_global ! ncol must be <= na_col and nb_col - IF (ncol > na) THEN + IF (ncol > na) & CPABORT("cannot copy because nrow > number of rows of source matrix") - END IF - IF (ncol > nb) THEN + IF (ncol > nb) & CPABORT("cannot copy because nrow > number of rows of target matrix") - END IF #if defined(__parallel) desca(:) = msource%matrix_struct%descriptor(:) @@ -1722,8 +1716,7 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another - ! routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends @@ -2019,12 +2012,10 @@ CONTAINS ! check whether source is available on this process IF (ASSOCIATED(source%matrix_struct)) THEN desca = source%matrix_struct%descriptor - IF (nrows > source%matrix_struct%nrow_global) THEN + IF (nrows > source%matrix_struct%nrow_global) & CPABORT("nrows is greater than nrow_global of source") - END IF - IF (ncols > source%matrix_struct%ncol_global) THEN + IF (ncols > source%matrix_struct%ncol_global) & CPABORT("ncols is greater than ncol_global of source") - END IF smat => source%local_data ELSE desca = -1 @@ -2033,12 +2024,10 @@ CONTAINS ! check destination is available on this process IF (ASSOCIATED(destination%matrix_struct)) THEN descb = destination%matrix_struct%descriptor - IF (nrows > destination%matrix_struct%nrow_global) THEN + IF (nrows > destination%matrix_struct%nrow_global) & CPABORT("nrows is greater than nrow_global of destination") - END IF - IF (ncols > destination%matrix_struct%ncol_global) THEN + IF (ncols > destination%matrix_struct%ncol_global) & CPABORT("ncols is greater than ncol_global of destination") - END IF dmat => destination%local_data ELSE descb = -1 diff --git a/src/force_env_methods.F b/src/force_env_methods.F index abb560ea63..28cbe7e2ac 100644 --- a/src/force_env_methods.F +++ b/src/force_env_methods.F @@ -404,9 +404,8 @@ CONTAINS "PRINT%PROGRAM_RUN_INFO") ! terminate the run if the value of the potential is abnormal - IF (abnormal_value(e_pot)) THEN + IF (abnormal_value(e_pot)) & CPABORT("Potential energy is an abnormal value (NaN/Inf).") - END IF ! Print forces, if requested print_forces = cp_print_key_unit_nr(logger, force_env%force_env_section, "PRINT%FORCES", & @@ -626,15 +625,13 @@ CONTAINS (.NOT. use_full_grid) ! Preserve restrictions selected during initial setup. The explicit DEBUG expert option ! remains available for symmetry diagnostics on otherwise unsupported cell matrices. - IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN + IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & use_inversion_symmetry_only = .TRUE. - END IF non_lower_triangular_cell = (ABS(cell%hmat(2, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 2)) > eps_cell) - IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN + IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & use_inversion_symmetry_only = .TRUE. - END IF dynamic_symmetry = kpoint_symmetry .AND. .NOT. use_full_grid .AND. & .NOT. use_inversion_symmetry_only IF (run_type_id == debug_run .AND. .NOT. fd_energy .AND. .NOT. dynamic_symmetry .AND. & @@ -1285,9 +1282,8 @@ CONTAINS !Transfer results source = 0 IF (ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) THEN - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & source = force_env%para_env%mepos - END IF END IF CALL force_env%para_env%sum(source) CALL cp_results_mp_bcast(results(iforce_eval)%results, source, force_env%para_env) @@ -1398,17 +1394,14 @@ CONTAINS CALL section_vals_val_get(mixed_section, "MIXED_CDFT%LAMBDA", r_val=lambda) ! Get the states which determine the forces CALL section_vals_val_get(mixed_section, "MIXED_CDFT%FORCE_STATES", i_vals=itmplist) - IF (SIZE(itmplist) /= 2) THEN + IF (SIZE(itmplist) /= 2) & CALL cp_abort(__LOCATION__, & "Keyword FORCE_STATES takes exactly two input values.") - END IF - IF (ANY(itmplist < 0)) THEN + IF (ANY(itmplist < 0)) & CPABORT("Invalid force_eval index.") - END IF istate = itmplist - IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) THEN + IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) & CPABORT("Invalid force_eval index.") - END IF mixed_energy%pot = lambda*energies(istate(1)) + (1.0_dp - lambda)*energies(istate(2)) ! General Mapping of forces... CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results, & @@ -1522,9 +1515,8 @@ CONTAINS ! Get Mapping index array natom = SIZE(particles(iforce_eval)%list%els) ! Serial mode need to deallocate first - IF (ASSOCIATED(map_index)) THEN + IF (ASSOCIATED(map_index)) & DEALLOCATE (map_index) - END IF CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, & map_index) @@ -1534,9 +1526,8 @@ CONTAINS particles(iforce_eval)%list%els(iparticle)%r = particles_mix%els(jparticle)%r END DO ! Mixed CDFT + QMMM: Need to translate now - IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN + IF (force_env%mixed_env%do_mixed_qmmm_cdft) & CALL apply_qmmm_translate(force_env%sub_force_env(iforce_eval)%force_env%qmmm_env) - END IF END DO ! For mixed CDFT calculations parallelized over CDFT states ! build weight and gradient on all processors before splitting into groups and @@ -1602,9 +1593,8 @@ CONTAINS nforce_eval = SIZE(force_env%sub_force_env) nvar = force_env%mixed_env%cdft_control%nconstraint ! Transfer cdft strengths for writing restart - IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) THEN + IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) & ALLOCATE (force_env%mixed_env%strength(nforce_eval, nvar)) - END IF force_env%mixed_env%strength = 0.0_dp DO iforce_eval = 1, nforce_eval IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE @@ -1614,16 +1604,14 @@ CONTAINS CALL force_env_get(force_env%sub_force_env(iforce_eval)%force_env, qs_env=qs_env) END IF CALL get_qs_env(qs_env, dft_control=dft_control) - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & force_env%mixed_env%strength(iforce_eval, :) = dft_control%qs_control%cdft_control%strength(:) - END IF END DO CALL force_env%para_env%sum(force_env%mixed_env%strength) ! Mixed CDFT: calculate ET coupling IF (force_env%mixed_env%do_mixed_et) THEN - IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) THEN + IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) & CALL mixed_cdft_calculate_coupling(force_env) - END IF END IF END IF @@ -2145,10 +2133,9 @@ CONTAINS ! Calculate potential gradient if the step has been accepted. Otherwise, we reuse the previous one - IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) THEN + IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) & CALL calculate_embed_pot_grad(force_env%sub_force_env(ref_subsys_number)%force_env%qs_env, & diff_rho_r, diff_rho_spin, opt_embed) - END IF ! Take the embedding step CALL opt_embed_step(diff_rho_r, diff_rho_spin, opt_embed, embed_pot, spin_embed_pot, rho_r_ref, & force_env%sub_force_env(ref_subsys_number)%force_env%qs_env) diff --git a/src/force_env_types.F b/src/force_env_types.F index f13f5bfbf1..339fcfeb75 100644 --- a/src/force_env_types.F +++ b/src/force_env_types.F @@ -230,12 +230,10 @@ CONTAINS CALL cp_add_default_logger(my_logger) END IF CALL force_env_release(force_env%sub_force_env(i)%force_env) - IF (force_env%in_use == use_mixed_force) THEN + IF (force_env%in_use == use_mixed_force) & CALL cp_rm_default_logger() - END IF - IF (force_env%in_use == use_embed) THEN + IF (force_env%in_use == use_embed) & CALL cp_rm_default_logger() - END IF END DO DEALLOCATE (force_env%sub_force_env) END IF diff --git a/src/force_env_utils.F b/src/force_env_utils.F index aba2988c97..699045290f 100644 --- a/src/force_env_utils.F +++ b/src/force_env_utils.F @@ -393,7 +393,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) DO iparticle = 1, SIZE(particles%els) force = particles%els(iparticle)%f(:) - mod_force = NORM2(force) + mod_force = SQRT(DOT_PRODUCT(force, force)) IF ((mod_force > max_value) .AND. (mod_force /= 0.0_dp)) THEN force = force/mod_force*max_value particles%els(iparticle)%f(:) = force diff --git a/src/force_fields_all.F b/src/force_fields_all.F index 798fe280b8..061e971116 100644 --- a/src/force_fields_all.F +++ b/src/force_fields_all.F @@ -64,11 +64,10 @@ MODULE force_fields_all spline_nonbond_control USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, mace_type, & - nequip_type, nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, & - pair_potential_pp_create, pair_potential_pp_type, pair_potential_single_add, & - pair_potential_single_clean, pair_potential_single_copy, pair_potential_single_type, & - sh_sh, siepmann_type, tersoff_type + ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, nequip_type, & + nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, pair_potential_pp_create, & + pair_potential_pp_type, pair_potential_single_add, pair_potential_single_clean, & + pair_potential_single_copy, pair_potential_single_type, sh_sh, siepmann_type, tersoff_type USE particle_types, ONLY: allocate_particle_set,& particle_type USE physcon, ONLY: bohr @@ -2026,12 +2025,11 @@ CONTAINS only_qm = qmmm_ff_precond_only_qm(id1=atmname, is_link=is_link_atom) CALL uppercase(atmname) - IF (charge /= -HUGE(0.0_dp)) THEN + IF (charge /= -HUGE(0.0_dp)) & CALL cp_warn(__LOCATION__, & "The charge for atom index ("//cp_to_string(iatom)//") and atom name ("// & TRIM(atmname)//") was already defined. The charge associated to this kind"// & " will be set to an uninitialized value and only the atom specific charge will be used! ") - END IF charge = -HUGE(0.0_dp) ! Check if the potential really requires the charge definition.. @@ -2173,11 +2171,10 @@ CONTAINS inp_info%shell_list(j)%shell%charge_shell charge = 0.0_dp IF (found) THEN - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "CORE-SHELL model defined for KIND ("//TRIM(atmname)//")"// & " ignoring charge definition! ") - END IF ELSE found = .TRUE. END IF @@ -2195,7 +2192,7 @@ CONTAINS atmname == inp_info%nonbonded%pot(j)%pot%at2) THEN SELECT CASE (inp_info%nonbonded%pot(j)%pot%type(1)) CASE (ea_type, tersoff_type, siepmann_type, nequip_type, & - allegro_type, deepmd_type, ace_type, mace_type) + allegro_type, deepmd_type, ace_type) ! Charge is zero for EAM, TERSOFF and SIEPMANN type potential ! Do nothing.. CASE DEFAULT @@ -2932,20 +2929,18 @@ CONTAINS ((name_atm_a) == (inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" ADDING! ") - END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declarations: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") - END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. @@ -2976,20 +2971,18 @@ CONTAINS ((name_atm_a) == (qmmm_env%inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" Adding QM/MM forcefield specifications") - END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING QM/MM forcefield specifications! ") - END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), & " ", TRIM(name_atm_b) @@ -3234,20 +3227,18 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") - END IF END IF found = .TRUE. END IF @@ -3277,20 +3268,18 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") - END IF END IF found = .TRUE. END IF @@ -3317,20 +3306,18 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> ADDING") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> OVERWRITING") - END IF END IF found = .TRUE. END DO @@ -3364,20 +3351,18 @@ CONTAINS END IF IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> ADDING QM/MM forcefield specifications") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> OVERWRITING QM/MM forcefield specifications") - END IF END IF found = .TRUE. END IF @@ -3648,10 +3633,9 @@ CONTAINS IF (PRESENT(atm3)) fmt = fmt + 1 IF (PRESENT(atm4)) fmt = fmt + 1 CALL integer_to_string(fmt - 1, sfmt) - IF (fmt > 1) THEN + IF (fmt > 1) & my_format = '(T2,"FORCEFIELD| Missing ","'//TRIM(type_name)// & '",T40,"(",A9,'//TRIM(sfmt)//'(",",A9),")")' - END IF IF (PRESENT(fatal)) fatal = .TRUE. ! Check for previous already stored equal force fields IF (ASSOCIATED(array)) nsize = SIZE(array) @@ -3676,9 +3660,8 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & found = .TRUE. - END IF CASE ("Urey-Bradley") IF (INDEX(array(i) (21:39), "Urey-Bradley") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3688,9 +3671,8 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & found = .TRUE. - END IF CASE ("Torsion") IF (INDEX(array(i) (21:39), "Torsion") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3702,9 +3684,8 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) THEN + ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) & found = .TRUE. - END IF CASE ("Improper") IF (INDEX(array(i) (21:39), "Improper") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3720,9 +3701,8 @@ CONTAINS ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm2)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm3)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) THEN + ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) & found = .TRUE. - END IF CASE ("Out of plane bend") IF (INDEX(array(i) (21:39), "Out of plane bend") == 0) CYCLE @@ -3735,9 +3715,8 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) THEN + ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) & found = .TRUE. - END IF CASE ("Charge") IF (INDEX(array(i) (21:39), "Charge") == 0) CYCLE diff --git a/src/force_fields_input.F b/src/force_fields_input.F index 1df71ce40d..28fccce750 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -69,7 +69,7 @@ MODULE force_fields_input USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, deepmd_type, do_potential_single_allocation, & ea_type, eam_pot_type, ft_pot_type, ft_type, ftd_type, gal21_type, gal_type, gp_type, & - gw_type, ip_type, ipbv_pot_type, lj_charmm_type, mace_type, nequip_pot_type, nequip_type, & + gw_type, ip_type, ipbv_pot_type, lj_charmm_type, nequip_pot_type, nequip_type, & no_potential_single_allocation, pair_potential_p_type, pair_potential_reallocate, & potential_single_allocation, siepmann_type, tab_pot_type, tab_type, tersoff_type, wl_type USE shell_potential_types, ONLY: shell_p_create,& @@ -109,8 +109,8 @@ CONTAINS CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: atm_names INTEGER :: nace, nb4, nbends, nbm, nbmhft, nbmhftd, nbonds, nchg, ndeepmd, neam, ngal, & - ngal21, ngd, ngp, nimpr, nipbv, nlj, nmace, nnequip, nopbend, nshell, nsiepmann, ntab, & - ntersoff, ntors, ntot, nubs, nwl + ngal21, ngd, ngp, nimpr, nipbv, nlj, nnequip, nopbend, nshell, nsiepmann, ntab, ntersoff, & + ntors, ntot, nubs, nwl LOGICAL :: explicit, unique_spline REAL(KIND=dp) :: min_eps_spline_allowed TYPE(input_info_type), POINTER :: inp_info @@ -135,11 +135,8 @@ CONTAINS SELECT CASE (ff_type%ff_type) CASE (do_ff_charmm, do_ff_amber, do_ff_g96, do_ff_g87) CALL section_vals_val_get(ff_section, "PARM_FILE_NAME", c_val=ff_type%ff_file_name) - - IF (TRIM(ff_type%ff_file_name) == "") THEN + IF (TRIM(ff_type%ff_file_name) == "") & CPABORT("Force Field Parameter's filename is empty! Please check your input file.") - END IF - CASE (do_ff_undef) ! Do Nothing CASE DEFAULT @@ -328,19 +325,6 @@ CONTAINS CALL read_ace_section(inp_info%nonbonded, tmp_section2, ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section, "MACE") - CALL section_vals_get(tmp_section2, explicit=explicit, n_repetition=nmace) - ntot = nlj + nwl + neam + ngd + nipbv + nbmhft + nbmhftd + nb4 + nbm + ngp + ntersoff + & - ngal + ngal21 + nsiepmann + nnequip + ntab + ndeepmd + nace - IF (explicit) THEN - ! avoid repeating the mace section for each pair - CALL section_vals_val_get(tmp_section2, "ATOMS", c_vals=atm_names) - nmace = nmace - 1 + SIZE(atm_names) + (SIZE(atm_names)*SIZE(atm_names) - SIZE(atm_names))/2 - ! MACE reuses the nequip_pot_type storage (set%nequip), hence nequip=.TRUE. here - CALL pair_potential_reallocate(inp_info%nonbonded, 1, ntot + nmace, nequip=.TRUE.) - CALL read_mace_section(inp_info%nonbonded, tmp_section2, ntot) - END IF - END IF tmp_section => section_vals_get_subs_vals(ff_section, "NONBONDED14") @@ -554,9 +538,8 @@ CONTAINS ipbv%a(13) = 8756947519.029_dp ipbv%a(14) = 15793297761.67_dp ipbv%a(15) = 12917180227.21_dp - ELSE IF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & - ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN - + ELSEIF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & + ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN ipbv%rcore = 2.95_dp ! a.u. ipbv%m = -0.004025691139759147_dp ! Hartree/a.u. @@ -576,7 +559,7 @@ CONTAINS ipbv%a(13) = -4224406093.918E0_dp ipbv%a(14) = 217192386506.5E0_dp ipbv%a(15) = -157581228915.5_dp - ELSE IF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN + ELSEIF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN ipbv%rcore = 3.165_dp ! a.u. ipbv%m = 0.002639704108787555_dp ! Hartree/a.u. ipbv%b = -0.2735482611857583_dp ! Hartree @@ -616,13 +599,12 @@ CONTAINS ft%a = cp_unit_to_cp2k(424.097_dp, "eV") ft%c = cp_unit_to_cp2k(1.05_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(0.499_dp, "eV*angstrom^8") - ELSE IF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & - ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN - + ELSEIF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & + ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN ft%a = cp_unit_to_cp2k(1256.31_dp, "eV") ft%c = cp_unit_to_cp2k(7.00_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(8.676_dp, "eV*angstrom^8") - ELSE IF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN + ELSEIF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN ft%a = cp_unit_to_cp2k(3488.998_dp, "eV") ft%c = cp_unit_to_cp2k(72.50_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(145.427_dp, "eV*angstrom^8") @@ -843,54 +825,6 @@ CONTAINS END SUBROUTINE read_nequip_section -! ************************************************************************************************** -!> \brief Reads the MACE section -!> \param nonbonded ... -!> \param section ... -!> \param start ... -!> \author Xinyue Sun -! ************************************************************************************************** - SUBROUTINE read_mace_section(nonbonded, section, start) - TYPE(pair_potential_p_type), POINTER :: nonbonded - TYPE(section_vals_type), POINTER :: section - INTEGER, INTENT(IN) :: start - - CHARACTER(LEN=default_string_length) :: pot_file_name - CHARACTER(LEN=default_string_length), & - DIMENSION(:), POINTER :: atm_names - INTEGER :: isec, jsec, n_items - TYPE(nequip_pot_type) :: mace - - n_items = 1 - isec = 1 - n_items = isec*n_items - CALL section_vals_val_get(section, "ATOMS", c_vals=atm_names) - CALL section_vals_val_get(section, "POT_FILE_NAME", c_val=pot_file_name) - - mace%pot_file_name = discover_file(pot_file_name) - ! MACE models use standardized units: Angstrom, eV and eV/Angstrom - mace%unit_length = "angstrom" - mace%unit_energy = "eV" - mace%unit_forces = "eV/Angstrom" - ! MACE models are exported to speak the same metadata/tensor dialect as NequIP - CALL read_nequip_data(mace) - CALL check_cp2k_atom_names_in_torch(atm_names, mace%type_names_torch) - - DO isec = 1, SIZE(atm_names) - DO jsec = isec, SIZE(atm_names) - nonbonded%pot(start + n_items)%pot%type = mace_type - nonbonded%pot(start + n_items)%pot%at1 = atm_names(isec) - nonbonded%pot(start + n_items)%pot%at2 = atm_names(jsec) - CALL uppercase(nonbonded%pot(start + n_items)%pot%at1) - CALL uppercase(nonbonded%pot(start + n_items)%pot%at2) - nonbonded%pot(start + n_items)%pot%set(1)%nequip = mace - nonbonded%pot(start + n_items)%pot%rcutsq = mace%rcutsq - n_items = n_items + 1 - END DO - END DO - - END SUBROUTINE read_mace_section - ! ************************************************************************************************** !> \brief Reads the LJ section !> \param nonbonded ... @@ -1337,13 +1271,10 @@ CONTAINS ! Calculate p_inv the inverse of the matrix p p_inv(:, :) = 0.0_dp CALL invert_matrix(p, p_inv, eval_error) - - IF (eval_error >= 1.0E-8_dp) THEN + IF (eval_error >= 1.0E-8_dp) & CALL cp_warn(__LOCATION__, & "The polynomial fit for the BUCK4RANGES potential is only accurate to "// & TRIM(cp_to_string(eval_error))) - END IF - ! Get the 6 coefficients of the 5th-order polynomial -> x(1:6) ! and the 4 coefficients of the 3rd-order polynomial -> x(7:10) x(:) = MATMUL(p_inv(:, :), v(:)) diff --git a/src/global_types.F b/src/global_types.F index 6ce57fe286..9d076d7514 100644 --- a/src/global_types.F +++ b/src/global_types.F @@ -139,9 +139,8 @@ CONTAINS CPASSERT(globenv%ref_count > 0) globenv%ref_count = globenv%ref_count - 1 IF (globenv%ref_count == 0) THEN - IF (ALLOCATED(globenv%gaussian_rng_stream)) THEN + IF (ALLOCATED(globenv%gaussian_rng_stream)) & DEALLOCATE (globenv%gaussian_rng_stream) - END IF DEALLOCATE (globenv) END IF END IF diff --git a/src/graphcon.F b/src/graphcon.F index e2ecc59f35..7a06c59b4e 100644 --- a/src/graphcon.F +++ b/src/graphcon.F @@ -547,7 +547,7 @@ CONTAINS IF (q(k) == k) THEN q(k) = n ELSE - GOTO 1 + go to 1 END IF END DO first = .TRUE. diff --git a/src/greenx_interface.F b/src/greenx_interface.F index 50a5253c8b..be070d3bc6 100644 --- a/src/greenx_interface.F +++ b/src/greenx_interface.F @@ -13,8 +13,7 @@ MODULE greenx_interface USE kinds, ONLY: dp USE cp_log_handling, ONLY: cp_logger_type, & - cp_get_default_logger, & - cp_logger_get_default_io_unit + cp_get_default_logger USE cp_output_handling, ONLY: cp_print_key_unit_nr, & cp_print_key_finished_output, & cp_print_key_generate_filename, & @@ -210,22 +209,15 @@ CONTAINS y_eval INTEGER, OPTIONAL :: n_pade_opt #if defined (__GREENX) - CHARACTER(len=*), PARAMETER :: routineN = 'greenx_refine_ft' - INTEGER :: fit_start, & fit_end, & max_fit, & n_fit, & n_pade, & n_eval, & - i, & - handle, & - unit_nr - TYPE(cp_logger_type), POINTER :: logger + i TYPE(params) :: pade_params - CALL timeset(routineN, handle) - ! Get the sizes from arrays max_fit = SIZE(x_fit) n_eval = SIZE(x_eval) @@ -249,30 +241,10 @@ CONTAINS n_pade = n_fit/2 IF (PRESENT(n_pade_opt)) n_pade = n_pade_opt - ! Too few FT points (e.g. very short propagation with &FT on) leave n_pade < 1; - ! the Thiele recurrence would then divide by zero. Skip, returning zeros. - IF (n_pade < 1) THEN - CPWARN("FT deck too short for Padé; raise STEPS or disable &FT.") - y_eval(1:n_eval) = CMPLX(0.0, 0.0, kind=dp) - CALL timestop(handle) - RETURN - END IF - ! Warn about a large number of Padé parameters IF (n_pade > 1000) THEN CPWARN("More then 1000 Padé parameters requested - may reduce with FIT_E_MIN/FIT_E_MAX.") END IF - - ! The Padé order is derived from the FT bins inside [FIT_E_MIN, FIT_E_MAX]; report it so a - ! spectrum's fit is reconstructable from the log. Distinct from the GW AC Padé (nparam_pade). - logger => cp_get_default_logger() - unit_nr = cp_logger_get_default_io_unit(logger) - IF (unit_nr > 0) THEN - WRITE (UNIT=unit_nr, FMT="(T3,A,T45,I6,I8,2F11.4)") & - "GREENX FT_PADE| n_pade, n_fit, window [eV]", n_pade, n_fit, & - REAL(x_fit(fit_start), kind=dp)*evolt, REAL(x_fit(fit_end), kind=dp)*evolt - END IF - ! TODO : Symmetry mode settable? ! Here, we assume that ft corresponds to transform of real trace pade_params = create_thiele_pade(n_pade, x_fit(fit_start:fit_end), y_fit(fit_start:fit_end), & @@ -282,7 +254,6 @@ CONTAINS y_eval(1:n_eval) = evaluate_thiele_pade_at(pade_params, x_eval) CALL free_params(pade_params) - CALL timestop(handle) #else ! Mark used MARK_USED(fit_e_min) diff --git a/src/grid/grid_api.F b/src/grid/grid_api.F index 3868fa9a47..f93b6072be 100644 --- a/src/grid/grid_api.F +++ b/src/grid/grid_api.F @@ -474,18 +474,14 @@ CONTAINS hadb=hadb_cptr, & a_hdab=a_hdab_cptr) - IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) THEN + IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) & force_a = force_a + forces(:, 1) - END IF - IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) THEN + IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) & force_b = force_b + forces(:, 2) - END IF - IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) THEN + IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) & my_virial_a = my_virial_a + virials(:, :, 1) - END IF - IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) THEN + IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) & my_virial_b = my_virial_b + virials(:, :, 2) - END IF END SUBROUTINE integrate_pgf_product diff --git a/src/grpp/libgrpp.F b/src/grpp/libgrpp.F index 07b19227b7..820b585bca 100644 --- a/src/grpp/libgrpp.F +++ b/src/grpp/libgrpp.F @@ -16,10 +16,6 @@ MODULE libgrpp USE ISO_C_BINDING, ONLY: C_DOUBLE,& C_INT32_T - IMPLICIT NONE - - PRIVATE - INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_DIRAC = 0 INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_TURBOMOLE = 1 @@ -30,12 +26,6 @@ MODULE libgrpp INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_FERMI_BUBBLE = 4 INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_POINT_CHARGE_NUMERICAL = 5 - PUBLIC :: libgrpp_init - PUBLIC :: libgrpp_type1_integrals - PUBLIC :: libgrpp_type1_integrals_gradient - PUBLIC :: libgrpp_type2_integrals - PUBLIC :: libgrpp_type2_integrals_gradient - INTERFACE SUBROUTINE libgrpp_init() diff --git a/src/gw_integrals.F b/src/gw_integrals.F index 9036627e7d..30582ab92c 100644 --- a/src/gw_integrals.F +++ b/src/gw_integrals.F @@ -128,7 +128,7 @@ CONTAINS IF (ctx%op_ij == do_potential_truncated .OR. ctx%op_ij == do_potential_short) THEN ctx%dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor ctx%dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (ctx%op_ij == do_potential_coulomb) THEN + ELSEIF (ctx%op_ij == do_potential_coulomb) THEN ctx%dr_ij = 1000000.0_dp ctx%dr_ik = 1000000.0_dp END IF diff --git a/src/gw_large_cell_gamma.F b/src/gw_large_cell_gamma.F index 574f484230..96ab647bdb 100644 --- a/src/gw_large_cell_gamma.F +++ b/src/gw_large_cell_gamma.F @@ -64,8 +64,7 @@ MODULE gw_large_cell_gamma USE gw_utils, ONLY: analyt_conti_and_print,& de_init_bs_env,& time_to_freq - USE input_constants, ONLY: rtp_method_bse,& - rtp_method_bse_linearized + USE input_constants, ONLY: rtp_method_bse USE input_section_types, ONLY: section_vals_type USE kinds, ONLY: default_path_length,& dp,& @@ -146,7 +145,7 @@ CONTAINS ! Σ^c_λσ(iτ,k=0) -> Σ^c_nn(ϵ,k); ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ,k) + Σ^x_nn(k) - v^xc_nn(k) CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) - CALL de_init_bs_env(qs_env, bs_env) + CALL de_init_bs_env(bs_env) CALL timestop(handle) @@ -1031,14 +1030,7 @@ CONTAINS ! Marek : Reading of the W(w=0) potential for RTP ! TODO : is the condition bs_env%all_W_exist sufficient for reading? - ! This block builds - ! bs_env%fm_W_MIC_freq_zero specifically for RT-BSE consumption (read by - ! rt_bse_linearized.F initialize_cohsex_selfenergy and by - ! rt_bse_ri_rs.F rt_bse_ri_rs_ensure_W0_grid). RT-BSE-specific compute - ! embedded in GW; left here because moving it would require keeping - ! fm_W_MIC_time alive past compute_W_MIC. - IF (bs_env%rtp_method == rtp_method_bse .OR. & - bs_env%rtp_method == rtp_method_bse_linearized) THEN + IF (bs_env%rtp_method == rtp_method_bse) THEN CALL cp_fm_create(bs_env%fm_W_MIC_freq_zero, bs_env%fm_W_MIC_freq%matrix_struct) t1 = m_walltime() CALL fm_read(bs_env%fm_W_MIC_freq_zero, bs_env, "W_freq_rtp", 0) @@ -1142,9 +1134,7 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(mat_chi_Gamma_tau) ! Marek : Fourier transform W^MIC(itau) back to get it at a specific im.frequency point - iomega = 0 - ! Same RT-BSE coupling as read_W_MIC_time. - IF (bs_env%rtp_method == rtp_method_bse .OR. & - bs_env%rtp_method == rtp_method_bse_linearized) THEN + IF (bs_env%rtp_method == rtp_method_bse) THEN t1 = m_walltime() CALL cp_fm_create(bs_env%fm_W_MIC_freq_zero, bs_env%fm_W_MIC_freq%matrix_struct) ! Set to zero diff --git a/src/gw_large_cell_gamma_ri_rs.F b/src/gw_large_cell_gamma_ri_rs.F index b60e118222..5dda82c272 100644 --- a/src/gw_large_cell_gamma_ri_rs.F +++ b/src/gw_large_cell_gamma_ri_rs.F @@ -89,11 +89,7 @@ MODULE gw_large_cell_Gamma_ri_rs CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_large_cell_Gamma_ri_rs' - PUBLIC :: gw_calc_large_cell_Gamma_ri_rs, & - contract_A_B_A, & - hadamard_product_inplace, & - release_dbcsr_topology_and_matrices, & - setup_square_topology + PUBLIC :: gw_calc_large_cell_Gamma_ri_rs CONTAINS @@ -156,7 +152,6 @@ CONTAINS !!======================================================================== CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) - bs_env%ri_rs%grid_built = .TRUE. !!======================================================================== !! 4. Compute Independent-Particle Polarizability (χ) @@ -204,7 +199,7 @@ CONTAINS !!======================================================================== CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) - CALL de_init_bs_env(qs_env, bs_env) + CALL de_init_bs_env(bs_env) CALL timestop(handle) @@ -230,8 +225,8 @@ CONTAINS INTEGER :: c_size, chunk_size, dimen_ORB, handle, i, i_blk, iatom, natom, npcol, nprow, & num_grid_chunks, r_end, r_start, total_grid_npts INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf - INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, r_blk_sizes, & - row_dist + INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, col_dist_ks, & + r_blk_sizes, row_dist, row_dist_ks REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: atom_col_buffer TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell @@ -278,9 +273,12 @@ CONTAINS ! C. Fetch CP2K's Default Process Grid Configuration CALL get_qs_env(qs_env, dbcsr_dist=dbcsr_dist_ks) - CALL dbcsr_distribution_get(dbcsr_dist_ks, nprows=nprow, npcols=npcol) + CALL dbcsr_distribution_get(dbcsr_dist_ks, row_dist=row_dist_ks, col_dist=col_dist_ks) ! D. Build Custom Mappings using Round-Robin across the 2D process grid + ! (MAXVAL + 1 accounts for 0-based process indexing in DBCSR) + nprow = MAXVAL(row_dist_ks) + 1 + npcol = MAXVAL(col_dist_ks) + 1 ALLOCATE (row_dist(num_grid_chunks)) DO i = 1, num_grid_chunks @@ -381,35 +379,25 @@ CONTAINS TYPE(cell_type), POINTER :: cell REAL(KIND=dp), INTENT(IN) :: r2_threshold - CHARACTER(LEN=*), PARAMETER :: routineN = 'fill_phi_for_atom' - - INTEGER :: first_sgf, handle, i_pt, ico, iend_co, ikind, ipgf, iset, isgf, ishell, & - istart_co, ix, ix_max, ix_min, iy, iy_max, iy_min, iz, iz_max, iz_min, l, last_sgf, lx, & - ly, lz, n_cart_total, row_idx + INTEGER :: first_sgf, i_pt, ico, iend_co, ikind, ipgf, iset, isgf, ishell, istart_co, ix, & + ix_max, ix_min, iy, iy_max, iy_min, iz, iz_max, iz_min, l, last_sgf, lx, ly, lz, & + n_cart_total, row_idx REAL(KIND=dp) :: alpha, cell_vector(3), dist_vec(3), & dist_vec_raw(3), exp_val, poly, r2, & r_atom(3), weight REAL(KIND=dp), DIMENSION(3, 3) :: hmat TYPE(gto_basis_set_type), POINTER :: orb_basis_set - CALL timeset(routineN, handle) - ! Get Atom Info ikind = particle_set(iatom)%atomic_kind%kind_number CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type="ORB") CALL get_cell(cell=cell, h=hmat) - IF (.NOT. ASSOCIATED(orb_basis_set)) THEN - CALL timestop(handle) - RETURN - END IF + IF (.NOT. ASSOCIATED(orb_basis_set)) RETURN - IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0 - END IF - IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0 - END IF - IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0 - END IF + IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0; END IF + IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0; END IF + IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0; END IF r_atom = particle_set(iatom)%r @@ -475,8 +463,6 @@ CONTAINS END DO !$OMP END PARALLEL DO - CALL timestop(handle) - END SUBROUTINE fill_phi_for_atom ! ************************************************************************************************** @@ -501,14 +487,13 @@ CONTAINS routineN = 'compute_coeff_Z_lP' INTEGER :: atom_j_mepos, atom_j_stride, atom_P, atom_P_start, atom_P_stride, col_end, & - col_start, current_chunk_size, g, group_handle, handle, handle_dpotrf, handle_dpotrs, & - handle_dsyrk, i, i_blk, ikind, info, j, j_ri, l, loc_idx, loc_ptr, max_ao_size, & - max_loc_ri, my_group, n_ao_total, n_grid_total, n_groups, n_loc_ri, n_local_grid, & - n_procs_per_atom, natom, nkind, npcol_phi, num_grid_chunks, P_loop_atom, r_end, r_start, & - source_atom + col_start, current_chunk_size, g, group_handle, handle, i, i_blk, ikind, info, j, j_ri, & + l, loc_idx, loc_ptr, max_ao_size, max_loc_ri, my_group, n_ao_total, n_grid_total, & + n_groups, n_loc_ri, n_local_grid, n_procs_per_atom, natom, nkind, num_grid_chunks, & + P_loop_atom, r_end, r_start, source_atom INTEGER, ALLOCATABLE, DIMENSION(:) :: local_grid_idx, row_offset - INTEGER, DIMENSION(:), POINTER :: col_dist_ri, r_blk_sizes, ri_blk_sizes, & - row_dist_grid + INTEGER, DIMENSION(:), POINTER :: col_dist_phi, col_dist_ri, r_blk_sizes, & + ri_blk_sizes, row_dist_grid REAL(KIND=dp) :: cutoff_ri, cutoff_ri_2, d_sP, dist2_min, & r2_threshold, r_c, t1, t2, t3 REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cutoff_ri_per_atom, cutoff_ri_per_kind, & @@ -573,8 +558,7 @@ CONTAINS ! 1. SETUP DBCSR TOPOLOGY & EXACT OFFSETS ! ========================================================================= CALL dbcsr_get_info(mat_phi_mu_l, row_blk_size=r_blk_sizes, distribution=dist_phi) - CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, & - group=group_handle, npcols=npcol_phi) + CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, col_dist=col_dist_phi, group=group_handle) num_grid_chunks = SIZE(r_blk_sizes) @@ -587,7 +571,7 @@ CONTAINS ALLOCATE (ri_blk_sizes(natom), col_dist_ri(natom)) DO atom_P = 1, natom ri_blk_sizes(atom_P) = bs_env%i_RI_end_from_atom(atom_P) - bs_env%i_RI_start_from_atom(atom_P) + 1 - col_dist_ri(atom_P) = MOD(atom_P - 1, npcol_phi) + col_dist_ri(atom_P) = MOD(atom_P - 1, MAXVAL(col_dist_phi) + 1) END DO CALL dbcsr_distribution_new(dist_Z, template=dist_phi, row_dist=row_dist_grid, col_dist=col_dist_ri) @@ -756,10 +740,8 @@ CONTAINS ALLOCATE (D_local(n_local_grid, n_local_grid)) D_local = 0.0_dp - CALL timeset(routineN//"_dsyrk", handle_dsyrk) CALL dsyrk("L", "N", n_local_grid, n_ao_total, 1.0_dp, phi_local, & n_local_grid, 0.0_dp, D_local, n_local_grid) - CALL timestop(handle_dsyrk) !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(n_local_grid, D_local, d_vec_local, bs_env) & @@ -820,13 +802,9 @@ CONTAINS ! F. Solve — BLAS dpotrf/dpotrs or ScaLAPACK pdpotrf/pdpotrs ! --------------------------------------------------------------------- IF (n_procs_per_atom == 1) THEN - CALL timeset(routineN//"_dpotrf", handle_dpotrf) CALL dpotrf('L', n_local_grid, D_local, n_local_grid, info) - CALL timestop(handle_dpotrf) - CALL timeset(routineN//"_dpotrs", handle_dpotrs) CALL dpotrs('L', n_local_grid, n_loc_ri, D_local, n_local_grid, & d_lp_local, n_local_grid, info) - CALL timestop(handle_dpotrs) DEALLOCATE (D_local) ELSE CALL solve_D_lp_distributed(phi_local, d_vec_local, d_lp_local, & @@ -961,12 +939,12 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_d_lp' INTEGER, PARAMETER :: grid_chunk = 1024 - INTEGER :: atom_j, atom_k, c, handle, handle_dgemm, ix_max, ix_min, ix_R, ix_S, iy_max, & - iy_min, iy_R, iy_S, iz_max, iz_min, iz_R, iz_S, j, jk_idx, jsize, jstart, k, ksize, & - kstart, l, l0, natom, ri + INTEGER :: atom_j, atom_k, c, handle, ix_max, ix_min, ix_R, ix_S, iy_max, iy_min, iy_R, & + iy_S, iz_max, iz_min, iz_R, iz_S, j, jk_idx, jsize, jstart, k, ksize, kstart, l, l0, & + natom, ri INTEGER, DIMENSION(3) :: cell_R_vec, cell_S_vec LOGICAL :: any_kept, screened - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: d_lp_prv, int_2d_prv, rho_chunk + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: int_2d_prv, rho_chunk REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: int_3c_prv, int_3c_sum TYPE(gw_3c_ws_type) :: ws @@ -974,28 +952,23 @@ CONTAINS natom = SIZE(bs_env%i_ao_start_from_atom) - IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0 - END IF - IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0 - END IF - IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0 - END IF + IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0; END IF + IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0; END IF + IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0; END IF !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, max_ao_size, & !$OMP natom, ix_min, ix_max, iy_min, iy_max, iz_min, iz_max, & !$OMP atom_j_mepos, atom_j_stride) & - !$OMP PRIVATE(any_kept, atom_j, atom_k, c, handle_dgemm, j, jk_idx, jsize, jstart, k, & - !$OMP ksize, kstart, l, l0, ri, ix_R, iy_R, iz_R, ix_S, iy_S, iz_S, cell_R_vec, & - !$OMP cell_S_vec, screened, d_lp_prv, int_2d_prv, rho_chunk, int_3c_prv, int_3c_sum, ws) + !$OMP PRIVATE(any_kept, atom_j, atom_k, c, j, jk_idx, jsize, jstart, k, ksize, kstart, l, & + !$OMP l0, ri, ix_R, iy_R, iz_R, ix_S, iy_S, iz_S, cell_R_vec, cell_S_vec, & + !$OMP screened, int_2d_prv, rho_chunk, int_3c_prv, int_3c_sum, ws) CALL gw_3c_ws_create(ws, ctx) ALLOCATE (int_3c_prv(max_ao_size, max_ao_size, n_loc_ri)) ALLOCATE (int_3c_sum(max_ao_size, max_ao_size, n_loc_ri)) ALLOCATE (int_2d_prv(max_ao_size*max_ao_size, n_loc_ri)) ALLOCATE (rho_chunk(grid_chunk, max_ao_size*max_ao_size)) - ALLOCATE (d_lp_prv(n_grid_total, n_loc_ri)) - d_lp_prv(:, :) = 0.0_dp ! atom_P pinned at cell (0,0,0); enumerate (atom_j, cell_R) × (atom_k, cell_S). The ctx ! integral builder's kind_radius triangle screen sets screened=.TRUE. for the bulk of @@ -1004,7 +977,7 @@ CONTAINS ! MPI-stride atom_j over the subgroup (atom_j_stride = 1 for the BLAS path, > 1 for the ! ScaLAPACK path). COLLAPSE(2) dropped because the outer stride is non-unit under ! ScaLAPACK; the inner atom_k loop carries enough work for DYNAMIC. - !$OMP DO SCHEDULE(DYNAMIC) + !$OMP DO SCHEDULE(DYNAMIC) REDUCTION(+:d_lp) DO atom_j = atom_j_mepos + 1, natom, atom_j_stride DO atom_k = 1, natom jstart = bs_env%i_ao_start_from_atom(atom_j) @@ -1069,23 +1042,16 @@ CONTAINS END DO END DO END DO - CALL timeset(routineN//"_dgemm", handle_dgemm) CALL dgemm("N", "N", c, n_loc_ri, jsize*ksize, & 1.0_dp, rho_chunk, grid_chunk, & int_2d_prv, max_ao_size*max_ao_size, & - 1.0_dp, d_lp_prv(l0, 1), n_grid_total) - CALL timestop(handle_dgemm) + 1.0_dp, d_lp(l0, 1), n_grid_total) END DO END DO END DO !$OMP END DO - !$OMP CRITICAL (compute_d_lp_reduce) - d_lp(1:n_grid_total, 1:n_loc_ri) = d_lp(1:n_grid_total, 1:n_loc_ri) + & - d_lp_prv(1:n_grid_total, 1:n_loc_ri) - !$OMP END CRITICAL (compute_d_lp_reduce) - - DEALLOCATE (int_3c_prv, int_3c_sum, int_2d_prv, rho_chunk, d_lp_prv) + DEALLOCATE (int_3c_prv, int_3c_sum, int_2d_prv, rho_chunk) CALL gw_3c_ws_release(ws) !$OMP END PARALLEL @@ -1111,8 +1077,8 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'get_mat_chi_Gamma_tau' INTEGER :: handle, i, i_t, ispin, npcol - INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_grid, & - dist_row_grid + INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_ao, & + dist_col_grid, dist_row_grid REAL(KIND=dp) :: t1, tau TYPE(dbcsr_distribution_type) :: dist_grid_grid, dist_phi TYPE(dbcsr_type) :: matrix_chi_grid, matrix_chi_grid_spin, & @@ -1124,7 +1090,10 @@ CONTAINS ! 1. SETUP CORE TOPOLOGIES ! ========================================================================= CALL dbcsr_get_info(mat_phi_mu_l, distribution=dist_phi, row_blk_size=blk_grid, col_blk_size=blk_ao) - CALL dbcsr_distribution_get(dist_phi, row_dist=dist_row_grid, npcols=npcol) + CALL dbcsr_distribution_get(dist_phi, row_dist=dist_row_grid, col_dist=dist_col_ao) + + ! Determine number of MPI process columns + npcol = MAXVAL(dist_col_ao) + 1 ! Build a perfectly safe column distribution for the Grid dimension ALLOCATE (dist_col_grid(SIZE(blk_grid))) @@ -1362,46 +1331,6 @@ CONTAINS END SUBROUTINE hadamard_product -! ************************************************************************************************** -!> \brief In-place Hadamard A <- fac * (A ◦ B). Value mutation only (no block insert/delete), -!> so iterating A while writing through the block pointer is safe. -!> \param matrix_A in/out factor (overwritten by the product) -!> \param matrix_B second factor (looked up; blocks absent in B zero the A block) -!> \param fac (Scaling factor applied to the product) -! ************************************************************************************************** - SUBROUTINE hadamard_product_inplace(matrix_A, matrix_B, fac) - - TYPE(dbcsr_type), INTENT(INOUT) :: matrix_A, matrix_B - REAL(KIND=dp), INTENT(IN) :: fac - - CHARACTER(LEN=*), PARAMETER :: routineN = 'hadamard_product_inplace' - - INTEGER :: col, handle, row - LOGICAL :: found - REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk_A, blk_B - TYPE(dbcsr_iterator_type) :: iter - - CALL timeset(routineN, handle) - - CALL dbcsr_iterator_start(iter, matrix_A) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, row, col, blk_A) - - CALL dbcsr_get_block_p(matrix_B, row, col, blk_B, found) - - IF (found) THEN - blk_A(:, :) = fac*blk_A(:, :)*blk_B(:, :) - ELSE - ! If B is sparse here, the product is zero - blk_A(:, :) = 0.0_dp - END IF - END DO - CALL dbcsr_iterator_stop(iter) - - CALL timestop(handle) - - END SUBROUTINE hadamard_product_inplace - ! ************************************************************************************************** !> \brief Compute screened Coulomb interaction matrix !> \param bs_env ... @@ -2027,23 +1956,18 @@ CONTAINS TYPE(dbcsr_distribution_type), INTENT(OUT) :: square_dist INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: blk_sizes, mapped_dist - CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_square_topology' - - INTEGER :: handle, i, np, npcols, nprows + INTEGER :: i, np INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist, row_blk, row_dist TYPE(dbcsr_distribution_type) :: dist_template - CALL timeset(routineN, handle) - CALL dbcsr_get_info(matrix_template, distribution=dist_template, & row_blk_size=row_blk, col_blk_size=col_blk) - CALL dbcsr_distribution_get(dist_template, row_dist=row_dist, col_dist=col_dist, & - nprows=nprows, npcols=npcols) + CALL dbcsr_distribution_get(dist_template, row_dist=row_dist, col_dist=col_dist) IF (TRIM(dim_type) == 'ROW') THEN ! Creates ROW x ROW (e.g., Grid x Grid from mat_phi_mu_l) blk_sizes => row_blk - np = npcols + np = MAXVAL(col_dist) + 1 ! npcol ALLOCATE (mapped_dist(SIZE(blk_sizes))) DO i = 1, SIZE(blk_sizes) mapped_dist(i) = MOD(i - 1, np) @@ -2054,7 +1978,7 @@ CONTAINS ELSE IF (TRIM(dim_type) == 'COL') THEN ! Creates COL x COL (e.g., Aux x Aux from mat_Z_lP) blk_sizes => col_blk - np = nprows + np = MAXVAL(row_dist) + 1 ! nprow ALLOCATE (mapped_dist(SIZE(blk_sizes))) DO i = 1, SIZE(blk_sizes) mapped_dist(i) = MOD(i - 1, np) @@ -2063,8 +1987,6 @@ CONTAINS row_dist=mapped_dist, col_dist=col_dist) END IF - CALL timestop(handle) - END SUBROUTINE setup_square_topology ! ************************************************************************************************** @@ -2085,12 +2007,6 @@ CONTAINS POINTER :: mapped_dist TYPE(dbcsr_type), INTENT(INOUT), OPTIONAL :: m1, m2, m3, m4 - CHARACTER(LEN=*), PARAMETER :: routineN = 'release_dbcsr_topology_and_matrices' - - INTEGER :: handle - - CALL timeset(routineN, handle) - IF (PRESENT(dist)) CALL dbcsr_distribution_release(dist) IF (PRESENT(mapped_dist)) THEN IF (ASSOCIATED(mapped_dist)) THEN @@ -2103,8 +2019,6 @@ CONTAINS IF (PRESENT(m3)) CALL dbcsr_release(m3) IF (PRESENT(m4)) CALL dbcsr_release(m4) - CALL timestop(handle) - END SUBROUTINE release_dbcsr_topology_and_matrices END MODULE gw_large_cell_Gamma_ri_rs diff --git a/src/gw_non_periodic_ri_rs.F b/src/gw_non_periodic_ri_rs.F index 915b654f4e..7c0cea6568 100644 --- a/src/gw_non_periodic_ri_rs.F +++ b/src/gw_non_periodic_ri_rs.F @@ -10,88 +10,82 @@ !> \par History !> 04.2026 created [Ritaj Tyagi] ! ************************************************************************************************** - MODULE gw_non_periodic_ri_rs - USE atomic_kind_types, ONLY: atomic_kind_type, & - get_atomic_kind_set - USE basis_set_types, ONLY: gto_basis_set_type - USE cell_types, ONLY: cell_type, & - pbc - USE constants_operator, ONLY: operator_coulomb - USE cp_blacs_env, ONLY: cp_blacs_env_create, & - cp_blacs_env_release, & - cp_blacs_env_type - USE cp_dbcsr_api, ONLY: & - dbcsr_add, dbcsr_binary_read, dbcsr_binary_write, dbcsr_copy, dbcsr_create, & - dbcsr_deallocate_matrix, dbcsr_distribution_get, dbcsr_distribution_new, & - dbcsr_distribution_release, dbcsr_distribution_type, dbcsr_finalize, & - dbcsr_get_block_p, dbcsr_filter, dbcsr_get_data_size, dbcsr_get_info, & - dbcsr_get_occupation, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & - dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, & - dbcsr_p_type, dbcsr_put_block, dbcsr_release, dbcsr_scale, dbcsr_set, dbcsr_type, & - dbcsr_type_no_symmetry - USE cp_dbcsr_contrib, ONLY: dbcsr_reserve_all_blocks - USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm, & - copy_fm_to_dbcsr, & - dbcsr_deallocate_matrix_set, & - max_elements_per_block - USE cp_files, ONLY: close_file, & - open_file - USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add, & - cp_fm_uplo_to_full - USE cp_fm_cholesky, ONLY: cp_fm_cholesky_decompose, & - cp_fm_cholesky_invert, & - cp_fm_cholesky_solve - USE cp_fm_diag, ONLY: cp_fm_power - USE cp_fm_struct, ONLY: cp_fm_struct_create, & - cp_fm_struct_release, & - cp_fm_struct_type - USE cp_fm_types, ONLY: cp_fm_create, & - cp_fm_get_info, & - cp_fm_get_submatrix, & - cp_fm_release, & - cp_fm_set_all, & - cp_fm_set_submatrix, & - cp_fm_to_fm, & - cp_fm_type - USE cp_log_handling, ONLY: cp_get_default_logger, & - cp_logger_type - USE cp_output_handling, ONLY: cp_p_file, & - cp_print_key_should_output - USE gw_integrals, ONLY: build_3c_integral_block_ctx, & - gw_3c_ctx_create, & - gw_3c_ctx_release, & - gw_3c_ctx_type, & - gw_3c_ws_create, & - gw_3c_ws_release, & - gw_3c_ws_type - USE gw_large_cell_gamma, ONLY: & - Fourier_transform_w_to_t, G_occ_vir, compute_QP_energies, compute_fm_chi_Gamma_freq, & - create_fm_W_MIC_time, delete_unnecessary_files, fill_fm_Sigma_c_Gamma_time, fm_write, & - multiply_fm_W_MIC_time_with_Minv_Gamma - USE gw_utils, ONLY: de_init_bs_env - USE input_constants, ONLY: rtp_method_bse - USE input_section_types, ONLY: section_vals_type - USE kinds, ONLY: default_path_length, & - default_string_length, & - dp, int_4, int_8 - USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp - USE machine, ONLY: m_flush, m_hostnm, & - m_memory_details, m_walltime - USE message_passing, ONLY: mp_para_env_type - USE mp2_ri_2c, ONLY: RI_2c_integral_mat - USE orbital_pointers, ONLY: indco, & - ncoset - USE parallel_gemm_api, ONLY: parallel_gemm - USE particle_types, ONLY: particle_type - USE physcon, ONLY: angstrom - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type - USE qs_environment_types, ONLY: get_qs_env, & - qs_environment_type - USE qs_kind_types, ONLY: get_qs_kind, & - qs_kind_type - USE util, ONLY: sort - + USE atomic_kind_types, ONLY: atomic_kind_type,& + get_atomic_kind_set + USE basis_set_types, ONLY: gto_basis_set_type + USE cell_types, ONLY: cell_type,& + pbc + USE constants_operator, ONLY: operator_coulomb + USE cp_blacs_env, ONLY: cp_blacs_env_create,& + cp_blacs_env_release,& + cp_blacs_env_type + USE cp_dbcsr_api, ONLY: & + dbcsr_add, dbcsr_binary_read, dbcsr_binary_write, dbcsr_copy, dbcsr_create, & + dbcsr_deallocate_matrix, dbcsr_distribution_get, dbcsr_distribution_new, & + dbcsr_distribution_release, dbcsr_distribution_type, dbcsr_finalize, dbcsr_get_block_p, & + dbcsr_get_info, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & + dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, & + dbcsr_p_type, dbcsr_put_block, dbcsr_release, dbcsr_scale, dbcsr_set, dbcsr_type, & + dbcsr_type_no_symmetry + USE cp_dbcsr_contrib, ONLY: dbcsr_reserve_all_blocks + USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& + copy_fm_to_dbcsr,& + dbcsr_deallocate_matrix_set,& + max_elements_per_block + USE cp_files, ONLY: close_file,& + open_file + USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add,& + cp_fm_uplo_to_full + USE cp_fm_cholesky, ONLY: cp_fm_cholesky_decompose,& + cp_fm_cholesky_invert,& + cp_fm_cholesky_solve + USE cp_fm_diag, ONLY: cp_fm_power + USE cp_fm_struct, ONLY: cp_fm_struct_create,& + cp_fm_struct_release,& + cp_fm_struct_type + USE cp_fm_types, ONLY: cp_fm_create,& + cp_fm_get_info,& + cp_fm_get_submatrix,& + cp_fm_release,& + cp_fm_set_all,& + cp_fm_set_submatrix,& + cp_fm_to_fm,& + cp_fm_type + USE cp_log_handling, ONLY: cp_get_default_logger,& + cp_logger_type + USE cp_output_handling, ONLY: cp_p_file,& + cp_print_key_should_output + USE gw_integrals, ONLY: build_3c_integral_block_ctx,& + gw_3c_ctx_create,& + gw_3c_ctx_release,& + gw_3c_ctx_type,& + gw_3c_ws_create,& + gw_3c_ws_release,& + gw_3c_ws_type + USE gw_large_cell_gamma, ONLY: & + Fourier_transform_w_to_t, G_occ_vir, compute_QP_energies, compute_fm_chi_Gamma_freq, & + create_fm_W_MIC_time, delete_unnecessary_files, fill_fm_Sigma_c_Gamma_time, fm_write, & + multiply_fm_W_MIC_time_with_Minv_Gamma + USE gw_utils, ONLY: de_init_bs_env + USE input_constants, ONLY: rtp_method_bse + USE input_section_types, ONLY: section_vals_type + USE kinds, ONLY: default_path_length,& + default_string_length,& + dp + USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp + USE machine, ONLY: m_walltime + USE message_passing, ONLY: mp_para_env_type + USE mp2_ri_2c, ONLY: RI_2c_integral_mat + USE orbital_pointers, ONLY: indco,& + ncoset + USE parallel_gemm_api, ONLY: parallel_gemm + USE particle_types, ONLY: particle_type + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type + USE qs_kind_types, ONLY: get_qs_kind,& + qs_kind_type #include "./base/base_uses.f90" IMPLICIT NONE @@ -100,17 +94,8 @@ MODULE gw_non_periodic_ri_rs CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_non_periodic_ri_rs' - ! DBCSR ships each ranks matrix panel in one MPI message whose length is stored in a - ! 32-bit default INTEGER (dbcsr_mpiwrap.F: msglen = SIZE(buffer)). Exceeding this ceiling - ! overflows the count to a negative/garbage value and multiply_cannon segfaults. This is - ! that hard limit in elements (= HUGE(int_4) = 2^31-1), the same bound DBCSR uses - ! internally as mp_max_memory_size. Panel sizing keeps every per-rank message below it. - - INTEGER(KIND=int_8), PARAMETER, PRIVATE :: dbcsr_msg_elem_limit = INT(HUGE(0_int_4), int_8) - PUBLIC :: gw_calc_non_periodic_ri_rs, ri_rs_grid_assembler, & - get_basis_offsets, precompute_ri_rs_radii, solve_D_lp_distributed, & - atomic_basis_at_grid_point, compute_coeff_Z_lP + get_basis_offsets, precompute_ri_rs_radii, solve_D_lp_distributed CONTAINS @@ -119,6 +104,7 @@ CONTAINS !> \param qs_env ... !> \param bs_env ... ! ************************************************************************************************** + SUBROUTINE gw_calc_non_periodic_ri_rs(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env @@ -132,97 +118,97 @@ CONTAINS CALL timeset(routineN, handle) - ! ======================================================================== - ! 0. Precompute AO and RI radii - ! Per-atom cutoff radii from the most diffuse Gaussian primitives of - ! the AO ("ORB") and RI auxiliary ("RI_AUX") basis sets: - ! α_min,ao = min { ζ_ao | ζ_ao > 10⁻³ }, α_min,ri analogous - ! r_ao = sqrt( -ln(ε) / α_min,ao ) (radius_ao_per_atom) - ! r_ri = sqrt( -ln(ε) / α_min,ri ) (radius_ri_per_atom) - ! ======================================================================== + !!======================================================================== + !! 0. Precompute AO and RI Radii + !! Determine per-atom cutoff radii from the most diffuse Gaussian + !! primitives in the AO and RI auxiliary basis sets. + !! Equations: + !! a. α_min,ao = min_{i,j} { ζ_ao(i,j) | ζ_ao(i,j) > 10⁻³ } + !! b. α_min,ri = min_{i,j} { ζ_ri(i,j) | ζ_ri(i,j) > 10⁻³ } + !! c. r_ao = sqrt( -ln(ε) / α_min,ao ) (radius_ao_per_atom) + !! d. r_ri = sqrt( -ln(ε) / α_min,ri ) (radius_ri_per_atom) + !!======================================================================== CALL precompute_ri_rs_radii(qs_env, bs_env) - ! ======================================================================== - ! 1. Grid generation for RI-RS - ! Modified Lebedev atomic grids (Duchemin & Blase), one per atom, - ! concatenated into a flat global list: r_l = R_A + r_l^(A) - ! ======================================================================== + !!======================================================================== + !! 1. Grid Generation for RI-RS + !! (Modified Lebedev grids from Ivan Duchemin and Xavier Blase) + !! Generate flattened 1D array of grid points for RI-RS. + !! Equation: r_g(k) = R_A + r_g(A) + !!======================================================================== CALL ri_rs_grid_assembler(qs_env, bs_env, bs_env%ri_rs%grid_points) - ! ======================================================================== - ! 2a. Atomic basis evaluation on the grid (grid x AO matrix) - ! Φ_μl = Φ_μ(r_l) (mat_phi_mu_l) - ! ======================================================================== + !!======================================================================== + !! 2. Atomic Basis Evaluation + !! Compute values of spherical atomic basis functions at grid points. + !! Expression: Φ_μl = Φ_μ(r_l) (mat_phi_mu_l) + !!======================================================================== CALL atomic_basis_at_grid_point(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l) - ! ======================================================================== - ! 2b. Print the memory estimate for the RI-RS calculation - ! ======================================================================== - CALL print_ri_rs_memory_estimate(qs_env, bs_env) - - ! ======================================================================== - ! 3. RI-RS fitting coefficients Z_lP (grid x RI matrix) - ! Per-atom regularized solve, restricted to grid points r_l within a - ! cutoff distance of atom P: - ! a. D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]² - ! b. D_lP = Σ_μν Φ_μ(r_l) Φ_ν(r_l) (μν|P) - ! c. Jacobi conditioning with d_l = 1/sqrt(D_ll): - ! D'_ll' = d_l D_ll' d_l' + λδ_ll' , D'_lP = d_l D_lP - ! d. Solve Σ_l' D'_ll' Z'_l'P = D'_lP - ! e. Rescale Z_lP = d_l Z'_lP (mat_Z_lP) - ! ======================================================================== + !!======================================================================== + !! 3. Compute RI-RS Coefficients (Z_lp) + !! Solve the regularized system for each atom P, where the grid domain + !! is restricted to r_l within a cutoff distance of atom P: + !! a. D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]^2 (Equation 13) + !! b. D_lP = Σ_{μν} Φ_μ(r_l) Φ_ν(r_l) (μν|P) (Equation 15) + !! c. Conditioning: + !! Dvec_l = 1 / sqrt(D_ll) (Diagonal scaling vector) + !! D'_ll' = Dvec_l * D_ll' * Dvec_l' + λδ_ll' + !! D'_lP = Dvec_l * D_lP + !! d. Solve: Σ_l' D'_ll' * Z'_l'P = D'_lP (Equation 14) + !! e. Rescale: Z_lP = Z'_lP * Dvec_l (Z_lP stored in mat_Z_lP) + !!======================================================================== CALL compute_coeff_Z_lP(qs_env, bs_env, bs_env%ri_rs%grid_points, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) - ! flag the RI-RS grid as built so a subsequent RT-BSE run reuses Z_lP instead of rebuilding it - bs_env%ri_rs%grid_built = .TRUE. - ! ======================================================================== - ! 4. Polarizability matrix χ on the imaginary-time grid - ! G^occ_µλ(i|τ|) = Σ_n^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - ! G^vir_µλ(i|τ|) = Σ_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn - ! G^occ_ll'(i|τ|) = Σ_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') (G^vir analogous) - ! χ_ll'(iτ) = G^occ_ll'(i|τ|) ∘ G^vir_ll'(i|τ|) (element-wise) - ! χ_PQ(iτ) = Σ_ll' Z_lP χ_ll'(iτ) Z_l'Q - ! ======================================================================== + !!======================================================================== + !! 4. Compute Independent-Particle Polarizability (χ) + !! G^occ_µλ(i|τ|) = sum_n^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + !! G^vir_µλ(i|τ|) = sum_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + !! G^occ_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') + !! G^vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^vir_µν Φ_ν(r_l') + !! χ_ll'(iτ) = G^occ_ll'(i|τ|) * G^vir_ll'(i|τ|) + !! χ_PQ(iτ) = sum_ll' Z_lP χ_ll'(iτ) Z_l'Q + !!======================================================================== CALL get_mat_chi_Gamma_tau(bs_env, bs_env%mat_chi_Gamma_tau, & bs_env%ri_rs%mat_phi_mu_l, bs_env%ri_rs%mat_Z_lP) - ! ======================================================================== - ! 5. Screened Coulomb interaction W (RI basis) - ! χ_PQ(iτ) -> χ_PQ(iω) -> ε_PQ(iω) -> W_PQ(iω) -> W_PQ(iτ) - ! ======================================================================== + !!======================================================================== + !! 5. Compute Screened Interaction (W) + !! χ_PQ(iτ) -> χ_PQ(iω) -> ε_PQ(iω) -> W_PQ(iω) -> W_PQ(iτ) + !!======================================================================== CALL compute_W(bs_env, qs_env, bs_env%mat_chi_Gamma_tau, fm_W_time) - ! ======================================================================== - ! 6. Exact-exchange self-energy Σ^x - ! D_µν = Σ_n^occ C_µn C_νn (density matrix) - ! D_ll' = Σ_µν Φ_µ(r_l) D_µν Φ_ν(r_l') - ! V^tr_ll' = Σ_PQ Z_lP V^tr_PQ Z_l'Q (truncated Coulomb) - ! Σ^x_ll' = D_ll' ∘ V^tr_ll' - ! Σ^x_λσ(k=0) = -Σ_ll' Φ_λ(r_l) Σ^x_ll' Φ_σ(r_l') - ! ======================================================================== + !!======================================================================== + !! 6. Compute Exact Exchange Self-Energy (Σ^x) + !! D_µν = sum_n^occ C_µn C_νn + !! D_ll' = sum_µν Φ_µ(r_l) D_µν Φ_ν(r_l') + !! V^trunc_ll' = sum_PQ Z_lP V^trunc_PQ Z_l'Q + !! Σ^x_ll' = D_ll' * V^trunc_ll' + !! Σ^x_λσ(k=0) = -sum_ll' Φ_λ(r_l) Σ^x_ll' Φ_σ(r_l') + !!======================================================================== CALL compute_Sigma_x(bs_env, qs_env, bs_env%ri_rs%mat_phi_mu_l, & bs_env%ri_rs%mat_Z_lP, fm_Sigma_x_Gamma) - ! ======================================================================== - ! 7. Correlation self-energy Σ^c on the imaginary-time grid - ! W_ll'(iτ) = Σ_PQ Z_lP W^MIC_PQ(iτ) Z_l'Q - ! Σ^c_ll'(iτ) = -G^occ_ll'(i|τ|) ∘ W_ll'(iτ), τ < 0 - ! Σ^c_ll'(iτ) = G^vir_ll'(i|τ|) ∘ W_ll'(iτ), τ > 0 - ! Σ^c_λσ(iτ) = Σ_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l') - ! ======================================================================== + !!======================================================================== + !! 7. Compute Correlation Self-Energy (Σ^c) + !! W_ll'(iτ) = sum_PQ Z_lP W^MIC_PQ(iτ) Z_l'Q + !! Σ^c_ll'(iτ) = -G^occ_ll'(i|τ|) * W_ll'(iτ), for τ < 0 + !! Σ^c_ll'(iτ) = G^vir_ll'(i|τ|) * W_ll'(iτ), for τ > 0 + !! Σ^c_λσ(iτ) = sum_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l') + !!======================================================================== CALL compute_Sigma_c(bs_env, fm_W_time, bs_env%ri_rs%mat_phi_mu_l, & bs_env%ri_rs%mat_Z_lP, fm_Sigma_c_Gamma_time) - ! ======================================================================== - ! 8. Quasiparticle energies (analytic continuation iτ -> iω -> real ϵ) - ! Σ^c_λσ(iτ) -> Σ^c_nn(ϵ) - ! ϵ_n^GW = ϵ_n^DFT + Σ^c_nn(ϵ_n^GW) + Σ^x_nn - v^xc_nn - ! ======================================================================== + !!======================================================================== + !! 8. Compute Quasiparticle Energies + !! Σ^c_λσ(iτ) -> Σ^c_nn(ϵ) + !! ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ) + Σ^x_nn - v^xc_nn + !!======================================================================== CALL compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamma_time) - CALL de_init_bs_env(qs_env, bs_env) + CALL de_init_bs_env(bs_env) CALL timestop(handle) @@ -238,6 +224,7 @@ CONTAINS !> \param qs_env ... !> \param bs_env ... ! ************************************************************************************************** + SUBROUTINE precompute_ri_rs_radii(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env @@ -271,16 +258,14 @@ CONTAINS DO i = 1, SIZE(zet_ao, 1) DO j = 1, SIZE(zet_ao, 2) - IF (zet_ao(i, j) > 1.0E-3_dp) then + IF (zet_ao(i, j) > 1.0E-3_dp) & alpha_min_ao_kind(ikind) = MIN(alpha_min_ao_kind(ikind), zet_ao(i, j)) - END IF END DO END DO DO i = 1, SIZE(zet_ri, 1) DO j = 1, SIZE(zet_ri, 2) - IF (zet_ri(i, j) > 1.0E-3_dp) then + IF (zet_ri(i, j) > 1.0E-3_dp) & alpha_min_ri_kind(ikind) = MIN(alpha_min_ri_kind(ikind), zet_ri(i, j)) - END IF END DO END DO END DO @@ -296,14 +281,14 @@ CONTAINS END DO IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind RI-RS basis radii (Å):' - WRITE (bs_env%unit_nr, '(T4,A6,2X,A4,2A14)') 'Kind', 'Elem', 'r_AO (Å)', 'r_RI (Å)' + WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind RI-RS basis radii (Bohr):' + WRITE (bs_env%unit_nr, '(T4,A6,2X,A4,2A14)') 'Kind', 'Elem', 'r_AO', 'r_RI' DO ikind = 1, nkind WRITE (bs_env%unit_nr, '(T4,I6,2X,A4,2F14.4)') & ikind, & atomic_kind_set(ikind)%element_symbol, & - SQRT(-LOG(eps)/alpha_min_ao_kind(ikind))*angstrom, & - SQRT(-LOG(eps)/alpha_min_ri_kind(ikind))*angstrom + SQRT(-LOG(eps)/alpha_min_ao_kind(ikind)), & + SQRT(-LOG(eps)/alpha_min_ri_kind(ikind)) END DO WRITE (bs_env%unit_nr, '(A)') ' ' END IF @@ -314,86 +299,6 @@ CONTAINS END SUBROUTINE precompute_ri_rs_radii -! ************************************************************************************************** -!> \brief Spreads the low 21 bits of a into every third bit (bits 0,3,6,...,60): the 1-D helper -!> for a 3-D Morton (Z-order) code. Standard 64-bit magic-mask implementation. -!> \param a value in [0, 2^21) -!> \param x a with two zero bits inserted between consecutive input bits -! ************************************************************************************************** - SUBROUTINE morton_split3(a, x) - INTEGER(KIND=int_8), INTENT(IN) :: a - INTEGER(KIND=int_8), INTENT(OUT) :: x - - x = IAND(a, INT(z'1FFFFF', int_8)) - x = IAND(IOR(x, ISHFT(x, 32)), INT(z'1F00000000FFFF', int_8)) - x = IAND(IOR(x, ISHFT(x, 16)), INT(z'1F0000FF0000FF', int_8)) - x = IAND(IOR(x, ISHFT(x, 8)), INT(z'100F00F00F00F00F', int_8)) - x = IAND(IOR(x, ISHFT(x, 4)), INT(z'10C30C30C30C30C3', int_8)) - x = IAND(IOR(x, ISHFT(x, 2)), INT(z'1249249249249249', int_8)) - END SUBROUTINE morton_split3 - -! ************************************************************************************************** -!> \brief Returns a permutation of atom indices in Morton (Z-order) space-filling order of their -!> Cartesian centers, so consecutive atoms are spatial neighbors. The RI-RS grid rows are -!> laid down in this order, so a contiguous grid panel maps to a compact spatial region and -!> the CUTOFF_RADIUS_RL_W neighborhood of every panel shrinks. The grid row index -!> is a summed contraction index, so ANY permutation is result-preserving; this one is -!> chosen purely to improve locality. Coordinates are normalized to the atom bounding box -!> and quantized to 21 bits per axis (sub-picometre for any real cell). -!> \param particle_set ... -!> \param order order(i) = atom index placed at layout position i -! ************************************************************************************************** - SUBROUTINE spatial_atom_order(particle_set, order) - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: order - - CHARACTER(LEN=*), PARAMETER :: routineN = 'spatial_atom_order' - INTEGER, PARAMETER :: nbits = 21 - - INTEGER :: handle, ia, k, natom - INTEGER(KIND=int_8) :: cmax, ic(3), m1, m2, m3 - INTEGER(KIND=int_8), ALLOCATABLE :: mcode(:) - REAL(KIND=dp) :: hi(3), lo(3), span(3) - - CALL timeset(routineN, handle) - - natom = SIZE(particle_set) - ALLOCATE (order(natom), mcode(natom)) - cmax = ISHFT(1_int_8, nbits) - 1_int_8 - - lo(:) = HUGE(1.0_dp) - hi(:) = -HUGE(1.0_dp) - DO ia = 1, natom - DO k = 1, 3 - lo(k) = MIN(lo(k), particle_set(ia)%r(k)) - hi(k) = MAX(hi(k), particle_set(ia)%r(k)) - END DO - END DO - span(:) = hi(:) - lo(:) - DO k = 1, 3 - IF (span(k) <= 0.0_dp) span(k) = 1.0_dp - END DO - - DO ia = 1, natom - DO k = 1, 3 - ic(k) = INT(((particle_set(ia)%r(k) - lo(k))/span(k))*REAL(cmax, dp), int_8) - ic(k) = MIN(cmax, MAX(0_int_8, ic(k))) - END DO - CALL morton_split3(ic(1), m1) - CALL morton_split3(ic(2), m2) - CALL morton_split3(ic(3), m3) - mcode(ia) = IOR(IOR(m1, ISHFT(m2, 1)), ISHFT(m3, 2)) - END DO - - ! sort(mcode, natom, order): order(i) = original atom index with the i-th smallest code - CALL sort(mcode, natom, order) - - DEALLOCATE (mcode) - - CALL timestop(handle) - - END SUBROUTINE spatial_atom_order - ! ************************************************************************************************** !> \brief Compute grid points for RI-RS !> Right now based on Ivan and Xavier implementation @@ -402,6 +307,7 @@ CONTAINS !> \param bs_env ... !> \param ri_rs_grid_points ... ! ************************************************************************************************** + SUBROUTINE ri_rs_grid_assembler(qs_env, bs_env, ri_rs_grid_points) TYPE(qs_environment_type), POINTER :: qs_env @@ -410,11 +316,10 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'ri_rs_grid_assembler' - INTEGER :: atom_idx, end_idx, handle, i_layout, & - ikind, j, natom, nkind, start_idx, & + INTEGER :: atom_idx, end_idx, handle, ikind, j, & + natom, nkind, start_idx, & total_grid_npts - INTEGER, ALLOCATABLE :: atom_order(:), atom_to_kind(:), & - ri_rs_grid_offsets(:) + INTEGER, ALLOCATABLE :: atom_to_kind(:), ri_rs_grid_offsets(:) REAL(KIND=dp) :: atomic_center(3) TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(particle_type), DIMENSION(:), POINTER :: particle_set @@ -434,37 +339,17 @@ CONTAINS ALLOCATE (ri_rs_grid_offsets(natom + 1)) ALLOCATE (atom_to_kind(natom)) - ! grid_atom_boundaries(k) = 1-based start of the k-th atom's grid run in LAYOUT order - ! (the order in which the points are laid down below). Used later to build atom-aligned - ! DBCSR grid row-blocks in atomic_basis_at_grid_point. - IF (ALLOCATED(bs_env%ri_rs%grid_atom_boundaries)) DEALLOCATE (bs_env%ri_rs%grid_atom_boundaries) - ALLOCATE (bs_env%ri_rs%grid_atom_boundaries(natom + 1)) - - ! atom -> kind map (needed before the spatial layout loop, which visits atoms in a - ! kind-independent order). + total_grid_npts = 0 DO ikind = 1, nkind DO j = 1, SIZE(atomic_kind_set(ikind)%atom_list) - atom_to_kind(atomic_kind_set(ikind)%atom_list(j)) = ikind + atom_idx = atomic_kind_set(ikind)%atom_list(j) + atom_to_kind(atom_idx) = ikind + ri_rs_grid_offsets(atom_idx) = total_grid_npts + 1 + total_grid_npts = total_grid_npts + bs_env%ri_rs%grid_cache(ikind)%npts END DO END DO - ! Lay the grid rows down in Morton (spatial) atom order rather than kind-major, so a - ! contiguous grid panel maps to a compact spatial region and the CUTOFF_RADIUS_RL_W - ! neighborhood width of every panel shrinks. The grid row index is summed over in χ/Σ, - ! so this reordering is result-preserving (see spatial_atom_order). - CALL spatial_atom_order(particle_set, atom_order) - - total_grid_npts = 0 - DO i_layout = 1, natom - atom_idx = atom_order(i_layout) - ikind = atom_to_kind(atom_idx) - ri_rs_grid_offsets(atom_idx) = total_grid_npts + 1 - bs_env%ri_rs%grid_atom_boundaries(i_layout) = total_grid_npts + 1 - total_grid_npts = total_grid_npts + bs_env%ri_rs%grid_cache(ikind)%npts - END DO - ri_rs_grid_offsets(natom + 1) = total_grid_npts + 1 - bs_env%ri_rs%grid_atom_boundaries(natom + 1) = total_grid_npts + 1 IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, FMT="(T2,A,T69,I12)") & @@ -488,7 +373,7 @@ CONTAINS start_idx = ri_rs_grid_offsets(atom_idx) end_idx = start_idx + bs_env%ri_rs%grid_cache(ikind)%npts - 1 - !! Shift the cached origin grid by the atom's center + !! Shift the cached origin grid by the atom's center ri_rs_grid_points(1, start_idx:end_idx) = bs_env%ri_rs%grid_cache(ikind)%raw_points(1, :) + atomic_center(1) ri_rs_grid_points(2, start_idx:end_idx) = bs_env%ri_rs%grid_cache(ikind)%raw_points(2, :) + atomic_center(2) ri_rs_grid_points(3, start_idx:end_idx) = bs_env%ri_rs%grid_cache(ikind)%raw_points(3, :) + atomic_center(3) @@ -504,8 +389,7 @@ CONTAINS DEALLOCATE (bs_env%ri_rs%grid_cache) END IF - DEALLOCATE (atom_order, atom_to_kind, ri_rs_grid_offsets) - + DEALLOCATE (atom_to_kind, ri_rs_grid_offsets) CALL timestop(handle) END SUBROUTINE ri_rs_grid_assembler @@ -515,34 +399,24 @@ CONTAINS !> \param bs_env ... !> \param atomic_kind_set ... ! ************************************************************************************************** + SUBROUTINE build_grid_cache(bs_env, atomic_kind_set) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_grid_cache' - CHARACTER(LEN=default_path_length) :: filename, full_path, line CHARACTER(LEN=default_string_length) :: atom_sym, suffix - INTEGER :: colon_idx, handle, i, ierr, ikind, & - iunit, nkind + INTEGER :: colon_idx, i, ierr, ikind, iunit, nkind REAL(KIND=dp) :: pt(3) - CALL timeset(routineN, handle) - ! Determine the file suffix based on the user's choice IF (bs_env%ri_rs%grid_select == 1) THEN suffix = "_def2-tzvp-rs.ion" ELSE IF (bs_env%ri_rs%grid_select == 2) THEN suffix = "_cc-pvtz-rs.ion" - ELSE IF (bs_env%ri_rs%grid_select == 3) THEN - IF (LEN_TRIM(bs_env%ri_rs%grid_file_suffix) > 0) THEN - suffix = TRIM(bs_env%ri_rs%grid_file_suffix) - ELSE - suffix = "_rirs.ion" - END IF ELSE - CPABORT("Unknown grid_select (1=def2-TZVPP, 2=cc-pVTZ, 3=user-provided).") + CPABORT("Unknown grid_select value. Valid options are 1 (def2-TZVPP) or 2 (cc-pVTZ).") END IF nkind = SIZE(atomic_kind_set) @@ -591,25 +465,16 @@ CONTAINS CALL close_file(unit_number=iunit) END DO - CALL timestop(handle) - END SUBROUTINE build_grid_cache ! ************************************************************************************************** -!> \brief Evaluates the AO basis on the RI-RS grid and stores it as the sparse DBCSR matrix -!> Φ_μl = Φ_μ(r_l) (rows = grid points in atom-aligned blocks of at most -!> max_elements_per_block points, columns = one block per atom's full AO set). -!> Grid points outside the reach of an atom's most -!> diffuse Gaussian (or the CUTOFF_RADIUS_RL_AO) are skipped, and only blocks -!> with at least one element > eps_filter are stored. This locality is the source of -!> ALL grid-dimension sparsity used downstream. Also caches the atom centers and the -!> per-chunk centroids needed by the optional CUTOFF_RADIUS_G_W / CUTOFF_RADIUS_RL_W -!> operator truncations. +!> \brief Evaluates atomic basis functions on a real-space grid and builds a sparse DBCSR matrix. !> \param qs_env ... !> \param bs_env ... !> \param ri_rs_grid_points ... !> \param mat_phi_mu_l ... ! ************************************************************************************************** + SUBROUTINE atomic_basis_at_grid_point(qs_env, bs_env, ri_rs_grid_points, mat_phi_mu_l) TYPE(qs_environment_type), POINTER :: qs_env @@ -619,12 +484,11 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'atomic_basis_at_grid_point' - INTEGER :: bs_eff, c_size, dimen_ORB, handle, i, i_blk, ia, iatom, natom, npcol, nprow, & - num_grid_chunks, r_end, r_start, remaining, run, safe_max, total_grid_npts - INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_row_start, first_sgf - INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, & - r_blk_sizes, row_dist - REAL(KIND=dp) :: r2_threshold + INTEGER :: c_size, chunk_size, dimen_ORB, handle, i, i_blk, iatom, natom, npcol, nprow, & + num_grid_chunks, r_end, r_start, total_grid_npts + INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf + INTEGER, DIMENSION(:), POINTER :: c_blk_sizes, col_dist, col_dist_ks, & + r_blk_sizes, row_dist, row_dist_ks REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: atom_col_buffer TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell @@ -636,6 +500,8 @@ CONTAINS CALL timeset(routineN, handle) + chunk_size = max_elements_per_block + ! Extract environment variables CALL get_qs_env(qs_env, cell=cell, atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set, particle_set=particle_set, & @@ -658,71 +524,22 @@ CONTAINS c_blk_sizes(iatom) = first_sgf(iatom + 1) - first_sgf(iatom) END DO - ! B. Define Row Block Sizes: atom-aligned blocks (a block never spans two atoms' grid - ! runs), each atom's run subdivided into blocks of at most bs_eff points. + ! B. Define Row Block Sizes (Grid chunks of max size 256) + num_grid_chunks = CEILING(REAL(total_grid_npts, KIND=dp)/REAL(chunk_size, KIND=dp)) + ALLOCATE (r_blk_sizes(num_grid_chunks)) + r_blk_sizes = chunk_size + IF (MOD(total_grid_npts, chunk_size) /= 0) THEN + r_blk_sizes(num_grid_chunks) = MOD(total_grid_npts, chunk_size) + END IF - ! Fetch CP2K's default process grid configuration + ! C. Fetch CP2K's Default Process Grid Configuration CALL get_qs_env(qs_env, dbcsr_dist=dbcsr_dist_ks) - CALL dbcsr_distribution_get(dbcsr_dist_ks, nprows=nprow, npcols=npcol) + CALL dbcsr_distribution_get(dbcsr_dist_ks, row_dist=row_dist_ks, col_dist=col_dist_ks) - ! Overflow-safe upper bound on the block size (see dbcsr_msg_elem_limit). - safe_max = INT(0.5_dp*REAL(dbcsr_msg_elem_limit, dp)*REAL(MAX(MIN(nprow, npcol), 1), dp)/ & - REAL(total_grid_npts, dp)) - safe_max = MAX(1, safe_max) - ! Block size = CP2K's global max_elements_per_block (GLOBAL/DBCSR input; default 32), - ! overflow-capped. - bs_eff = MAX(1, MIN(max_elements_per_block, safe_max)) - - ! Count the atom-aligned blocks, then fill r_blk_sizes and each block's starting grid row. - num_grid_chunks = 0 - DO ia = 1, natom - run = bs_env%ri_rs%grid_atom_boundaries(ia + 1) - bs_env%ri_rs%grid_atom_boundaries(ia) - IF (run > 0) num_grid_chunks = num_grid_chunks + (run + bs_eff - 1)/bs_eff - END DO - ALLOCATE (r_blk_sizes(num_grid_chunks), blk_row_start(num_grid_chunks)) - i_blk = 0 - r_start = 1 - DO ia = 1, natom - remaining = bs_env%ri_rs%grid_atom_boundaries(ia + 1) - bs_env%ri_rs%grid_atom_boundaries(ia) - DO WHILE (remaining > 0) - i_blk = i_blk + 1 - r_blk_sizes(i_blk) = MIN(bs_eff, remaining) - blk_row_start(i_blk) = r_start - r_start = r_start + r_blk_sizes(i_blk) - remaining = remaining - r_blk_sizes(i_blk) - END DO - END DO - - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T69,I12)') 'RI-RS grid row-blocks of phi(mu,l)', num_grid_chunks - WRITE (bs_env%unit_nr, '(T2,A,T69,I12)') 'RI-RS grid points per block (max)', bs_eff - END IF - - ! Cache atomic positions: AO and RI blocks are one-block-per-atom, so these are the - ! block centers used by the optional CUTOFF_RADIUS_G_W atom-pair truncation. - IF (ALLOCATED(bs_env%ri_rs%atom_centers)) DEALLOCATE (bs_env%ri_rs%atom_centers) - ALLOCATE (bs_env%ri_rs%atom_centers(3, natom)) - DO iatom = 1, natom - bs_env%ri_rs%atom_centers(1:3, iatom) = particle_set(iatom)%r(1:3) - END DO - - ! Cache per-chunk centroids for the optional CUTOFF_RADIUS_RL_W block truncation. - IF (bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp) THEN - IF (ALLOCATED(bs_env%ri_rs%chunk_centroids)) DEALLOCATE (bs_env%ri_rs%chunk_centroids) - ALLOCATE (bs_env%ri_rs%chunk_centroids(3, num_grid_chunks)) - DO i_blk = 1, num_grid_chunks - r_start = blk_row_start(i_blk) - r_end = r_start + r_blk_sizes(i_blk) - 1 - bs_env%ri_rs%chunk_centroids(1, i_blk) = & - SUM(ri_rs_grid_points(1, r_start:r_end))/REAL(r_blk_sizes(i_blk), dp) - bs_env%ri_rs%chunk_centroids(2, i_blk) = & - SUM(ri_rs_grid_points(2, r_start:r_end))/REAL(r_blk_sizes(i_blk), dp) - bs_env%ri_rs%chunk_centroids(3, i_blk) = & - SUM(ri_rs_grid_points(3, r_start:r_end))/REAL(r_blk_sizes(i_blk), dp) - END DO - END IF - - ! C. Build Custom Mappings using Round-Robin across the 2D process grid + ! D. Build Custom Mappings using Round-Robin across the 2D process grid + ! (MAXVAL + 1 accounts for 0-based process indexing in DBCSR) + nprow = MAXVAL(row_dist_ks) + 1 + npcol = MAXVAL(col_dist_ks) + 1 ALLOCATE (row_dist(num_grid_chunks)) DO i = 1, num_grid_chunks @@ -756,20 +573,15 @@ CONTAINS ! Evaluate the basis functions on the grid. Skip grid points outside ! the spatial extent of the most diffuse AO Gaussian on iatom; beyond - ! that radius the contribution is guaranteed below eps_filter. A positive - ! CUTOFF_RADIUS_RL_AO overrides this with a user-defined hard cutoff. - IF (bs_env%ri_rs%cutoff_radius_ri_ao > 0.0_dp) THEN - r2_threshold = bs_env%ri_rs%cutoff_radius_ri_ao**2 - ELSE - r2_threshold = bs_env%ri_rs%radius_ao_per_atom(iatom)**2 - END IF + ! that radius the contribution is guaranteed below eps_filter. CALL fill_phi_for_atom(atom_col_buffer, ri_rs_grid_points, total_grid_npts, & - iatom, particle_set, qs_kind_set, cell, r2_threshold) + iatom, particle_set, qs_kind_set, cell, & + bs_env%ri_rs%radius_ao_per_atom(iatom)**2) - ! Slice the dense column into the atom-aligned grid row-blocks and insert into DBCSR + ! Slice the dense column into chunks and insert into DBCSR DO i_blk = 1, num_grid_chunks - r_start = blk_row_start(i_blk) - r_end = r_start + r_blk_sizes(i_blk) - 1 + r_start = (i_blk - 1)*chunk_size + 1 + r_end = MIN(i_blk*chunk_size, total_grid_npts) ! Apply dynamic sparsity filtering: Only store blocks with physical significance IF (MAXVAL(ABS(atom_col_buffer(r_start:r_end, 1:c_size))) > bs_env%eps_filter) THEN @@ -782,14 +594,13 @@ CONTAINS END DO + ! Finalize triggers internal MPI communication to route blocks to their correct 2D process owners CALL dbcsr_finalize(mat_phi_mu_l) - CALL print_matrix_occupation(mat_phi_mu_l, 'φ(μ,l)', para_env, bs_env%unit_nr) - ! ------------------------------------------------------------------------- ! CLEANUP ! ------------------------------------------------------------------------- - DEALLOCATE (first_sgf, r_blk_sizes, c_blk_sizes, row_dist, col_dist, blk_row_start) + DEALLOCATE (first_sgf, r_blk_sizes, c_blk_sizes, row_dist, col_dist) CALL dbcsr_distribution_release(dist) CALL timestop(handle) @@ -797,13 +608,7 @@ CONTAINS END SUBROUTINE atomic_basis_at_grid_point ! ************************************************************************************************** -!> \brief Evaluates all spherical AO basis functions of one atom on a set of grid points and -!> ACCUMULATES them into phi_val (+=). For each point within the cutoff radius, -!> Φ_μ(r) = Σ_pgf Σ_cart sphi(cart,μ) · (x-X_A)^lx (y-Y_A)^ly (z-Z_A)^lz · e^(-ζ_pgf |r-R_A|²) -!> i.e. contracted Cartesian Gaussians transformed to the spherical basis via the sphi -!> coefficients. Distances are minimum-image wrapped (pbc); points with -!> |r - R_A|² > r2_threshold are skipped since every primitive is below eps there. -!> OMP-parallel over grid points. +!> \brief Compute value of all basis function for single atom across all grid points !> \param phi_val ... !> \param ri_rs_grid ... !> \param npts ... @@ -813,6 +618,7 @@ CONTAINS !> \param cell ... !> \param r2_threshold ... ! ************************************************************************************************** + SUBROUTINE fill_phi_for_atom(phi_val, ri_rs_grid, npts, iatom, & particle_set, qs_kind_set, cell, r2_threshold) @@ -825,25 +631,18 @@ CONTAINS TYPE(cell_type), POINTER :: cell REAL(KIND=dp), INTENT(IN) :: r2_threshold - CHARACTER(LEN=*), PARAMETER :: routineN = 'fill_phi_for_atom' - - INTEGER :: first_sgf, handle, i_pt, ico, iend_co, & - ikind, ipgf, iset, isgf, ishell, & - istart_co, l, last_sgf, lx, ly, lz, & - n_cart_total, row_idx + INTEGER :: first_sgf, i_pt, ico, iend_co, ikind, & + ipgf, iset, isgf, ishell, istart_co, & + l, last_sgf, lx, ly, lz, n_cart_total, & + row_idx REAL(KIND=dp) :: alpha, dist_vec(3), exp_val, poly, r2, & r_atom(3), weight TYPE(gto_basis_set_type), POINTER :: orb_basis_set - CALL timeset(routineN, handle) - ! Get Atom Info ikind = particle_set(iatom)%atomic_kind%kind_number CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type="ORB") - IF (.NOT. ASSOCIATED(orb_basis_set)) THEN - CALL timestop(handle) - RETURN - END IF + IF (.NOT. ASSOCIATED(orb_basis_set)) RETURN r_atom = particle_set(iatom)%r @@ -893,19 +692,16 @@ CONTAINS END DO !$OMP END PARALLEL DO - CALL timestop(handle) - END SUBROUTINE fill_phi_for_atom ! ************************************************************************************************** -!> \brief Computes the AO basis offsets: first_sgf(iatom) is the global index of the first -!> spherical Gaussian function (SGF) of iatom, first_sgf(natom+1) = total_sgf + 1, -!> and total_sgf is the total number of AO basis functions. +!> \brief Helper for OMP threads to fill phi_val column values !> \param particle_set ... !> \param qs_kind_set ... !> \param first_sgf ... !> \param total_sgf ... ! ************************************************************************************************** + SUBROUTINE get_basis_offsets(particle_set, qs_kind_set, first_sgf, total_sgf) TYPE(particle_type), DIMENSION(:), POINTER :: particle_set @@ -932,29 +728,17 @@ CONTAINS END SUBROUTINE get_basis_offsets ! ************************************************************************************************** -!> \brief Computes the RI-RS fitting coefficients Z_lP by solving, independently for every RI -!> atom P, a Jacobi-conditioned, Tikhonov-regularized linear system restricted to the -!> grid points r_l inside P's integration sphere |r_l - R_P| <= cutoff_ri(P): -!> D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]² (squared grid Gram matrix, Eq. 13) -!> D_lP = Σ_μν Φ_μ(r_l) Φ_ν(r_l) (μν|P) (grid-RI right-hand side, Eq. 15) -!> d_l = 1 / sqrt(D_ll) (Jacobi conditioning vector) -!> D'_ll' = d_l D_ll' d_l' + λ δ_ll' (λ = TIKHONOV_SIGMA regularization) -!> Σ_l' D'_ll' Z'_l'P = d_l D_lP (Cholesky solve, Eq. 14) -!> Z_lP = d_l Z'_l'P (undo the conditioning) -!> Work is distributed over atoms in two phases (planned by classify_z_lp_atoms and -!> lpt_assign_atoms): Phase A solves "small" atoms with single-rank LAPACK -!> (dpotrf/dpotrs); Phase B solves "big" atoms, whose dense Gram matrix would exceed one -!> rank's memory, with ScaLAPACK (pdpotrf/pdpotrs) over rank subgroups of size G. -!> The solved Z columns are scattered into the sparse global mat_Z_lP. -!> If a Z_lP restart file exists, it is read instead and the solve is skipped entirely. +!> \brief Compute RI-RS Coefficients (Z_lP) !> \param qs_env ... !> \param bs_env ... !> \param ri_rs_grid_points ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... ! ************************************************************************************************** + SUBROUTINE compute_coeff_Z_lP(qs_env, bs_env, ri_rs_grid_points, mat_phi_mu_l, mat_Z_lP) + ! Arguments TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env REAL(KIND=dp), ALLOCATABLE, INTENT(INOUT) :: ri_rs_grid_points(:, :) @@ -962,21 +746,23 @@ CONTAINS TYPE(dbcsr_type), INTENT(OUT) :: mat_Z_lP CHARACTER(LEN=*), PARAMETER :: key = 'PROPERTIES%BANDSTRUCTURE%GW%PRINT%RESTART', & - routineN = 'compute_coeff_Z_lP' + routineN = 'compute_coeff_Z_lP' - INTEGER :: atom_j_mepos, atom_j_stride, atom_P, G, handle, handle_dpotrf, handle_dpotrs, & - i_blk, idx, info, iphase, j, max_ao_size, my_group, n_ao_total, n_big, n_done, & - n_groups, n_loc_ri, n_local_grid, n_my_atoms, n_small, natom, next_pct, & - npcol_phi, num_grid_chunks, P_loop_atom, phase_hi - INTEGER, ALLOCATABLE, DIMENSION(:) :: big_list, local_grid_idx, & - my_atoms_A, my_atoms_B, & - n_local_grid_atom, row_offset, small_list - INTEGER, DIMENSION(:), POINTER :: col_dist_ri, r_blk_sizes, & + INTEGER :: atom_j_mepos, atom_j_stride, atom_P, atom_P_start, atom_P_stride, col_end, & + col_start, current_chunk_size, g, group_handle, handle, i, i_blk, ikind, info, j, j_ri, & + l, loc_idx, loc_ptr, max_ao_size, max_loc_ri, my_group, n_ao_total, n_grid_total, & + n_groups, n_loc_ri, n_local_grid, n_procs_per_atom, natom, nkind, num_grid_chunks, & + P_loop_atom, r_end, r_start, source_atom + INTEGER, ALLOCATABLE, DIMENSION(:) :: local_grid_idx, row_offset + INTEGER, DIMENSION(:), POINTER :: col_dist_phi, col_dist_ri, r_blk_sizes, & ri_blk_sizes, row_dist_grid - LOGICAL :: do_scatter, use_dist - REAL(KIND=dp) :: balance_A, balance_B, cutoff_ri, r_c, t1 + REAL(KIND=dp) :: cutoff_ri, d_sP, dist, r2_threshold, & + r_c, t1 + REAL(KIND=dp), ALLOCATABLE :: cutoff_ri_per_kind(:) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cutoff_ri_per_atom, d_vec_local - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: D_local, d_lp_local, phi_local + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: D_local, d_lp_local, phi_local, & + sphere_grid, Z_blk + REAL(KIND=dp), DIMENSION(3) :: pos_P TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub @@ -997,18 +783,44 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env, particle_set=particle_set, input=input, & qs_kind_set=qs_kind_set, cell=cell, atomic_kind_set=atomic_kind_set) + ! --------------------------------------------------------------------- + ! Subgroup setup. Default G=1 keeps the single-rank BLAS path; G>1 splits + ! ranks into atom-groups so the Cholesky on D_local distributes across G + ! ranks (memory ~1/G) and the compute_d_lp build also splits across the + ! subgroup. G=1 leaves para_env_sub / blacs_env_sub NULL — no subgroup + ! comms created, atom_P loop uses per-rank round-robin, compute_d_lp runs + ! its full atom_j range on each rank, no allreduce. + ! --------------------------------------------------------------------- + n_procs_per_atom = MIN(bs_env%ri_rs%n_procs_per_atom_z_lp, para_env%num_pe) + IF (n_procs_per_atom < 1) n_procs_per_atom = 1 + NULLIFY (para_env_sub, blacs_env_sub) + IF (n_procs_per_atom > 1) THEN + n_groups = para_env%num_pe/n_procs_per_atom + my_group = MIN(para_env%mepos/n_procs_per_atom, n_groups - 1) + ALLOCATE (para_env_sub) + CALL para_env_sub%from_split(para_env, my_group) + CALL cp_blacs_env_create(blacs_env=blacs_env_sub, para_env=para_env_sub) + atom_P_start = my_group + 1 + atom_P_stride = n_groups + atom_j_mepos = para_env_sub%mepos + atom_j_stride = para_env_sub%num_pe + ELSE + atom_P_start = para_env%mepos + 1 + atom_P_stride = para_env%num_pe + atom_j_mepos = 0 + atom_j_stride = 1 + END IF natom = SIZE(bs_env%i_RI_start_from_atom) n_ao_total = bs_env%i_ao_end_from_atom(natom) + n_grid_total = SIZE(ri_rs_grid_points, 2) ! ========================================================================= ! 1. SETUP DBCSR TOPOLOGY & EXACT OFFSETS - ! mat_Z_lP inherits the grid row blocking (and row distribution) of - ! mat_phi_mu_l; its columns are one block per RI atom. ! ========================================================================= CALL dbcsr_get_info(mat_phi_mu_l, row_blk_size=r_blk_sizes, distribution=dist_phi) - CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, npcols=npcol_phi) + CALL dbcsr_distribution_get(dist_phi, row_dist=row_dist_grid, col_dist=col_dist_phi, group=group_handle) num_grid_chunks = SIZE(r_blk_sizes) @@ -1021,7 +833,7 @@ CONTAINS ALLOCATE (ri_blk_sizes(natom), col_dist_ri(natom)) DO atom_P = 1, natom ri_blk_sizes(atom_P) = bs_env%i_RI_end_from_atom(atom_P) - bs_env%i_RI_start_from_atom(atom_P) + 1 - col_dist_ri(atom_P) = MOD(atom_P - 1, npcol_phi) + col_dist_ri(atom_P) = MOD(atom_P - 1, MAXVAL(col_dist_phi) + 1) END DO CALL dbcsr_distribution_new(dist_Z, template=dist_phi, row_dist=row_dist_grid, col_dist=col_dist_ri) @@ -1033,11 +845,6 @@ CONTAINS IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & 'Read Z_lP from file ', ' Execution time', m_walltime() - t1, ' s' - ! The grid rows are laid out in Morton (spatial) order (spatial_atom_order); a Z_lP.matrix - ! written by an older build with a different grid ordering would be silently misread into - ! the current row order. Delete stale Z_lP.matrix files and recompute if in doubt. - WRITE (bs_env%unit_nr, '(T2,A)') & - '*** NOTE: Z_lP restart must match the current (spatial) grid row ordering ***' WRITE (bs_env%unit_nr, '(A)') ' ' END IF ELSE @@ -1046,17 +853,17 @@ CONTAINS matrix_type=dbcsr_type_no_symmetry, & row_blk_size=r_blk_sizes, col_blk_size=ri_blk_sizes) - ! Largest per-atom AO block, needed to size the 3c-integral work buffers. max_ao_size = 0 DO j = 1, SIZE(bs_env%i_ao_start_from_atom) max_ao_size = MAX(max_ao_size, bs_env%i_ao_end_from_atom(j) - bs_env%i_ao_start_from_atom(j) + 1) END DO + max_loc_ri = MAXVAL(ri_blk_sizes) ! Per-atom RI-RS integration sphere: - ! cutoff_ri(P) = r_c + r_RI(P) - ! where r_c is the truncated-Coulomb cutoff of the RI metric and r_RI the radius of - ! the most diffuse RI auxiliary Gaussian on P. The CUTOFF_RADIUS_RL_RI keyword - ! (when > 0) overrides the entire cutoff calculation. + ! cutoff_ri(P) = r_c + r_AO(P) + ! where r_c is the truncated-Coulomb cutoff of the RI metric. The + ! CUTOFF_RADIUS_RI_RS keyword (when > 0) overrides the entire cutoff calculation. + nkind = SIZE(atomic_kind_set) ALLOCATE (cutoff_ri_per_atom(natom)) IF (bs_env%ri_rs%cutoff_radius_ri_rs > 0.0_dp) THEN @@ -1065,215 +872,267 @@ CONTAINS r_c = bs_env%ri_metric%cutoff_radius DO P_loop_atom = 1, natom cutoff_ri_per_atom(P_loop_atom) = & - r_c + bs_env%ri_rs%radius_ri_per_atom(P_loop_atom) + r_c + bs_env%ri_rs%radius_ao_per_atom(P_loop_atom) END DO END IF - CALL print_sphere_cutoff_table(bs_env, atomic_kind_set, particle_set, cutoff_ri_per_atom) - - ! ========================================================================= - ! 2. PER-ATOM SOLVER CLASSIFICATION - ! Split the atoms into "small" (single-rank LAPACK, Phase A) and "big" - ! (distributed ScaLAPACK over subgroups of G ranks, Phase B) by comparing - ! each atom's estimated solve peak memory against the measured budget. - ! ========================================================================= - CALL classify_z_lp_atoms(bs_env, para_env, ri_rs_grid_points, particle_set, & - cutoff_ri_per_atom, ri_blk_sizes, n_ao_total, & - n_local_grid_atom, small_list, n_small, big_list, n_big, G) - - ! LPT scheduling: sort the atoms of each phase by estimated solve cost - ! (n_local_grid^3, Cholesky-dominated) and greedily assign to the least-loaded - ! rank (Phase A) / subgroup (Phase B). - CALL lpt_assign_atoms(small_list, n_small, n_local_grid_atom, para_env%num_pe, & - para_env%mepos, my_atoms_A, balance_A) - IF (n_big > 0) THEN - n_groups = para_env%num_pe/G - my_group = MIN(para_env%mepos/G, n_groups - 1) - CALL lpt_assign_atoms(big_list, n_big, n_local_grid_atom, n_groups, my_group, & - my_atoms_B, balance_B) - ELSE - ALLOCATE (my_atoms_B(0)) - balance_B = 1.0_dp - END IF - - ! Atoms this rank will process across both phases for rank-0 progress - n_my_atoms = SIZE(my_atoms_A) + SIZE(my_atoms_B) - n_done = 0 - next_pct = 25 - + ALLOCATE (cutoff_ri_per_kind(nkind)) + cutoff_ri_per_kind(:) = 0.0_dp IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,I7,A,I8,A)') & - 'RI-RS Z_lP solver: ', n_small, ' atoms single-rank (BLAS), ', n_big, & - ' atoms distributed' - IF (n_small > 0) WRITE (bs_env%unit_nr, '(T4,A,F18.2)') & - 'estimated single-rank load balance (max/mean cost per rank)', balance_A - IF (n_big > 0) THEN - WRITE (bs_env%unit_nr, '(T4,A,I44,A)') & - 'distributed subgroup size G', G, ' ranks' - WRITE (bs_env%unit_nr, '(T4,A,F17.2)') & - 'estimated distributed load balance (max/mean cost per group)', balance_B - END IF + WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind maximum RI-RS sphere cutoff (Bohr):' + WRITE (bs_env%unit_nr, '(T4,A4,A14)') 'Kind', 'max cutoff_ri' + ! Walk atoms once; accumulate per-kind max using atomic_kind index + DO P_loop_atom = 1, natom + ikind = particle_set(P_loop_atom)%atomic_kind%kind_number + cutoff_ri_per_kind(ikind) = MAX(cutoff_ri_per_kind(ikind), & + cutoff_ri_per_atom(P_loop_atom)) + END DO + DO ikind = 1, nkind + WRITE (bs_env%unit_nr, '(T4,A4,F14.4)') & + atomic_kind_set(ikind)%element_symbol, & + cutoff_ri_per_kind(ikind) + END DO WRITE (bs_env%unit_nr, '(A)') ' ' END IF + DEALLOCATE (cutoff_ri_per_kind) - ! Shared context for the three-center integrals (μν|P) of the RHS build + ! Build the shared 3c-integral context once, before the atom_P loop and outside + ! any OMP region. This hoists out the libint / t_c_g0 / md_ftable inits and the + ! contracted sphi tables, which would otherwise re-run on every per-block call. + ! gw_3c_ctx_create is MPI-collective (truncated-Coulomb init reads a file + bcasts). CALL gw_3c_ctx_create(ctx_3c, qs_env, bs_env%ri_metric, & basis_j=bs_env%basis_set_AO, basis_k=bs_env%basis_set_AO, & basis_i=bs_env%basis_set_RI) ! ========================================================================= - ! 3. TWO-PHASE LOOP OVER ATOMS - ! Phase A processes the "small" atoms with the single-rank BLAS path - ! Phase B processes the "big" atoms with the distributed ScaLAPACK path - ! over rank subgroups of size G. phi_local for each atom's cutoff sphere - ! is built on the fly to avoid replicating a global grid x AO matrix. + ! 2. MPI LOOP OVER ATOMS (Fully independent, no MPI barriers inside) + ! This distributes the N_atoms among the available MPI processors. + ! phi_local for each atom_P's cutoff sphere is built on the fly via + ! fill_phi_for_atom — no dense replicated phi_global, no allreduce. ! ========================================================================= - DO iphase = 1, 2 - IF (iphase == 1) THEN - use_dist = .FALSE. - atom_j_mepos = 0 - atom_j_stride = 1 - phase_hi = SIZE(my_atoms_A) - ELSE - IF (n_big == 0) CYCLE - use_dist = .TRUE. - n_groups = para_env%num_pe/G - my_group = MIN(para_env%mepos/G, n_groups - 1) - ALLOCATE (para_env_sub) - CALL para_env_sub%from_split(para_env, my_group) - CALL cp_blacs_env_create(blacs_env=blacs_env_sub, para_env=para_env_sub) - atom_j_mepos = para_env_sub%mepos - atom_j_stride = para_env_sub%num_pe - ! All ranks of a subgroup share my_group, hence the identical my_atoms_B list - ! (the per-atom ScaLAPACK solve is collective over the subgroup). - phase_hi = SIZE(my_atoms_B) + DO atom_P = atom_P_start, natom, atom_P_stride + + n_loc_ri = ri_blk_sizes(atom_P) + pos_P(:) = particle_set(atom_P)%r(:) + + cutoff_ri = cutoff_ri_per_atom(atom_P) + + ! --------------------------------------------------------------------- + ! A. Determine Local Grid Domain based on cutoff_ri + ! --------------------------------------------------------------------- + n_local_grid = 0 + DO l = 1, n_grid_total + dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) + IF (dist <= cutoff_ri) n_local_grid = n_local_grid + 1 + END DO + + ALLOCATE (local_grid_idx(n_local_grid)) + + n_local_grid = 0 + DO l = 1, n_grid_total + dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) + IF (dist <= cutoff_ri) THEN + n_local_grid = n_local_grid + 1 + local_grid_idx(n_local_grid) = l + END IF + END DO + + ! --------------------------------------------------------------------- + ! B. Build phi_local on the fly via fill_phi_for_atom (no replication) + ! --------------------------------------------------------------------- + ! Copy the local sphere coordinates into a contiguous buffer for + ! fill_phi_for_atom. Only source atoms whose AO basis can reach the + ! sphere of atom_P contribute; the others are pruned by the inequality + ! using the per-atom radii precomputed in precompute_ri_rs_radii. + ALLOCATE (sphere_grid(3, n_local_grid)) + DO loc_idx = 1, n_local_grid + sphere_grid(:, loc_idx) = ri_rs_grid_points(:, local_grid_idx(loc_idx)) + END DO + + ALLOCATE (phi_local(n_local_grid, n_ao_total)) + phi_local = 0.0_dp + + DO source_atom = 1, natom + d_sP = NORM2(particle_set(source_atom)%r(:) - pos_P(:)) + IF (d_sP > bs_env%ri_rs%radius_ao_per_atom(source_atom) + cutoff_ri) CYCLE + + col_start = bs_env%i_ao_start_from_atom(source_atom) + col_end = bs_env%i_ao_end_from_atom(source_atom) + r2_threshold = bs_env%ri_rs%radius_ao_per_atom(source_atom)**2 + + CALL fill_phi_for_atom(phi_local(:, col_start:col_end), sphere_grid, & + n_local_grid, source_atom, particle_set, qs_kind_set, & + cell, r2_threshold) + END DO + + DEALLOCATE (sphere_grid) + + ! --------------------------------------------------------------------- + ! C. Build Local RHS Matrix (d_lp_local) + ! Done first so the subgroup-distributed compute_d_lp + allreduce + ! is not entangled with the LHS build. compute_d_lp does not + ! depend on D_local or d_vec_local. + ! --------------------------------------------------------------------- + ALLOCATE (d_lp_local(n_local_grid, n_loc_ri)) + d_lp_local = 0.0_dp + + CALL compute_d_lp(bs_env, ctx_3c, phi_local, d_lp_local, n_local_grid, & + n_loc_ri, atom_P, max_ao_size, atom_j_mepos, atom_j_stride) + + ! Reduce per-subgroup-rank partials into the replicated d_lp_local. + ! Skipped for G=1 (BLAS path): each rank has the full sum locally. + IF (n_procs_per_atom > 1) THEN + CALL para_env_sub%sum(d_lp_local) END IF - DO idx = 1, phase_hi - IF (iphase == 1) THEN - atom_P = my_atoms_A(idx) - ELSE - atom_P = my_atoms_B(idx) - END IF + ! --------------------------------------------------------------------- + ! D. Build d_vec_local (Jacobi diagonal) + LHS — BLAS or ScaLAPACK + ! --------------------------------------------------------------------- + ALLOCATE (d_vec_local(n_local_grid)) - n_loc_ri = ri_blk_sizes(atom_P) - cutoff_ri = cutoff_ri_per_atom(atom_P) + IF (n_procs_per_atom == 1) THEN + ! BLAS path: build D_local densely, compute d_vec as side-effect + ! of the Jacobi step (preserves bit-identical arithmetic with the + ! previous branch). + ALLOCATE (D_local(n_local_grid, n_local_grid)) + D_local = 0.0_dp - ! --------------------------------------------------------------------- - ! A. Sphere-local AO matrix Φ_μ(r_l): select the grid points with - ! |r_l - R_P| <= cutoff_ri(P), evaluate every AO on them, and drop - ! points whose largest AO amplitude is below EPS_FILTER. - ! --------------------------------------------------------------------- - CALL build_phi_on_sphere(bs_env, particle_set, qs_kind_set, cell, & - ri_rs_grid_points, atom_P, cutoff_ri, n_ao_total, & - local_grid_idx, n_local_grid, phi_local) + CALL dsyrk("L", "N", n_local_grid, n_ao_total, 1.0_dp, phi_local, & + n_local_grid, 0.0_dp, D_local, n_local_grid) - ! --------------------------------------------------------------------- - ! B. Right-hand side D_lP = Σ_μν Φ_μ(r_l) Φ_ν(r_l) (μν|P) - ! --------------------------------------------------------------------- - ALLOCATE (d_lp_local(n_local_grid, n_loc_ri)) - d_lp_local = 0.0_dp + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, D_local, d_vec_local, bs_env) & + !$OMP PRIVATE(i) & + !$OMP SCHEDULE(STATIC) + DO i = 1, n_local_grid + D_local(i, i) = D_local(i, i)**2 + d_vec_local(i) = 1.0_dp/SQRT(MAX(D_local(i, i), 1.0E-16_dp)) + D_local(i, i) = (D_local(i, i)*d_vec_local(i)**2) + bs_env%ri_rs%tikhonov + END DO + !$OMP END PARALLEL DO - CALL compute_d_lp(bs_env, ctx_3c, phi_local, d_lp_local, n_local_grid, & - n_loc_ri, atom_P, max_ao_size, atom_j_mepos, atom_j_stride) - - ! Reduce per-subgroup-rank partials into the replicated d_lp_local. - ! Skipped for BLAS path: each rank has the full sum locally. - IF (use_dist) THEN - CALL para_env_sub%sum(d_lp_local) - END IF - - ! --------------------------------------------------------------------- - ! C. Jacobi conditioning vector d_l = 1/sqrt(D_ll) and, on the BLAS path, - ! the dense conditioned Gram matrix D'_ll' = d_l D_ll' d_l' + λδ_ll'. - ! --------------------------------------------------------------------- - ALLOCATE (d_vec_local(n_local_grid)) - - IF (.NOT. use_dist) THEN - CALL build_gram_jacobi_blas(phi_local, n_local_grid, n_ao_total, & - bs_env%ri_rs%tikhonov, D_local, d_vec_local) - ELSE - ! ScaLAPACK path: only d_vec is needed here (= 1/||phi(r_l)||^2); - ! solve_D_lp_distributed builds its block-cyclic slice of D' internally - ! with the squared+scaled values, so no dense D_local on this rank. - CALL build_jacobi_diag_from_phi(phi_local, n_local_grid, n_ao_total, & - d_vec_local) - END IF - - ! --------------------------------------------------------------------- - ! D. Pre-scale the RHS: D'_lP = d_l * D_lP - ! --------------------------------------------------------------------- - CALL scale_rows_by_diag(d_lp_local, d_vec_local, n_local_grid, n_loc_ri) - - ! --------------------------------------------------------------------- - ! E. Cholesky solve Σ_l' D'_ll' Z'_l'P = D'_lP - ! (BLAS dpotrf/dpotrs or ScaLAPACK pdpotrf/pdpotrs) - ! --------------------------------------------------------------------- - IF (.NOT. use_dist) THEN - CALL timeset(routineN//"_dpotrf", handle_dpotrf) - CALL dpotrf('L', n_local_grid, D_local, n_local_grid, info) - CALL timestop(handle_dpotrf) - CALL timeset(routineN//"_dpotrs", handle_dpotrs) - CALL dpotrs('L', n_local_grid, n_loc_ri, D_local, n_local_grid, & - d_lp_local, n_local_grid, info) - CALL timestop(handle_dpotrs) - DEALLOCATE (D_local) - ELSE - CALL solve_D_lp_distributed(phi_local, d_vec_local, d_lp_local, & - n_local_grid, n_ao_total, n_loc_ri, & - bs_env%ri_rs%tikhonov, & - para_env_sub, blacs_env_sub, & - fm_struct_D, fm_struct_b, fm_D, fm_b, info) - END IF - - ! --------------------------------------------------------------------- - ! F. Undo the conditioning: Z_lP = d_l * Z'_lP - ! --------------------------------------------------------------------- - CALL scale_rows_by_diag(d_lp_local, d_vec_local, n_local_grid, n_loc_ri) - - ! --------------------------------------------------------------------- - ! G. Scatter the solved Z columns back into the global sparse mat_Z_lP. - ! --------------------------------------------------------------------- - do_scatter = .TRUE. - IF (use_dist) do_scatter = (para_env_sub%mepos == 0) - IF (do_scatter) THEN - CALL scatter_z_columns(mat_Z_lP, d_lp_local, local_grid_idx, n_local_grid, & - n_loc_ri, atom_P, r_blk_sizes, row_offset, & - bs_env%eps_filter) - END IF - - DEALLOCATE (d_vec_local, d_lp_local) - DEALLOCATE (local_grid_idx, phi_local) - - ! Progress based on rank 0 only - n_done = n_done + 1 - IF (bs_env%unit_nr > 0 .AND. n_my_atoms > 0) THEN - DO WHILE (next_pct <= 100 .AND. n_done*100 >= next_pct*n_my_atoms) - WRITE (bs_env%unit_nr, '(T2,A,I57,A)') 'Computing Z_lP:', next_pct, ' % done' - next_pct = next_pct + 25 + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, D_local, d_vec_local) & + !$OMP PRIVATE(j, i) & + !$OMP SCHEDULE(DYNAMIC) + DO j = 1, n_local_grid + DO i = j + 1, n_local_grid + D_local(i, j) = D_local(i, j)**2 + D_local(i, j) = D_local(i, j)*d_vec_local(i)*d_vec_local(j) + D_local(j, i) = D_local(i, j) END DO - END IF - END DO ! idx: atoms of this phase owned by this rank / subgroup - - ! Tear down the Phase-B subgroup (all ranks created it collectively). - IF (iphase == 2) THEN - CALL cp_blacs_env_release(blacs_env_sub) - CALL para_env_sub%free() - DEALLOCATE (para_env_sub) + END DO + !$OMP END PARALLEL DO + ELSE + ! ScaLAPACK path: d_vec computed directly from phi (= 1/||phi_i||^2); + ! solve_D_lp_distributed builds D block-cyclic internally with + ! the squared+scaled values, so no dense D_local on this rank. + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_local_grid, n_ao_total, phi_local, d_vec_local) & + !$OMP PRIVATE(i, j) & + !$OMP SCHEDULE(STATIC) + DO i = 1, n_local_grid + d_vec_local(i) = 0.0_dp + DO j = 1, n_ao_total + d_vec_local(i) = d_vec_local(i) + phi_local(i, j)*phi_local(i, j) + END DO + d_vec_local(i) = 1.0_dp/MAX(d_vec_local(i), 1.0E-16_dp) + END DO + !$OMP END PARALLEL DO END IF - END DO ! iphase + + ! --------------------------------------------------------------------- + ! E. Pre-scale d_lp by d_vec + ! --------------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_loc_ri, n_local_grid, d_lp_local, d_vec_local) & + !$OMP PRIVATE(j_ri, i) & + !$OMP SCHEDULE(STATIC) + DO j_ri = 1, n_loc_ri + DO i = 1, n_local_grid + d_lp_local(i, j_ri) = d_lp_local(i, j_ri)*d_vec_local(i) + END DO + END DO + !$OMP END PARALLEL DO + + ! --------------------------------------------------------------------- + ! F. Solve — BLAS dpotrf/dpotrs or ScaLAPACK pdpotrf/pdpotrs + ! --------------------------------------------------------------------- + IF (n_procs_per_atom == 1) THEN + CALL dpotrf('L', n_local_grid, D_local, n_local_grid, info) + CALL dpotrs('L', n_local_grid, n_loc_ri, D_local, n_local_grid, & + d_lp_local, n_local_grid, info) + DEALLOCATE (D_local) + ELSE + CALL solve_D_lp_distributed(phi_local, d_vec_local, d_lp_local, & + n_local_grid, n_ao_total, n_loc_ri, & + bs_env%ri_rs%tikhonov, & + para_env_sub, blacs_env_sub, & + fm_struct_D, fm_struct_b, fm_D, fm_b, info) + END IF + + ! --------------------------------------------------------------------- + ! G. Post-scale solution by d_vec (common to both paths) + ! --------------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(n_loc_ri, n_local_grid, d_lp_local, d_vec_local) & + !$OMP PRIVATE(j_ri, i) & + !$OMP SCHEDULE(STATIC) + DO j_ri = 1, n_loc_ri + DO i = 1, n_local_grid + d_lp_local(i, j_ri) = d_lp_local(i, j_ri)*d_vec_local(i) + END DO + END DO + !$OMP END PARALLEL DO + + ! --------------------------------------------------------------------- + ! H. Scatter Local Solution Back to Global DBCSR Matrix + ! local_grid_idx is ascending (built by the ordered scan above), so a + ! single walking pointer over it sweeps the chunks in one pass. + ! Under ScaLAPACK (G>1) the d_lp_local solution is identical on all + ! G subgroup ranks (gathered via cp_fm_get_submatrix); only the + ! subgroup root writes to mat_Z_lP so each atom column is emitted + ! exactly once. DBCSR routes blocks to their global owner on finalize. + ! --------------------------------------------------------------------- + IF (n_procs_per_atom == 1 .OR. para_env_sub%mepos == 0) THEN + ALLOCATE (Z_blk(MAXVAL(r_blk_sizes), n_loc_ri)) + loc_ptr = 1 + + DO i_blk = 1, num_grid_chunks + r_start = row_offset(i_blk) + 1 + r_end = row_offset(i_blk) + r_blk_sizes(i_blk) + current_chunk_size = r_blk_sizes(i_blk) + + Z_blk = 0.0_dp + + DO WHILE (loc_ptr <= n_local_grid) + g = local_grid_idx(loc_ptr) + IF (g > r_end) EXIT + Z_blk(g - r_start + 1, 1:n_loc_ri) = d_lp_local(loc_ptr, 1:n_loc_ri) + loc_ptr = loc_ptr + 1 + END DO + + IF (MAXVAL(ABS(Z_blk(1:current_chunk_size, 1:n_loc_ri))) > bs_env%eps_filter) THEN + CALL dbcsr_put_block(mat_Z_lP, row=i_blk, col=atom_P, & + block=Z_blk(1:current_chunk_size, 1:n_loc_ri)) + END IF + END DO + + DEALLOCATE (Z_blk) + END IF + + DEALLOCATE (d_vec_local, d_lp_local) + DEALLOCATE (local_grid_idx, phi_local) + + END DO DEALLOCATE (cutoff_ri_per_atom) - DEALLOCATE (small_list, big_list) CALL gw_3c_ctx_release(ctx_3c) CALL dbcsr_finalize(mat_Z_lP) - CALL print_matrix_occupation(mat_Z_lP, 'Z(l,P)', para_env, bs_env%unit_nr) - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(A)') ' ' WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & 'Computed Z_lP ', ' Execution time', m_walltime() - t1, ' s' WRITE (bs_env%unit_nr, '(A)') ' ' @@ -1290,666 +1149,36 @@ CONTAINS DEALLOCATE (row_offset, ri_blk_sizes, col_dist_ri) CALL dbcsr_distribution_release(dist_Z) + IF (n_procs_per_atom > 1) THEN + CALL cp_blacs_env_release(blacs_env_sub) + CALL para_env_sub%free() + DEALLOCATE (para_env_sub) + END IF + DEALLOCATE (ri_rs_grid_points) CALL timestop(handle) END SUBROUTINE compute_coeff_Z_lP -! ************************************************************************************************** -!> \brief Prints the per-kind maximum RI-RS integration-sphere cutoff table. -!> \param bs_env ... -!> \param atomic_kind_set ... -!> \param particle_set ... -!> \param cutoff_ri_per_atom ... -! ************************************************************************************************** - SUBROUTINE print_sphere_cutoff_table(bs_env, atomic_kind_set, particle_set, cutoff_ri_per_atom) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: cutoff_ri_per_atom - CHARACTER(LEN=*), PARAMETER :: routineN = 'print_sphere_cutoff_table' - - INTEGER :: handle - - INTEGER :: iatom, ikind, nkind - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cutoff_ri_per_kind - - CALL timeset(routineN, handle) - - IF (bs_env%unit_nr <= 0) THEN - CALL timestop(handle) - RETURN - END IF - - nkind = SIZE(atomic_kind_set) - ALLOCATE (cutoff_ri_per_kind(nkind)) - cutoff_ri_per_kind(:) = 0.0_dp - - DO iatom = 1, SIZE(particle_set) - ikind = particle_set(iatom)%atomic_kind%kind_number - cutoff_ri_per_kind(ikind) = MAX(cutoff_ri_per_kind(ikind), cutoff_ri_per_atom(iatom)) - END DO - - WRITE (bs_env%unit_nr, '(T2,A)') 'Per-kind maximum RI-RS sphere cutoff (Å):' - WRITE (bs_env%unit_nr, '(T4,A4,A14)') 'Kind', 'cutoff (Å)' - DO ikind = 1, nkind - WRITE (bs_env%unit_nr, '(T4,A4,F14.4)') & - atomic_kind_set(ikind)%element_symbol, & - cutoff_ri_per_kind(ikind)*angstrom - END DO - WRITE (bs_env%unit_nr, '(A)') ' ' - - DEALLOCATE (cutoff_ri_per_kind) - - CALL timestop(handle) - - END SUBROUTINE print_sphere_cutoff_table - -! ************************************************************************************************** -!> \brief Splits the atoms of the Z_lP solve into a single-rank list ("small", Phase A: LAPACK -!> dpotrf/dpotrs on one rank) and a distributed list ("big", Phase B: ScaLAPACK -!> pdpotrf/pdpotrs over a rank subgroup of size G), and sizes G. -!> AUTO mode (N_PROCS_PER_ATOM_Z_LP <= 0, the default): estimate each atom's single-rank -!> peak memory -!> peak(P) = 8*n_local_grid(P)^2 (dense Gram matrix D_local) -!> + 8*n_local_grid(P)*n_ao (phi_local) -!> + 8*n_local_grid(P)*n_RI(P)*(1+n_threads) (d_lp + OMP partials) -!> and send atoms whose peak exceeds mem_safety * available-memory-per-proc to the -!> distributed path; G is auto-sized so the biggest atom's distributed D_local (/G) -!> fits alongside the replicated phi_local + d_lp. -!> MANUAL mode (> 0): 1 forces the single-rank path for every atom; > 1 keeps the -!> memory-based classification but forces that fixed subgroup size G. -!> In every mode G is floored by the ScaLAPACK 32-bit index limit (a local block-cyclic -!> slice of ~n_local_grid^2/G elements must stay below 2^31 or pdpotrf segfaults). -!> \param bs_env ... -!> \param para_env ... -!> \param ri_rs_grid_points ... -!> \param particle_set ... -!> \param cutoff_ri_per_atom ... -!> \param ri_blk_sizes per-atom ... -!> \param n_ao_total ... -!> \param n_local_grid_atom ... -!> \param small_list ... -!> \param n_small ... -!> \param big_list ... -!> \param n_big ... -!> \param G ... -! ************************************************************************************************** - SUBROUTINE classify_z_lp_atoms(bs_env, para_env, ri_rs_grid_points, particle_set, & - cutoff_ri_per_atom, ri_blk_sizes, n_ao_total, & - n_local_grid_atom, small_list, n_small, big_list, n_big, G) - -!$ USE OMP_LIB, ONLY: omp_get_max_threads - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(mp_para_env_type), POINTER :: para_env - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: ri_rs_grid_points - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: cutoff_ri_per_atom - INTEGER, DIMENSION(:), INTENT(IN) :: ri_blk_sizes - INTEGER, INTENT(IN) :: n_ao_total - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: n_local_grid_atom, small_list, big_list - INTEGER, INTENT(OUT) :: n_small, n_big, G - CHARACTER(LEN=*), PARAMETER :: routineN = 'classify_z_lp_atoms' - - INTEGER :: handle - - ! Conservative fraction of measured available memory usable per rank for the Z_lP - REAL(KIND=dp), PARAMETER :: mem_safety = 0.8_dp - - ! ScaLAPACK/BLACS index the per-rank local block-cyclic slice (~n_local_grid^2/G - ! elements) with 32-bit integers; keep it safely below 2^31 or pdpotrf segfaults. - REAL(KIND=dp), PARAMETER :: scalapack_loc_limit = 2.0E9_dp - - INTEGER :: G_atom, G_int32, G_int32_max, l, & - n_grid_total, n_local_grid, natom, & - nthreads_cls, P_loop_atom - LOGICAL :: auto_mode - REAL(KIND=dp) :: budget_bytes, cutoff_ri, dlp_bytes, & - mem_avail_GB, ng, nri, peak_bytes, & - phi_bytes - REAL(KIND=dp), DIMENSION(3) :: pos_P - - CALL timeset(routineN, handle) - - natom = SIZE(particle_set) - n_grid_total = SIZE(ri_rs_grid_points, 2) - - ! Per-atom sphere size: n_local_grid(P) = #{ l : |r_l - R_P| <= cutoff_ri(P) }. - ! It sets both the memory footprint (D_local is n_local_grid^2) and the solve - ! cost (~n_local_grid^3), so it drives classification and the LPT load balancing. - ALLOCATE (n_local_grid_atom(natom), small_list(natom), big_list(natom)) - DO P_loop_atom = 1, natom - pos_P(:) = particle_set(P_loop_atom)%r(:) - cutoff_ri = cutoff_ri_per_atom(P_loop_atom) - n_local_grid = 0 - DO l = 1, n_grid_total - IF (SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2) <= cutoff_ri**2) then - n_local_grid = n_local_grid + 1 - end if - END DO - n_local_grid_atom(P_loop_atom) = n_local_grid - END DO - - nthreads_cls = 1 -!$ nthreads_cls = omp_get_max_threads() - ! N_PROCS_PER_ATOM_Z_LP: -1 (default) = AUTO (classify by memory, auto-size G); - ! 1 = force single-rank BLAS for every atom; >1 = classify by memory but use this - ! fixed subgroup size G for the big atoms. - auto_mode = (bs_env%ri_rs%n_procs_per_atom_z_lp <= 0) - CALL ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) ! collective over all ranks - budget_bytes = mem_safety*mem_avail_GB*1.0E9_dp - - n_small = 0 - n_big = 0 - G = 1 - G_atom = 1 ! max G a big atom needs (memory + ScaLAPACK int32 floor) - G_int32_max = 1 ! max ScaLAPACK-int32 floor over the distributed atoms - IF (bs_env%ri_rs%n_procs_per_atom_z_lp == 1) THEN - ! Force single-rank BLAS for every atom. - DO P_loop_atom = 1, natom - n_small = n_small + 1 - small_list(n_small) = P_loop_atom - END DO - ELSE IF (mem_avail_GB <= 0.0_dp) THEN - ! No /proc/meminfo => cannot size by memory. - IF (auto_mode) THEN - IF (bs_env%unit_nr > 0) then - CPWARN("RI-RS Z_lP: no meminfo; single-rank solve for all atoms") - end if - DO P_loop_atom = 1, natom - n_small = n_small + 1 - small_list(n_small) = P_loop_atom - END DO - ELSE - ! Fixed G, no meminfo: distribute all atoms; still floor G by the int32 limit. - DO P_loop_atom = 1, natom - ng = REAL(n_local_grid_atom(P_loop_atom), dp) - G_int32_max = MAX(G_int32_max, CEILING(ng*ng/scalapack_loc_limit)) - n_big = n_big + 1 - big_list(n_big) = P_loop_atom - END DO - G = MIN(bs_env%ri_rs%n_procs_per_atom_z_lp, para_env%num_pe) - IF (G < G_int32_max) THEN - G = MIN(G_int32_max, para_env%num_pe) - IF (bs_env%unit_nr > 0) then - CPWARN("RI-RS Z_lP: raised G to avoid ScaLAPACK overflow") - end if - END IF - END IF - ELSE - ! Classify by memory: peak (D_local + phi_local + d_lp) vs budget. Small -> BLAS, - ! big -> distributed. Same classification for AUTO and fixed-G modes. - DO P_loop_atom = 1, natom - ng = REAL(n_local_grid_atom(P_loop_atom), dp) - nri = REAL(ri_blk_sizes(P_loop_atom), dp) - phi_bytes = 8.0_dp*ng*REAL(n_ao_total, dp) - dlp_bytes = 8.0_dp*ng*nri*REAL(1 + nthreads_cls, dp) - peak_bytes = 8.0_dp*ng*ng + phi_bytes + dlp_bytes - IF (peak_bytes <= budget_bytes) THEN - n_small = n_small + 1 - small_list(n_small) = P_loop_atom - ELSE - n_big = n_big + 1 - big_list(n_big) = P_loop_atom - ! G must satisfy BOTH: (a) memory — distributed D_local (/G) fits next to the - ! replicated phi_local + d_lp; (b) ScaLAPACK — local ~ng^2/G below the int32 limit. - G_int32 = CEILING(ng*ng/scalapack_loc_limit) - G_int32_max = MAX(G_int32_max, G_int32) - G_atom = MAX(G_atom, G_int32, & - CEILING(8.0_dp*ng*ng/MAX(budget_bytes - phi_bytes - dlp_bytes, 1.0_dp))) - END IF - END DO - IF (n_big > 0) THEN - IF (auto_mode) THEN - ! Auto-size G from the most demanding big atom. - IF (G_atom > para_env%num_pe) THEN - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A)') & - 'RI-RS Z_lP: an atom is too large to fit even distributed over all '// & - 'ranks. Add nodes, use fewer MPI ranks/node, lower CUTOFF_RADIUS_RL_RI, '// & - 'or raise EPS_FILTER (more grid screening).' - END IF - CPABORT("RI-RS Z_lP: atom too large even fully distributed") - END IF - G = MIN(MAX(G_atom, 2), para_env%num_pe) - ELSE - ! Fixed G from the keyword. Hard-floor by the ScaLAPACK int32 limit (below it - ! pdpotrf segfaults); warn if it is still below the memory recommendation. - G = MIN(bs_env%ri_rs%n_procs_per_atom_z_lp, para_env%num_pe) - IF (G < G_int32_max) THEN - G = MIN(G_int32_max, para_env%num_pe) - IF (bs_env%unit_nr > 0) then - CPWARN("RI-RS Z_lP: raised G to avoid ScaLAPACK overflow") - end if - ELSE IF (G < G_atom .AND. bs_env%unit_nr > 0) THEN - CPWARN("RI-RS Z_lP: N_PROCS_PER_ATOM_Z_LP too small for the largest atom") - END IF - END IF - END IF - END IF - - CALL timestop(handle) - - END SUBROUTINE classify_z_lp_atoms - -! ************************************************************************************************** -!> \brief Builds the sphere-local AO matrix phi_local(l, μ) = Φ_μ(r_l) for one RI atom P -!> \param bs_env ... -!> \param particle_set ... -!> \param qs_kind_set ... -!> \param cell ... -!> \param ri_rs_grid_points ... -!> \param atom_P ... -!> \param cutoff_ri ... -!> \param n_ao_total ... -!> \param local_grid_idx ... -!> \param n_local_grid ... -!> \param phi_local ... -! ************************************************************************************************** - SUBROUTINE build_phi_on_sphere(bs_env, particle_set, qs_kind_set, cell, ri_rs_grid_points, & - atom_P, cutoff_ri, n_ao_total, local_grid_idx, n_local_grid, & - phi_local) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set - TYPE(cell_type), POINTER :: cell - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: ri_rs_grid_points - INTEGER, INTENT(IN) :: atom_P - REAL(KIND=dp), INTENT(IN) :: cutoff_ri - INTEGER, INTENT(IN) :: n_ao_total - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: local_grid_idx - INTEGER, INTENT(OUT) :: n_local_grid - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), & - INTENT(OUT) :: phi_local - - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_phi_on_sphere' - - INTEGER :: col_end, col_start, handle, j, k, l, & - loc_idx, n_grid_total, n_keep, & - source_atom - REAL(KIND=dp) :: d_sP, dist, r2_threshold - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: w_pt - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: phi_keep, sphere_grid - REAL(KIND=dp), DIMENSION(3) :: pos_P - - CALL timeset(routineN, handle) - - n_grid_total = SIZE(ri_rs_grid_points, 2) - pos_P(:) = particle_set(atom_P)%r(:) - - n_local_grid = 0 - DO l = 1, n_grid_total - dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) - IF (dist <= cutoff_ri) n_local_grid = n_local_grid + 1 - END DO - - ALLOCATE (local_grid_idx(n_local_grid)) - - n_local_grid = 0 - DO l = 1, n_grid_total - dist = SQRT(SUM((ri_rs_grid_points(1:3, l) - pos_P(1:3))**2)) - IF (dist <= cutoff_ri) THEN - n_local_grid = n_local_grid + 1 - local_grid_idx(n_local_grid) = l - END IF - END DO - - ALLOCATE (sphere_grid(3, n_local_grid)) - DO loc_idx = 1, n_local_grid - sphere_grid(:, loc_idx) = ri_rs_grid_points(:, local_grid_idx(loc_idx)) - END DO - - ALLOCATE (phi_local(n_local_grid, n_ao_total)) - phi_local = 0.0_dp - - DO source_atom = 1, SIZE(particle_set) - d_sP = NORM2(particle_set(source_atom)%r(:) - pos_P(:)) - IF (d_sP > bs_env%ri_rs%radius_ao_per_atom(source_atom) + cutoff_ri) CYCLE - - col_start = bs_env%i_ao_start_from_atom(source_atom) - col_end = bs_env%i_ao_end_from_atom(source_atom) - ! A positive CUTOFF_RADIUS_RI_AO overrides the per-atom Gaussian radius - ! with a user-defined hard cutoff. - IF (bs_env%ri_rs%cutoff_radius_ri_ao > 0.0_dp) THEN - r2_threshold = bs_env%ri_rs%cutoff_radius_ri_ao**2 - ELSE - r2_threshold = bs_env%ri_rs%radius_ao_per_atom(source_atom)**2 - END IF - - CALL fill_phi_for_atom(phi_local(:, col_start:col_end), sphere_grid, & - n_local_grid, source_atom, particle_set, qs_kind_set, & - cell, r2_threshold) - END DO - - DEALLOCATE (sphere_grid) - - IF (n_local_grid > 0) THEN - ALLOCATE (w_pt(n_local_grid)) - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, n_ao_total, phi_local, w_pt) & - !$OMP PRIVATE(l, j) SCHEDULE(STATIC) - DO l = 1, n_local_grid - w_pt(l) = 0.0_dp - DO j = 1, n_ao_total - w_pt(l) = MAX(w_pt(l), ABS(phi_local(l, j))) - END DO - END DO - !$OMP END PARALLEL DO - n_keep = COUNT(w_pt > bs_env%eps_filter) - IF (n_keep < n_local_grid) THEN - ALLOCATE (phi_keep(n_keep, n_ao_total)) - k = 0 - DO l = 1, n_local_grid - IF (w_pt(l) > bs_env%eps_filter) THEN - k = k + 1 - phi_keep(k, :) = phi_local(l, :) - local_grid_idx(k) = local_grid_idx(l) - END IF - END DO - CALL MOVE_ALLOC(phi_keep, phi_local) - n_local_grid = n_keep - END IF - DEALLOCATE (w_pt) - END IF - - CALL timestop(handle) - - END SUBROUTINE build_phi_on_sphere - -! ************************************************************************************************** -!> \brief Builds the dense Jacobi-conditioned Gram matrix and the conditioning vector for the -!> single-rank (BLAS/LAPACK) Z_lP solve: -!> D_ll' = [ Σ_μ Φ_μ(r_l) Φ_μ(r_l') ]² (dsyrk of phi_local, then squared) -!> d_l = 1 / sqrt(D_ll) -!> D'_ll' = d_l D_ll' d_l' + λ δ_ll' -!> Only the lower triangle is referenced by the subsequent dpotrf('L') -!> \param phi_local ... -!> \param n_local_grid ... -!> \param n_ao_total ... -!> \param tikhonov ... -!> \param D_local ... -!> \param d_vec_local ... -! ************************************************************************************************** - SUBROUTINE build_gram_jacobi_blas(phi_local, n_local_grid, n_ao_total, tikhonov, D_local, & - d_vec_local) - - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: phi_local - INTEGER, INTENT(IN) :: n_local_grid, n_ao_total - REAL(KIND=dp), INTENT(IN) :: tikhonov - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), & - INTENT(OUT) :: D_local - REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: d_vec_local - - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_gram_jacobi_blas' - - INTEGER :: handle, handle_dsyrk, i, j - - CALL timeset(routineN, handle) - - ALLOCATE (D_local(n_local_grid, n_local_grid)) - D_local = 0.0_dp - - ! D_ll' = Σ_μ Φ_μ(r_l) Φ_μ(r_l') (lower triangle only) - CALL timeset(routineN//"_dsyrk", handle_dsyrk) - CALL dsyrk("L", "N", n_local_grid, n_ao_total, 1.0_dp, phi_local, & - n_local_grid, 0.0_dp, D_local, n_local_grid) - CALL timestop(handle_dsyrk) - - ! Diagonal: square, derive d_l = 1/sqrt(D_ll), scale, add Tikhonov λ - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, D_local, d_vec_local, tikhonov) & - !$OMP PRIVATE(i) & - !$OMP SCHEDULE(STATIC) - DO i = 1, n_local_grid - D_local(i, i) = D_local(i, i)**2 - d_vec_local(i) = 1.0_dp/SQRT(MAX(D_local(i, i), 1.0E-16_dp)) - D_local(i, i) = (D_local(i, i)*d_vec_local(i)**2) + tikhonov - END DO - !$OMP END PARALLEL DO - - ! Off-diagonal: D'_ll' = d_l D_ll'^2 d_l' (mirror to the upper triangle) - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, D_local, d_vec_local) & - !$OMP PRIVATE(j, i) & - !$OMP SCHEDULE(DYNAMIC) - DO j = 1, n_local_grid - DO i = j + 1, n_local_grid - D_local(i, j) = D_local(i, j)**2 - D_local(i, j) = D_local(i, j)*d_vec_local(i)*d_vec_local(j) - D_local(j, i) = D_local(i, j) - END DO - END DO - !$OMP END PARALLEL DO - - CALL timestop(handle) - - END SUBROUTINE build_gram_jacobi_blas - -! ************************************************************************************************** -!> \brief Computes the Jacobi conditioning vector directly from phi for the distributed -!> (ScaLAPACK) Z_lP solve: d_l = 1 / Σ_μ Φ_μ(r_l)² = 1/sqrt(D_ll), without forming -!> the Gram matrix. -!> \param phi_local ... -!> \param n_local_grid ... -!> \param n_ao_total ... -!> \param d_vec_local ... -! ************************************************************************************************** - SUBROUTINE build_jacobi_diag_from_phi(phi_local, n_local_grid, n_ao_total, d_vec_local) - - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: phi_local - INTEGER, INTENT(IN) :: n_local_grid, n_ao_total - REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: d_vec_local - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_jacobi_diag_from_phi' - - INTEGER :: handle - - INTEGER :: i, j - - CALL timeset(routineN, handle) - - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_local_grid, n_ao_total, phi_local, d_vec_local) & - !$OMP PRIVATE(i, j) & - !$OMP SCHEDULE(STATIC) - DO i = 1, n_local_grid - d_vec_local(i) = 0.0_dp - DO j = 1, n_ao_total - d_vec_local(i) = d_vec_local(i) + phi_local(i, j)*phi_local(i, j) - END DO - d_vec_local(i) = 1.0_dp/MAX(d_vec_local(i), 1.0E-16_dp) - END DO - !$OMP END PARALLEL DO - - CALL timestop(handle) - - END SUBROUTINE build_jacobi_diag_from_phi - -! ************************************************************************************************** -!> \brief Scales every row of a matrix by the corresponding diagonal entry, -!> A(l, :) <- d_l * A(l, :). Used in Z_lP solve: to pre-scale the RHS -!> (D'_lP = d_l D_lP) and to undo the conditioning of the solution (Z_lP = d_l Z'_lP). -!> \param d_lp_local ... -!> \param d_vec_local ... -!> \param n_local_grid ... -!> \param n_loc_ri ... -! ************************************************************************************************** - SUBROUTINE scale_rows_by_diag(d_lp_local, d_vec_local, n_local_grid, n_loc_ri) - - REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: d_lp_local - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: d_vec_local - INTEGER, INTENT(IN) :: n_local_grid, n_loc_ri - CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_rows_by_diag' - - INTEGER :: handle - - INTEGER :: i, j_ri - - CALL timeset(routineN, handle) - - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(n_loc_ri, n_local_grid, d_lp_local, d_vec_local) & - !$OMP PRIVATE(j_ri, i) & - !$OMP SCHEDULE(STATIC) - DO j_ri = 1, n_loc_ri - DO i = 1, n_local_grid - d_lp_local(i, j_ri) = d_lp_local(i, j_ri)*d_vec_local(i) - END DO - END DO - !$OMP END PARALLEL DO - - CALL timestop(handle) - - END SUBROUTINE scale_rows_by_diag - -! ************************************************************************************************** -!> \brief Scatters the solved Z columns of one atom P from the dense sphere-local solution back -!> into the global sparse mat_Z_lP -!> \param mat_Z_lP ... -!> \param d_lp_local ... -!> \param local_grid_idx ... -!> \param n_local_grid ... -!> \param n_loc_ri ... -!> \param atom_P ... -!> \param r_blk_sizes ... -!> \param row_offset ... -!> \param eps_filter ... -! ************************************************************************************************** - SUBROUTINE scatter_z_columns(mat_Z_lP, d_lp_local, local_grid_idx, n_local_grid, n_loc_ri, & - atom_P, r_blk_sizes, row_offset, eps_filter) - - TYPE(dbcsr_type), INTENT(INOUT) :: mat_Z_lP - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: d_lp_local - INTEGER, DIMENSION(:), INTENT(IN) :: local_grid_idx - INTEGER, INTENT(IN) :: n_local_grid, n_loc_ri, atom_P - INTEGER, DIMENSION(:), INTENT(IN) :: r_blk_sizes, row_offset - REAL(KIND=dp), INTENT(IN) :: eps_filter - CHARACTER(LEN=*), PARAMETER :: routineN = 'scatter_z_columns' - INTEGER :: handle - - INTEGER :: current_chunk_size, g_pt, i_blk, & - loc_ptr, r_end, r_start - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Z_blk - - CALL timeset(routineN, handle) - - ALLOCATE (Z_blk(MAXVAL(r_blk_sizes), n_loc_ri)) - loc_ptr = 1 - - DO i_blk = 1, SIZE(r_blk_sizes) - r_start = row_offset(i_blk) + 1 - r_end = row_offset(i_blk) + r_blk_sizes(i_blk) - current_chunk_size = r_blk_sizes(i_blk) - - Z_blk = 0.0_dp - - ! Copy the sphere points whose global grid index falls inside this block - DO WHILE (loc_ptr <= n_local_grid) - g_pt = local_grid_idx(loc_ptr) - IF (g_pt > r_end) EXIT - Z_blk(g_pt - r_start + 1, 1:n_loc_ri) = d_lp_local(loc_ptr, 1:n_loc_ri) - loc_ptr = loc_ptr + 1 - END DO - - IF (MAXVAL(ABS(Z_blk(1:current_chunk_size, 1:n_loc_ri))) > eps_filter) THEN - CALL dbcsr_put_block(mat_Z_lP, row=i_blk, col=atom_P, & - block=Z_blk(1:current_chunk_size, 1:n_loc_ri)) - END IF - END DO - - DEALLOCATE (Z_blk) - - CALL timestop(handle) - - END SUBROUTINE scatter_z_columns - -! ************************************************************************************************** -!> \brief LPT (longest-processing-time) assignment of the Z_lP atoms to workers (MPI ranks in -!> Phase A, rank subgroups in Phase B): sort by estimated solve cost n_local_grid^3 -!> (the per-atom Cholesky dominates; the n^2 assembly terms order the atoms the same -!> way) and greedily give each atom to the least-loaded worker. -!> \param atom_list ... -!> \param n_atoms ... -!> \param n_local_grid_atom ... -!> \param n_workers ... -!> \param my_worker ... -!> \param my_atoms ... -!> \param max_over_mean ... -! ************************************************************************************************** - SUBROUTINE lpt_assign_atoms(atom_list, n_atoms, n_local_grid_atom, n_workers, my_worker, & - my_atoms, max_over_mean) - - INTEGER, DIMENSION(:), INTENT(IN) :: atom_list - INTEGER, INTENT(IN) :: n_atoms - INTEGER, DIMENSION(:), INTENT(IN) :: n_local_grid_atom - INTEGER, INTENT(IN) :: n_workers, my_worker - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: my_atoms - REAL(KIND=dp), INTENT(OUT) :: max_over_mean - CHARACTER(LEN=*), PARAMETER :: routineN = 'lpt_assign_atoms' - INTEGER :: handle - - INTEGER :: i, iw, n_mine, w_min - INTEGER, ALLOCATABLE, DIMENSION(:) :: mine_tmp, perm - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: cost, load - - CALL timeset(routineN, handle) - - max_over_mean = 1.0_dp - IF (n_atoms <= 0) THEN - ALLOCATE (my_atoms(0)) - CALL timestop(handle) - RETURN - END IF - - ALLOCATE (cost(n_atoms), perm(n_atoms), mine_tmp(n_atoms), load(n_workers)) - DO i = 1, n_atoms - cost(i) = REAL(n_local_grid_atom(atom_list(i)), dp)**3 - END DO - CALL sort(cost, n_atoms, perm) ! ascending; walk backwards for largest-first - - load(:) = 0.0_dp - n_mine = 0 - DO i = n_atoms, 1, -1 - w_min = 1 - DO iw = 2, n_workers - IF (load(iw) < load(w_min)) w_min = iw - END DO - load(w_min) = load(w_min) + cost(i) - IF (w_min - 1 == my_worker) THEN - n_mine = n_mine + 1 - mine_tmp(n_mine) = atom_list(perm(i)) - END IF - END DO - - ALLOCATE (my_atoms(n_mine)) - my_atoms(:) = mine_tmp(1:n_mine) - IF (SUM(load) > 0.0_dp) max_over_mean = MAXVAL(load)*REAL(n_workers, dp)/SUM(load) - - CALL timestop(handle) - - END SUBROUTINE lpt_assign_atoms - ! ************************************************************************************************** !> \brief Computes the dense localized RHS d_lp(l,P) = Σ_{μν} Φ_μ(r_l)·Φ_ν(r_l)·(μν|P) for one !> RI atom P, OMP-threaded over (atom_j, atom_k) AO-pair blocks: per thread, build the 3c !> block, then contract grid-chunked pair densities into a private d_lp partial; partials !> are reduced into d_lp at the end. -!> Pair screening is handled inside build_3c_integral_block_ctx via the `screened` output. +!> Pair screening is handled inside build_3c_integral_block_ctx via the `screened` output, !> \param bs_env ... -!> \param ctx ... -!> \param phi_val ... -!> \param d_lp ... -!> \param n_grid_total ... -!> \param n_loc_ri ... +!> \param ctx shared 3c-integral context (gw_3c_ctx_create) +!> \param phi_val Φ_μ(r_l) on the local-sphere grid (n_grid_total × n_ao) +!> \param d_lp output (n_grid_total × n_loc_ri), zeroed by the caller, accumulated here +!> \param n_grid_total number of local-sphere grid rows +!> \param n_loc_ri number of RI functions of atom_P !> \param atom_P ... !> \param max_ao_size ... !> \param atom_j_mepos ... !> \param atom_j_stride ... ! ************************************************************************************************** + SUBROUTINE compute_d_lp(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, & max_ao_size, atom_j_mepos, atom_j_stride) @@ -1964,12 +1193,11 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_d_lp' INTEGER, PARAMETER :: grid_chunk = 1024 - INTEGER :: atom_j, atom_k, c, handle, & - handle_dgemm, j, jk_idx, & + INTEGER :: atom_j, atom_k, c, handle, j, jk_idx, & jsize, jstart, k, ksize, kstart, l, & l0, ri LOGICAL :: screened - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: d_lp_prv, int_2d_prv, rho_chunk + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: int_2d_prv, rho_chunk REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: int_3c_prv TYPE(gw_3c_ws_type) :: ws @@ -1978,20 +1206,20 @@ CONTAINS !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, max_ao_size, & !$OMP atom_j_mepos, atom_j_stride) & - !$OMP PRIVATE(atom_j, atom_k, c, handle_dgemm, j, jk_idx, jsize, jstart, k, ksize, kstart, & - !$OMP l, l0, ri, screened, d_lp_prv, int_2d_prv, rho_chunk, int_3c_prv, ws) + !$OMP PRIVATE(atom_j, atom_k, c, j, jk_idx, jsize, jstart, k, ksize, kstart, l, l0, ri, & + !$OMP screened, int_2d_prv, rho_chunk, int_3c_prv, ws) CALL gw_3c_ws_create(ws, ctx) ALLOCATE (int_3c_prv(max_ao_size, max_ao_size, n_loc_ri)) ALLOCATE (int_2d_prv(max_ao_size*max_ao_size, n_loc_ri)) ALLOCATE (rho_chunk(grid_chunk, max_ao_size*max_ao_size)) - ALLOCATE (d_lp_prv(n_grid_total, n_loc_ri)) - d_lp_prv(:, :) = 0.0_dp ! MPI-stride atom_j over the subgroup (atom_j_stride = 1 for the BLAS ! path, > 1 for the ScaLAPACK path). The OMP DO parallelizes the inner - ! atom_k while the outer atom_j carries the MPI stride. - !$OMP DO SCHEDULE(DYNAMIC) + ! atom_k while the outer atom_j carries the MPI stride. COLLAPSE(2) is + ! dropped because the outer stride is non-unit under ScaLAPACK; for + ! typical natom the inner loop has plenty of work for DYNAMIC. + !$OMP DO SCHEDULE(DYNAMIC) REDUCTION(+:d_lp) DO atom_j = atom_j_mepos + 1, SIZE(bs_env%i_ao_start_from_atom), atom_j_stride DO atom_k = 1, SIZE(bs_env%i_ao_start_from_atom) jstart = bs_env%i_ao_start_from_atom(atom_j) @@ -2032,23 +1260,16 @@ CONTAINS END DO END DO END DO - CALL timeset(routineN//"_dgemm", handle_dgemm) CALL dgemm("N", "N", c, n_loc_ri, jsize*ksize, & 1.0_dp, rho_chunk, grid_chunk, & int_2d_prv, max_ao_size*max_ao_size, & - 1.0_dp, d_lp_prv(l0, 1), n_grid_total) - CALL timestop(handle_dgemm) + 1.0_dp, d_lp(l0, 1), n_grid_total) END DO END DO END DO !$OMP END DO - !$OMP CRITICAL (compute_d_lp_reduce) - d_lp(1:n_grid_total, 1:n_loc_ri) = d_lp(1:n_grid_total, 1:n_loc_ri) + & - d_lp_prv(1:n_grid_total, 1:n_loc_ri) - !$OMP END CRITICAL (compute_d_lp_reduce) - - DEALLOCATE (int_3c_prv, int_2d_prv, rho_chunk, d_lp_prv) + DEALLOCATE (int_3c_prv, int_2d_prv, rho_chunk) CALL gw_3c_ws_release(ws) !$OMP END PARALLEL @@ -2059,28 +1280,29 @@ CONTAINS ! ************************************************************************************************** !> \brief Distributed pdpotrf/pdpotrs solve of D x = b for one atom of the -!> RI-RS Z_lP build (Phase B, "big" atoms), called with a subgroup of -!> cooperating ranks and an associated BLACS context. +!> RI-RS Z_lP build. Called when N_PROCS_PER_ATOM_Z_LP > 1, with a +!> subgroup of cooperating ranks and an associated BLACS context. !> Each rank in the subgroup holds the (replicated) phi_local and the !> (replicated) RHS d_lp; it builds its own block-cyclic slice of the !> squared+Jacobi-scaled Gram matrix D via tiled DGEMM, factorizes via !> cp_fm_cholesky_decompose (UPLO='U'), and solves with !> cp_fm_cholesky_solve. The replicated d_lp is updated in place via !> cp_fm_get_submatrix. -!> \param phi_local ... -!> \param d_vec ... -!> \param d_lp ... -!> \param n_loc ... -!> \param n_ao ... -!> \param n_rhs ... -!> \param tikhonov ... -!> \param para_env_sub ... -!> \param blacs_env_sub ... +!> \param phi_local replicated (n_loc x n_ao) AO values on the sphere grid +!> \param d_vec replicated Jacobi diagonal = 1 / ||phi_i||^2 +!> \param d_lp replicated RHS in/out (n_loc x n_rhs); on input pre-scaled +!> by d_vec, on output also pre-scaled (caller post-scales) +!> \param n_loc number of sphere-local grid points +!> \param n_ao number of AO basis functions +!> \param n_rhs number of RI functions of this atom_P (RHS columns) +!> \param tikhonov regularisation added to the diagonal +!> \param para_env_sub sub-communicator of the atom-group +!> \param blacs_env_sub BLACS context on the sub-communicator !> \param fm_struct_D ... !> \param fm_struct_b ... !> \param fm_D ... !> \param fm_b ... -!> \param info ... +!> \param info 0 on success, non-zero if pdpotrf or pdpotrs failed ! ************************************************************************************************** SUBROUTINE solve_D_lp_distributed(phi_local, d_vec, d_lp, n_loc, n_ao, n_rhs, & tikhonov, para_env_sub, blacs_env_sub, & @@ -2131,7 +1353,7 @@ CONTAINS IF (nrow_local > 0 .AND. ncol_local > 0) THEN BLOCK INTEGER, PARAMETER :: ntile = 1024 - INTEGER :: ib, ie, jb, je, mb, kb, ti, tj, handle_dgemm + INTEGER :: ib, ie, jb, je, mb, kb, ti, tj REAL(KIND=dp), ALLOCATABLE :: gram_t(:, :), phi_cols_t(:, :), phi_rows_t(:, :) ALLOCATE (phi_rows_t(ntile, n_ao), phi_cols_t(n_ao, ntile), gram_t(ntile, ntile)) DO ib = 1, nrow_local, ntile @@ -2158,11 +1380,9 @@ CONTAINS END DO END DO !$OMP END PARALLEL DO - CALL timeset(routineN//"_dgemm", handle_dgemm) CALL dgemm('N', 'N', mb, kb, n_ao, & 1.0_dp, phi_rows_t, ntile, phi_cols_t, n_ao, & 0.0_dp, gram_t, ntile) - CALL timestop(handle_dgemm) !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(mb, kb, gram_t, d_vec, row_indices, col_indices, ib, jb) & !$OMP SHARED(local_data, tikhonov) & @@ -2186,23 +1406,23 @@ CONTAINS END BLOCK END IF - ! Load the replicated d_lp into the block-cyclic fm_b + ! ---- Load the replicated d_lp into the block-cyclic fm_b ----------- CALL cp_fm_set_submatrix(fm_b, d_lp) - ! pdpotrf (Cholesky factorisation; cp_fm_cholesky_decompose - ! factors with UPLO='U', so pdpotrs must match) + ! ---- pdpotrf (Cholesky factorisation; cp_fm_cholesky_decompose + ! factors with UPLO='U', so pdpotrs must match) CALL cp_fm_cholesky_decompose(fm_D, n=n_loc, info_out=info) IF (info /= 0) THEN CPABORT("pdpotrf failed in solve_D_lp_distributed") END IF - ! pdpotrs/dpotrs (solve in place on fm_b) + ! ---- pdpotrs/dpotrs (solve in place on fm_b) ----------------------- CALL cp_fm_cholesky_solve(fm_D, fm_b, n=n_loc, info_out=info) IF (info /= 0) THEN CPABORT("pdpotrs failed in solve_D_lp_distributed") END IF - ! Gather distributed solution back into the replicated d_lp + ! ---- Gather distributed solution back into the replicated d_lp ---- CALL cp_fm_get_submatrix(fm_b, d_lp) CALL cp_fm_release(fm_D) @@ -2215,17 +1435,13 @@ CONTAINS END SUBROUTINE solve_D_lp_distributed ! ************************************************************************************************** -!> \brief Computes the polarizability matrix in the RI basis for every -!> imaginary-time point: -!> G^occ/vir_μν(i|τ|) = Σ_n C_μn e^(-|(ϵ_n-ϵ_F)τ|) C_νn (AO x AO, build_G_ao) -!> χ_ll'(iτ) = [Σ_μν Φ_μ(r_l) G^occ_μν Φ_ν(r_l')] ∘ [Σ_μν Φ_μ(r_l) G^vir_μν Φ_ν(r_l')] -!> χ_PQ(iτ) = g_s Σ_ll' Z_lP χ_ll'(iτ) Z_l'Q (g_s = spin degeneracy) -!> The grid (l) index is streamed in panels (contract_grid_panels). +!> \brief Computes the χ(iτ) matrix !> \param bs_env ... !> \param mat_chi_Gamma_tau ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... ! ************************************************************************************************** + SUBROUTINE get_mat_chi_Gamma_tau(bs_env, mat_chi_Gamma_tau, mat_phi_mu_l, mat_Z_lP) TYPE(post_scf_bandstructure_type), POINTER :: bs_env @@ -2234,71 +1450,82 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'get_mat_chi_Gamma_tau' - INTEGER :: handle, i_t, ispin, n_panels - INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last - REAL(KIND=dp) :: grid_occ, t1, tau - TYPE(dbcsr_type) :: matrix_G_occ_ao, matrix_G_vir_ao + INTEGER :: handle, i, i_t, ispin, npcol + INTEGER, DIMENSION(:), POINTER :: blk_ao, blk_grid, dist_col_ao, & + dist_col_grid, dist_row_grid + REAL(KIND=dp) :: t1, tau + TYPE(dbcsr_distribution_type) :: dist_grid_grid, dist_phi + TYPE(dbcsr_type) :: matrix_chi_grid, matrix_chi_grid_spin, & + matrix_G_occ_grid, matrix_G_vir_grid CALL timeset(routineN, handle) - ! Panel boundaries for the grid-streaming contraction. - ! The panels are identical for χ, Σ^x and Σ^c, so the count is reported once here for all three stages. + ! ========================================================================= + ! 1. SETUP CORE TOPOLOGIES + ! ========================================================================= + CALL dbcsr_get_info(mat_phi_mu_l, distribution=dist_phi, row_blk_size=blk_grid, col_blk_size=blk_ao) + CALL dbcsr_distribution_get(dist_phi, row_dist=dist_row_grid, col_dist=dist_col_ao) - CALL resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) + ! Determine number of MPI process columns + npcol = MAXVAL(dist_col_ao) + 1 - n_panels = SIZE(pan_first) - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,I44)') 'Number of batches for χ, Σ matrices', n_panels - CALL m_flush(bs_env%unit_nr) - END IF + ! Build a perfectly safe column distribution for the Grid dimension + ALLOCATE (dist_col_grid(SIZE(blk_grid))) + DO i = 1, SIZE(blk_grid) + dist_col_grid(i) = MOD(i - 1, npcol) + END DO + + CALL dbcsr_distribution_new(dist_grid_grid, template=dist_phi, & + row_dist=dist_row_grid, col_dist=dist_col_grid) + + CALL dbcsr_create(matrix_G_occ_grid, "G_occ_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + CALL dbcsr_create(matrix_G_vir_grid, "G_vir_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + CALL dbcsr_create(matrix_chi_grid, "chi_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + CALL dbcsr_create(matrix_chi_grid_spin, "chi_grid_spin", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) ! ========================================================================= - ! IMAGINARY TIME LOOP - ! χ_PQ(iτ) = Σ_s g_s · Z^T ( (φ G^occ_s φ^T) ∘ (φ G^vir_s φ^T) ) Z - ! (g_s = spin degeneracy) + ! 2. MAIN IMAGINARY TIME LOOP ! ========================================================================= DO i_t = 1, bs_env%num_time_freq_points t1 = m_walltime() - tau = bs_env%imag_time_points(i_t) + tau = bs_env%imag_time_points(i_t) + CALL dbcsr_set(matrix_chi_grid, 0.0_dp) + + ! ---------------------------------------------------------------------- + ! A. SPIN LOOP (Allocations safely encapsulated in wrappers) + ! ---------------------------------------------------------------------- DO ispin = 1, bs_env%n_spin - ! AO-space Green's functions G^occ_µν, G^vir_µν (dense AO x AO, small) - CALL build_G_ao(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_G_occ_ao) - CALL build_G_ao(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, matrix_G_vir_ao) + ! G^occ_µλ(i|τ|) = sum_n^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + ! G^occ_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') + CALL build_G_grid(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, & + matrix_G_occ_grid, bs_env%eps_filter) - ! χ_PQ += g_s · Z^T ( (φ G^occ φ^T) ∘ (φ G^vir φ^T) ) Z - CALL contract_grid_panels(L_A=mat_phi_mu_l, M_A=matrix_G_occ_ao, & - L_B=mat_phi_mu_l, M_B=matrix_G_vir_ao, & - L_out=mat_Z_lP, mat_out=mat_chi_Gamma_tau(i_t)%matrix, & - scale=bs_env%spin_degeneracy, eps=bs_env%eps_filter, & - para_env=bs_env%para_env, & - pan_first=pan_first, pan_last=pan_last, & - lb_eq_la=.TRUE., lout_eq_la=.FALSE., & - zero_out=(ispin == 1), & - keep_sparsity=bs_env%ri_rs%keep_sparsity_rirs, & - centroids=bs_env%ri_rs%chunk_centroids, & - cutoff=bs_env%ri_rs%cutoff_radius_v_w, & - grid_occupation=grid_occ) + ! G^vir_µλ(i|τ|) = sum_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + ! G^vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^vir_µν Φ_ν(r_l') + CALL build_G_grid(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, & + matrix_G_vir_grid, bs_env%eps_filter) - CALL dbcsr_release(matrix_G_occ_ao) - CALL dbcsr_release(matrix_G_vir_ao) + ! ------------------------------------------------------------------- + ! B. ELEMENT-WISE HADAMARD PRODUCT + ! ------------------------------------------------------------------- + ! χ_ll'(iτ) = G^occ_ll'(i|τ|) * G^vir_ll'(i|τ|) + CALL hadamard_product(matrix_G_occ_grid, matrix_G_vir_grid, matrix_chi_grid_spin, bs_env%spin_degeneracy) + + ! Accumulate spin contributions + CALL dbcsr_add(matrix_chi_grid, matrix_chi_grid_spin, 1.0_dp, 1.0_dp) END DO ! ispin - ! Sparsity reports - IF (i_t == 1 .AND. bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(A)') ' ' - WRITE (bs_env%unit_nr, '(T2,A,F17.2,A)') & - 'Occupation of non-zero elements of G(l,l''), χ(l,l''), W(l,l'')', & - grid_occ*100.0_dp, ' %' - WRITE (bs_env%unit_nr, '(A)') ' ' - CALL m_flush(bs_env%unit_nr) - END IF - IF (i_t == 1) then - CALL print_matrix_occupation(mat_chi_Gamma_tau(i_t)%matrix, 'χ(P,Q)', & - bs_env%para_env, bs_env%unit_nr) - end if + ! ---------------------------------------------------------------------- + ! C. TRANSFORM TO AUXILIARY BASIS & EXPORT DIRECTLY + ! χ_aux = Z^T * χ_grid * Z + ! χ_PQ(iτ) = sum_ll' Z_lP χ_ll'(iτ) Z_l'Q + ! Result is dumped into the final array mat_chi_Gamma_tau! + ! ---------------------------------------------------------------------- + CALL contract_A_B_A("T", "N", mat_Z_lP, matrix_chi_grid, & + mat_chi_Gamma_tau(i_t)%matrix, bs_env%eps_filter) IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,I13,A,I3,A,F7.1,A)') & @@ -2308,6 +1535,16 @@ CONTAINS END DO ! i_t + ! ========================================================================= + ! 3. FINAL CLEANUP + ! ========================================================================= + CALL dbcsr_release(matrix_G_occ_grid) + CALL dbcsr_release(matrix_G_vir_grid) + CALL dbcsr_release(matrix_chi_grid) + CALL dbcsr_release(matrix_chi_grid_spin) + CALL dbcsr_distribution_release(dist_grid_grid) + DEALLOCATE (dist_col_grid) + IF (bs_env%unit_nr > 0) WRITE (bs_env%unit_nr, '(A)') ' ' CALL timestop(handle) @@ -2315,1488 +1552,115 @@ CONTAINS END SUBROUTINE get_mat_chi_Gamma_tau ! ************************************************************************************************** -!> \brief Prints the non-zero occupation percentage of a DBCSR matrix on one line. -!> \param matrix ... -!> \param label ... -!> \param para_env ... -!> \param unit_nr ... -! ************************************************************************************************** - SUBROUTINE print_matrix_occupation(matrix, label, para_env, unit_nr) - - TYPE(dbcsr_type), INTENT(IN) :: matrix - CHARACTER(LEN=*), INTENT(IN) :: label - TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env - INTEGER, INTENT(IN) :: unit_nr - CHARACTER(LEN=*), PARAMETER :: routineN = 'print_matrix_occupation' - - INTEGER :: handle - - REAL(KIND=dp) :: frac_2p31, max_loc, occ - - CALL timeset(routineN, handle) - - occ = dbcsr_get_occupation(matrix) - max_loc = REAL(dbcsr_get_data_size(matrix), dp) - CALL para_env%max(max_loc) - - IF (unit_nr > 0) THEN - frac_2p31 = max_loc/REAL(dbcsr_msg_elem_limit, dp) - WRITE (unit_nr, '(A)') ' ' - WRITE (unit_nr, '(T2,A,F36.2,A)') & - 'Occupation of non-zero elements of '//TRIM(label), occ*100.0_dp, ' %' - IF (frac_2p31 > 0.5_dp) then - WRITE (unit_nr, '(T4,A)') '*** WARNING: max/rank approaching 2^31 -- DBCSR overflow risk ***' - end if - CALL m_flush(unit_nr) - END IF - - CALL timestop(handle) - - END SUBROUTINE print_matrix_occupation - -! ************************************************************************************************** -!> \brief Marks the grid blocks whose centroid lies within cutoff of the bounding box of the -!> panel [blk0, blk1]'s chunk centroids. -!> \param centroids ... -!> \param blk0 ... -!> \param blk1 ... -!> \param cutoff ... -!> \param used ... -! ************************************************************************************************** - SUBROUTINE mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, used) - - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centroids - INTEGER, INTENT(IN) :: blk0, blk1 - REAL(KIND=dp), INTENT(IN) :: cutoff - LOGICAL, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: used - CHARACTER(LEN=*), PARAMETER :: routineN = 'mask_grid_blocks_near_panel' - - INTEGER :: handle - INTEGER :: c, k - REAL(KIND=dp) :: cutoff2, d2, dx - REAL(KIND=dp), DIMENSION(3) :: hi, lo - - CALL timeset(routineN, handle) - - cutoff2 = cutoff**2 - lo(:) = MINVAL(centroids(:, blk0:blk1), DIM=2) - hi(:) = MAXVAL(centroids(:, blk0:blk1), DIM=2) - - ALLOCATE (used(SIZE(centroids, 2))) - DO c = 1, SIZE(centroids, 2) - d2 = 0.0_dp - DO k = 1, 3 - dx = MAX(0.0_dp, lo(k) - centroids(k, c), centroids(k, c) - hi(k)) - d2 = d2 + dx*dx - END DO - used(c) = (d2 <= cutoff2) - END DO - - CALL timestop(handle) - - END SUBROUTINE mask_grid_blocks_near_panel - -! ************************************************************************************************** -!> \brief Exact allocated-element count of the geo template of panel [blk0, blk1]: the very same -!> per-block-pair centroid test as build_geo_template_panel, so this is the true DBCSR -!> data size of A_pan/B_pan/C_pan (DBCSR stores whole blocks). -!> \param r_blk_sizes ... -!> \param centroids ... -!> \param used ... -!> \param blk0 ... -!> \param blk1 ... -!> \param cutoff ... -!> \param nze_tmpl ... -! ************************************************************************************************** - SUBROUTINE panel_template_elems(r_blk_sizes, centroids, used, blk0, blk1, cutoff, nze_tmpl) - - INTEGER, DIMENSION(:), INTENT(IN) :: r_blk_sizes - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centroids - LOGICAL, DIMENSION(:), INTENT(IN) :: used - INTEGER, INTENT(IN) :: blk0, blk1 - REAL(KIND=dp), INTENT(IN) :: cutoff - INTEGER(KIND=int_8), INTENT(OUT) :: nze_tmpl - CHARACTER(LEN=*), PARAMETER :: routineN = 'panel_template_elems' - - INTEGER :: handle - INTEGER :: c, ib, n_used - INTEGER, ALLOCATABLE, DIMENSION(:) :: used_idx - REAL(KIND=dp) :: cutoff2 - - CALL timeset(routineN, handle) - - ! Compress the near mask once so the pair loop only visits candidate columns. - n_used = COUNT(used) - ALLOCATE (used_idx(n_used)) - n_used = 0 - DO c = 1, SIZE(used) - IF (used(c)) THEN - n_used = n_used + 1 - used_idx(n_used) = c - END IF - END DO - - cutoff2 = cutoff**2 - nze_tmpl = 0_int_8 - !$OMP PARALLEL DO DEFAULT(NONE) SHARED(blk0, blk1, n_used, used_idx, centroids, cutoff2, & - !$OMP r_blk_sizes) PRIVATE(ib, c) REDUCTION(+:nze_tmpl) - DO ib = blk0, blk1 - DO c = 1, n_used - IF (SUM((centroids(:, ib) - centroids(:, used_idx(c)))**2) <= cutoff2) then - nze_tmpl = nze_tmpl + INT(r_blk_sizes(ib), int_8)*INT(r_blk_sizes(used_idx(c)), int_8) - end if - END DO - END DO - !$OMP END PARALLEL DO - - CALL timestop(handle) - - END SUBROUTINE panel_template_elems - -! ************************************************************************************************** -!> \brief Per-rank peak memory (GB) of one panel step of the neighborhood-restricted -!> contractions: three grid x grid panels of the template size (A_pan, B_pan, C_pan) -!> plus the grid x RI intermediates (tmp2 and the accumulation operand) and the -!> grid x AO intermediate (tmpA), whose column support is the panel's geometric -!> neighborhood fraction f_near = width/n_grid. Shared by the panel planner and -!> \param nze_tmpl ... -!> \param pan_rows ... -!> \param width ... -!> \param n_grid_total ... -!> \param n_RI ... -!> \param n_ao ... -!> \param n_procs ... -!> \param mem_GB ... -! ************************************************************************************************** - SUBROUTINE panel_mem_estimate_GB(nze_tmpl, pan_rows, width, n_grid_total, n_RI, n_ao, & - n_procs, mem_GB) - - INTEGER(KIND=int_8), INTENT(IN) :: nze_tmpl - INTEGER, INTENT(IN) :: pan_rows, width, n_grid_total, n_RI, & - n_ao, n_procs - REAL(KIND=dp), INTENT(OUT) :: mem_GB - - REAL(KIND=dp) :: f_near - - f_near = REAL(width, dp)/REAL(MAX(n_grid_total, 1), dp) - mem_GB = (3.0_dp*REAL(nze_tmpl, dp) + & - REAL(pan_rows, dp)*f_near*(2.0_dp*REAL(n_RI, dp) + REAL(n_ao, dp)))* & - 8.0_dp/REAL(MAX(n_procs, 1), dp)*1.0E-9_dp - - END SUBROUTINE panel_mem_estimate_GB - -! ************************************************************************************************** -!> \brief Plans the panel boundaries for the streaming contractions. Panels grow by whole grid -!> row-blocks towards ~panel_size rows. When the neighborhood restriction is active -!> (centroids+cutoff), each candidate panel is additionally checked against -!> (a) the 32-bit message bound with the panel's TRUE occupancy -!> (b) the per-rank memory budget: panel_mem_estimate_GB <= mem_budget_GB. -!> \param r_blk_sizes ... -!> \param panel_size ... -!> \param min_dim ... -!> \param pan_first ... -!> \param pan_last ... -!> \param centroids ... -!> \param cutoff ... -!> \param n_RI ... -!> \param n_ao ... -!> \param n_procs ... -!> \param mem_budget_GB ... -! ************************************************************************************************** - SUBROUTINE plan_grid_panels(r_blk_sizes, panel_size, min_dim, pan_first, pan_last, & - centroids, cutoff, n_RI, n_ao, n_procs, mem_budget_GB, & - honor_exact, unsafe) - - INTEGER, DIMENSION(:), INTENT(IN) :: r_blk_sizes - INTEGER, INTENT(IN) :: panel_size, min_dim - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: pan_first, pan_last - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), OPTIONAL :: centroids - REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff - INTEGER, INTENT(IN), OPTIONAL :: n_RI, n_ao, n_procs - REAL(KIND=dp), INTENT(IN), OPTIONAL :: mem_budget_GB - LOGICAL, INTENT(IN), OPTIONAL :: honor_exact - LOGICAL, INTENT(OUT), OPTIONAL :: unsafe - CHARACTER(LEN=*), PARAMETER :: routineN = 'plan_grid_panels' - - INTEGER :: blk0, blk1, ib, n_grid_blocks, & - n_grid_total, n_panels, rows_acc, & - target, width - INTEGER(KIND=int_8) :: msg, nze_tmpl, side - INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_first, tmp_last - LOGICAL :: fits, my_honor_exact, my_unsafe, & - use_cutoff - LOGICAL, ALLOCATABLE, DIMENSION(:) :: used - REAL(KIND=dp) :: f_near, mem_GB - INTEGER :: handle - - CALL timeset(routineN, handle) - - use_cutoff = PRESENT(centroids) .AND. PRESENT(cutoff) - IF (use_cutoff) use_cutoff = cutoff > 0.0_dp - IF (use_cutoff) THEN - CPASSERT(PRESENT(n_RI) .AND. PRESENT(n_ao) .AND. PRESENT(n_procs)) - END IF - - ! honor_exact: use N_PANELS as requested -- do NOT split a panel further even if it trips - ! the message-overflow / memory-budget check; instead flag `unsafe` so the caller can warn. - my_honor_exact = .FALSE. - IF (PRESENT(honor_exact)) my_honor_exact = honor_exact - my_unsafe = .FALSE. - - n_grid_blocks = SIZE(r_blk_sizes) - n_grid_total = SUM(r_blk_sizes) - ALLOCATE (tmp_first(n_grid_blocks), tmp_last(n_grid_blocks)) - - n_panels = 0 - blk0 = 1 - DO WHILE (blk0 <= n_grid_blocks) - target = panel_size - DO - rows_acc = 0 - blk1 = blk0 - DO ib = blk0, n_grid_blocks - rows_acc = rows_acc + r_blk_sizes(ib) - blk1 = ib - IF (rows_acc >= target) EXIT - END DO - IF (.NOT. use_cutoff .OR. blk1 == blk0) EXIT - CALL mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, used) - width = SUM(r_blk_sizes, MASK=used) - CALL panel_template_elems(r_blk_sizes, centroids, used, blk0, blk1, cutoff, nze_tmpl) - f_near = REAL(width, dp)/REAL(MAX(n_grid_total, 1), dp) - side = INT(REAL(rows_acc, dp)*f_near*REAL(MAX(n_RI, n_ao), dp), int_8) - msg = MAX(nze_tmpl, side)/INT(MAX(min_dim, 1), int_8) - fits = (msg <= dbcsr_msg_elem_limit/4) - IF (fits .AND. PRESENT(mem_budget_GB)) THEN - IF (mem_budget_GB > 0.0_dp) THEN - CALL panel_mem_estimate_GB(nze_tmpl, rows_acc, width, n_grid_total, & - n_RI, n_ao, n_procs, mem_GB) - fits = (mem_GB <= mem_budget_GB) - END IF - END IF - ! Panel size is bounded only by the message-overflow and memory checks above; there is - ! no neighborhood-width (f_near) cap. mp_waitall is dominated by the NUMBER of panel - ! multiplies, so fewer/larger panels are cheaper here -- panel count is driven DOWN by - ! the N_PANELS keyword (panel_size), not split up by a width heuristic. - IF (my_honor_exact) THEN - ! Keep exactly the requested grouping; just record if it exceeds a safety limit. - IF (.NOT. fits) my_unsafe = .TRUE. - EXIT - END IF - IF (fits) EXIT - target = MAX(1, MIN(target, rows_acc)/2) - END DO - n_panels = n_panels + 1 - tmp_first(n_panels) = blk0 - tmp_last(n_panels) = blk1 - blk0 = blk1 + 1 - END DO - - ALLOCATE (pan_first(n_panels), pan_last(n_panels)) - pan_first(:) = tmp_first(1:n_panels) - pan_last(:) = tmp_last(1:n_panels) - DEALLOCATE (tmp_first, tmp_last) - - IF (PRESENT(unsafe)) unsafe = my_unsafe - - CALL timestop(handle) - - END SUBROUTINE plan_grid_panels - -! ************************************************************************************************** -!> \brief Resolves the panel boundaries for the streaming contractions from the bs_env settings: -!> \param bs_env ... -!> \param mat_phi_mu_l ... -!> \param pan_first ... -!> \param pan_last ... -! ************************************************************************************************** - SUBROUTINE resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(dbcsr_type), INTENT(INOUT) :: mat_phi_mu_l - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: pan_first, pan_last - CHARACTER(LEN=*), PARAMETER :: routineN = 'resolve_grid_panels' - - INTEGER :: min_dim, n_grid_total, n_panels_req, & - npcols, nprows, panel_size, safe_max - INTEGER, DIMENSION(:), POINTER :: r_blk_sizes - LOGICAL :: honor_exact, panels_unsafe, use_cutoff - REAL(KIND=dp) :: mem_avail_GB, mem_budget_GB - TYPE(dbcsr_distribution_type) :: dist - INTEGER :: handle - - CALL timeset(routineN, handle) - - IF (ALLOCATED(bs_env%ri_rs%pan_first)) THEN - ALLOCATE (pan_first, SOURCE=bs_env%ri_rs%pan_first) - ALLOCATE (pan_last, SOURCE=bs_env%ri_rs%pan_last) - CALL timestop(handle) - RETURN - END IF - - use_cutoff = bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp .AND. & - ALLOCATED(bs_env%ri_rs%chunk_centroids) - - ! MIN(nprows, npcols) is the divisor that bounds the worst-rank Cannon message: a - ! P x n_grid panel is replicated into block row strips (P/nprows x n_grid) or column - ! strips (P x n_grid/npcols) during multiply_cannon, so the largest single-rank - ! message is ~ P*n_grid / MIN(nprows,npcols) elements. - CALL dbcsr_get_info(mat_phi_mu_l, nfullrows_total=n_grid_total, row_blk_size=r_blk_sizes, & - distribution=dist) - CALL dbcsr_distribution_get(dist, nprows=nprows, npcols=npcols) - min_dim = MAX(MIN(nprows, npcols), 1) - - ! Panel height such that NO per-rank DBCSR message can overflow the 32-bit length field - ! (see dbcsr_msg_elem_limit): requiring the worst-rank message to stay under - ! 0.5 * HUGE(int_4) gives the safe height P_safe = 0.5 * HUGE(int_4) * min_dim / n_grid. - IF (use_cutoff) THEN - safe_max = n_grid_total - ELSE - safe_max = INT(0.5_dp*REAL(dbcsr_msg_elem_limit, dp)*REAL(min_dim, dp)/ & - REAL(n_grid_total, dp)) - safe_max = MAX(1, MIN(safe_max, n_grid_total)) - END IF - - ! A user-set N_PANELS ( > 1 ) is honored EXACTLY: the planner produces that many panels - ! (up to grid-block granularity) and never force-splits them for the message/memory safety - ! limits -- if a limit is tripped it warns instead of silently changing the count. - n_panels_req = bs_env%ri_rs%n_panels - honor_exact = (n_panels_req > 1) - panels_unsafe = .FALSE. - IF (n_panels_req > 1) THEN - ! ceil(n_grid/n_panels_req) rows per panel => exactly n_panels_req panels. With the - ! cutoff active safe_max = n_grid_total (no clamp, honored exactly); without it, safe_max - ! is the int32-overflow ceiling and MUST still bound the panel (the non-cutoff planner - ! loop has no in-loop message-size check). - panel_size = MIN((n_grid_total + n_panels_req - 1)/n_panels_req, safe_max) - ELSE - ! Default (<= 1): a single whole-grid panel, clamped to the overflow-safe ceiling. - panel_size = safe_max - END IF - panel_size = MAX(1, panel_size) - - IF (use_cutoff) THEN - ! Half of the measured free memory as panel budget. - CALL ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) - mem_budget_GB = 0.5_dp*mem_avail_GB - CALL plan_grid_panels(r_blk_sizes, panel_size, min_dim, pan_first, pan_last, & - centroids=bs_env%ri_rs%chunk_centroids, & - cutoff=bs_env%ri_rs%cutoff_radius_v_w, & - n_RI=bs_env%n_RI, n_ao=bs_env%n_ao, & - n_procs=bs_env%para_env%num_pe, mem_budget_GB=mem_budget_GB, & - honor_exact=honor_exact, unsafe=panels_unsafe) - ELSE - CALL plan_grid_panels(r_blk_sizes, panel_size, min_dim, pan_first, pan_last) - END IF - - IF (honor_exact .AND. panels_unsafe .AND. bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,I0,A)') & - '*** WARNING: N_PANELS = ', n_panels_req, ' used as requested, but one or more '// & - 'panels exceed the DBCSR 32-bit message / memory-budget safety limit. The run may '// & - 'abort or swap; increase N_PANELS if it does. ***' - END IF - - ALLOCATE (bs_env%ri_rs%pan_first, SOURCE=pan_first) - ALLOCATE (bs_env%ri_rs%pan_last, SOURCE=pan_last) - - CALL timestop(handle) - - END SUBROUTINE resolve_grid_panels - -! ************************************************************************************************** -!> \brief Available memory per MPI process (GB). /proc/meminfo reports node-wide memory, so -!> every rank on a node reads the SAME MemLikelyFree; the per-process share is -!> node_free / ranks_per_node (ranks grouped by a hostname hash exchanged via allgather). -!> Returns the MIN across all ranks (most-constrained node) -!> \param bs_env ... -!> \param mem_avail_GB ... -! ************************************************************************************************** - SUBROUTINE ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), INTENT(OUT) :: mem_avail_GB - CHARACTER(LEN=*), PARAMETER :: routineN = 'ri_rs_mem_avail_per_proc_GB' - - CHARACTER(LEN=default_string_length) :: hostname - INTEGER :: host_hash, ic, n_procs, ranks_per_node - INTEGER, ALLOCATABLE, DIMENSION(:) :: all_host_hashes - INTEGER(KIND=int_8) :: h8, mem_buffers, mem_cached, mem_free, & - mem_likely_free, mem_sreclaimable, & - mem_slab, mem_total - INTEGER :: handle - - CALL timeset(routineN, handle) - - n_procs = bs_env%para_env%num_pe - CALL m_hostnm(hostname) - h8 = 0_int_8 - DO ic = 1, LEN_TRIM(hostname) - h8 = MOD(h8*127_int_8 + INT(ICHAR(hostname(ic:ic)), int_8), 2147483647_int_8) - END DO - host_hash = INT(h8) - ALLOCATE (all_host_hashes(n_procs)) - CALL bs_env%para_env%allgather(host_hash, all_host_hashes) - ranks_per_node = MAX(COUNT(all_host_hashes == host_hash), 1) - DEALLOCATE (all_host_hashes) - - CALL m_memory_details(MemTotal=mem_total, MemFree=mem_free, Buffers=mem_buffers, & - Cached=mem_cached, Slab=mem_slab, SReclaimable=mem_sreclaimable, & - MemLikelyFree=mem_likely_free) - mem_avail_GB = REAL(mem_likely_free, dp)*1.0E-9_dp/REAL(ranks_per_node, dp) - CALL bs_env%para_env%min(mem_avail_GB) - - CALL timestop(handle) - - END SUBROUTINE ri_rs_mem_avail_per_proc_GB - -! ************************************************************************************************** -!> \brief Estimates and prints per-process memory requirements for the RI-RS GW calculation. -!> \param qs_env ... -!> \param bs_env ... -! ************************************************************************************************** - SUBROUTINE print_ri_rs_memory_estimate(qs_env, bs_env) - -!$ USE OMP_LIB, ONLY: omp_get_max_threads - - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'print_ri_rs_memory_estimate' - - INTEGER :: handle, iatom, ipan, l, & - max_n_local_grid, & - n_ao_total, n_grid_total, & - n_local_grid, n_loc_ri_max, n_procs, & - n_procs_per_atom, n_RI, n_threads, & - natom, pan_rows, pan_width - INTEGER(KIND=int_8) :: nze_tmpl - INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last - INTEGER, DIMENSION(:), POINTER :: r_blk_sizes - LOGICAL :: use_cutoff - LOGICAL, ALLOCATABLE, DIMENSION(:) :: grid_used - REAL(KIND=dp) :: cutoff_ri, mem_avail_GB, mem_D_local_GB, & - mem_dlp_GB, mem_pan_GB, mem_panels_GB, & - mem_phi_local_GB, mem_Z_lP_GB, & - mem_Zlp_peak_GB, pos_P(3) - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - - CALL timeset(routineN, handle) - - CALL dbcsr_get_info(bs_env%ri_rs%mat_phi_mu_l, nfullrows_total=n_grid_total, & - row_blk_size=r_blk_sizes) - n_RI = bs_env%n_RI - n_procs = bs_env%para_env%num_pe - - ! Z_lP upper bound: dense n_grid × n_RI, distributed evenly across all ranks. - ! The actual sparse Z_lP is smaller due to the per-atom locality cutoff. - mem_Z_lP_GB = REAL(n_grid_total, dp)*REAL(n_RI, dp)*8.0_dp/ & - REAL(n_procs, dp)*1.0E-9_dp - - ! Peak panel memory during Σ^c: two G panels (A_occ, A_vir) + one W panel plus the - ! grid × RI / grid × AO intermediates. With the CUTOFF_RADIUS_RL_W restriction the panel - ! matrices only allocate the geo-template blocks, so use the same nze-aware model as the - ! panel planner (panel_mem_estimate_GB); without the cutoff, dense panel_rows × n_grid. - ! Plus the n_RI × n_RI W_aux matrix. Distributed over n_procs ranks. - use_cutoff = bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp .AND. & - ALLOCATED(bs_env%ri_rs%chunk_centroids) - CALL resolve_grid_panels(bs_env, bs_env%ri_rs%mat_phi_mu_l, pan_first, pan_last) - mem_panels_GB = 0.0_dp - DO ipan = 1, SIZE(pan_first) - pan_rows = SUM(r_blk_sizes(pan_first(ipan):pan_last(ipan))) - IF (use_cutoff) THEN - CALL mask_grid_blocks_near_panel(bs_env%ri_rs%chunk_centroids, pan_first(ipan), & - pan_last(ipan), bs_env%ri_rs%cutoff_radius_v_w, & - grid_used) - pan_width = SUM(r_blk_sizes, MASK=grid_used) - CALL panel_template_elems(r_blk_sizes, bs_env%ri_rs%chunk_centroids, & - grid_used, pan_first(ipan), pan_last(ipan), & - bs_env%ri_rs%cutoff_radius_v_w, nze_tmpl) - CALL panel_mem_estimate_GB(nze_tmpl, pan_rows, pan_width, n_grid_total, & - n_RI, bs_env%n_ao, n_procs, mem_pan_GB) - ELSE - pan_width = n_grid_total - mem_pan_GB = (3.0_dp*REAL(pan_rows, dp)*REAL(pan_width, dp) + & - 2.0_dp*REAL(pan_rows, dp)*REAL(n_RI, dp))* & - 8.0_dp/REAL(n_procs, dp)*1.0E-9_dp - END IF - mem_panels_GB = MAX(mem_panels_GB, mem_pan_GB) - END DO - mem_panels_GB = mem_panels_GB + & - REAL(n_RI, dp)*REAL(n_RI, dp)*8.0_dp/REAL(n_procs, dp)*1.0E-9_dp - - ! Z_lP SOLVE peak (compute_coeff_Z_lP). For the atom P with the largest integration - ! sphere, one rank holds simultaneously: - ! D_local : n_local_grid x n_local_grid (dense Gram, BLAS path only; O(n_local_grid^2)) - ! phi_local: n_local_grid x n_ao_total - ! d_lp : n_local_grid x n_loc_ri, replicated once + one private copy per OMP thread - ! n_local_grid = # grid points within cutoff_ri(P) = CUTOFF_RADIUS_RL_RI (if > 0) else - ! r_c(RI metric) + r_RI(P). This is NOT evenly distributed: n_local_grid depends on the - ! local density of atoms/grid, so the rank owning the densest atom peaks well above the - ! average. We report the worst-case (max over atoms) as a per-rank upper bound. - CALL get_qs_env(qs_env, particle_set=particle_set) - natom = SIZE(particle_set) - n_ao_total = bs_env%i_ao_end_from_atom(natom) - - max_n_local_grid = 0 - n_loc_ri_max = 0 - DO iatom = 1, natom - IF (bs_env%ri_rs%cutoff_radius_ri_rs > 0.0_dp) THEN - cutoff_ri = bs_env%ri_rs%cutoff_radius_ri_rs - ELSE - cutoff_ri = bs_env%ri_metric%cutoff_radius + bs_env%ri_rs%radius_ri_per_atom(iatom) - END IF - pos_P(:) = particle_set(iatom)%r(:) - n_local_grid = 0 - DO l = 1, n_grid_total - IF (SUM((bs_env%ri_rs%grid_points(1:3, l) - pos_P(1:3))**2) <= cutoff_ri**2) then - n_local_grid = n_local_grid + 1 - end if - END DO - max_n_local_grid = MAX(max_n_local_grid, n_local_grid) - n_loc_ri_max = MAX(n_loc_ri_max, & - bs_env%i_RI_end_from_atom(iatom) - bs_env%i_RI_start_from_atom(iatom) + 1) - END DO - - n_procs_per_atom = MIN(MAX(bs_env%ri_rs%n_procs_per_atom_z_lp, 1), n_procs) - n_threads = 1 -!$ n_threads = omp_get_max_threads() - - ! D_local: dense on one rank for the BLAS path; block-cyclic over the subgroup (=> /G) for - ! the ScaLAPACK path (N_PROCS_PER_ATOM_Z_LP = G > 1). phi_local/d_lp stay per-rank either way. - IF (n_procs_per_atom > 1) THEN - mem_D_local_GB = REAL(max_n_local_grid, dp)**2*8.0_dp/REAL(n_procs_per_atom, dp)*1.0E-9_dp - ELSE - mem_D_local_GB = REAL(max_n_local_grid, dp)**2*8.0_dp*1.0E-9_dp - END IF - mem_phi_local_GB = REAL(max_n_local_grid, dp)*REAL(n_ao_total, dp)*8.0_dp*1.0E-9_dp - mem_dlp_GB = REAL(max_n_local_grid, dp)*REAL(n_loc_ri_max, dp)*8.0_dp* & - REAL(1 + n_threads, dp)*1.0E-9_dp - mem_Zlp_peak_GB = mem_D_local_GB + mem_phi_local_GB + mem_dlp_GB - - ! Available memory per process = node MemLikelyFree / ranks-per-node, min across ranks - ! (0 on non-Linux => warnings suppressed below). - CALL ri_rs_mem_avail_per_proc_GB(bs_env, mem_avail_GB) - - IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(A)') ' ' - WRITE (bs_env%unit_nr, '(T2,A)') 'RI-RS memory estimate per MPI process:' - WRITE (bs_env%unit_nr, '(T4,A,F37.2,A)') & - 'Available memory per process (system)', mem_avail_GB, ' GB' - WRITE (bs_env%unit_nr, '(T4,A,F18.2,A)') & - 'Required for Z_lP (dense upper bound; actual is sparser)', mem_Z_lP_GB, ' GB' - WRITE (bs_env%unit_nr, '(T4,A,F25.2,A)') & - 'Required for χ, W, Σ panels (peak per panel step)', mem_panels_GB, ' GB' - WRITE (bs_env%unit_nr, '(T4,A,F17.2,A)') & - 'Required for Z_lP solve peak (D_local+φ, worst-case atom)', mem_Zlp_peak_GB, ' GB' - WRITE (bs_env%unit_nr, '(T6,A,I21,A,F10.2,A)') & - 'worst-case n_local_grid', max_n_local_grid, ' points (D_local', mem_D_local_GB, ' GB)' - WRITE (bs_env%unit_nr, '(A)') ' ' - - IF (mem_avail_GB > 0.0_dp .AND. mem_Z_lP_GB > mem_avail_GB) THEN - WRITE (bs_env%unit_nr, '(T2,A)') & - '*** WARNING: Estimated Z_lP memory exceeds available memory per process ***' - WRITE (bs_env%unit_nr, '(T4,A,F6.2,A,F6.2,A)') & - 'Z_lP upper bound: ', mem_Z_lP_GB, ' GB > available: ', mem_avail_GB, ' GB' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'Z_lP (n_grid × n_RI) is distributed across all MPI ranks. To reduce per-rank' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'memory: add more nodes, use fewer MPI ranks per node, or increase' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'N_PROCS_PER_ATOM_Z_LP to distribute each atom block via ScaLAPACK (reduces' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'per-rank memory by ~1/G where G = N_PROCS_PER_ATOM_Z_LP).' - WRITE (bs_env%unit_nr, '(A)') ' ' - END IF - IF (mem_avail_GB > 0.0_dp .AND. mem_panels_GB > mem_avail_GB) THEN - WRITE (bs_env%unit_nr, '(T2,A)') & - '*** WARNING: Estimated χ/W/Σ panel memory exceeds available memory per process ***' - WRITE (bs_env%unit_nr, '(T4,A,F6.2,A,F6.2,A)') & - 'Panel peak estimate: ', mem_panels_GB, ' GB > available: ', mem_avail_GB, ' GB' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'Panel memory scales as ~3×panel_size×n_grid / n_procs. Options:' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' - More nodes or fewer MPI ranks per node (increases n_procs, reduces share)' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' - Increase N_PANELS (more, smaller panels → less peak memory per step)' - WRITE (bs_env%unit_nr, '(A)') ' ' - END IF - IF (mem_avail_GB > 0.0_dp .AND. mem_Zlp_peak_GB > mem_avail_GB) THEN - WRITE (bs_env%unit_nr, '(T2,A)') & - '*** WARNING: Estimated Z_lP solve peak exceeds available memory per process ***' - WRITE (bs_env%unit_nr, '(T4,A,F8.2,A,F8.2,A)') & - 'Z_lP solve peak: ', mem_Zlp_peak_GB, ' GB > available: ', mem_avail_GB, ' GB' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'The per-atom Gram matrix D_local(n_local_grid, n_local_grid) dominates and scales' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'as n_local_grid^2. It is NOT balanced across ranks (the rank owning the atom with' - WRITE (bs_env%unit_nr, '(T4,A)') & - 'the largest integration sphere peaks well above the average). Options:' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' - Increase N_PROCS_PER_ATOM_Z_LP=G to distribute D_local block-cyclic via' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' ScaLAPACK (reduces the D_local term by ~1/G; no accuracy loss)' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' - Reduce the RI-RS sphere cutoff (CUTOFF_RADIUS_RL_RI): D_local shrinks as' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' n_local_grid^2, but this trades accuracy' - WRITE (bs_env%unit_nr, '(T4,A)') & - ' - Fewer MPI ranks per node (more memory per rank for the peak atom)' - WRITE (bs_env%unit_nr, '(A)') ' ' - END IF - END IF - - CALL timestop(handle) - - END SUBROUTINE print_ri_rs_memory_estimate - -! ************************************************************************************************** -!> \brief Creates an empty (panel_chunks x neighborhood_chunks) DBCSR matrix with zero blocks -!> pre-allocated only where |centroid(panel_row r) - centroid(column c)| <= cutoff. -!> Used with retain_sparsity=.TRUE. in the subsequent dbcsr_multiply so distant blocks -!> of the grid-basis panels (φ G φ^T, Z W Z^T, ...) are never computed at all. -!> \param L_pan ... -!> \param L_full ... -!> \param centroids ... -!> \param cutoff ... -!> \param blk0 ... -!> \param A_template ... -!> \param col_map ... -! ************************************************************************************************** - SUBROUTINE build_geo_template_panel(L_pan, L_full, centroids, cutoff, blk0, A_template, col_map) - TYPE(dbcsr_type), INTENT(IN) :: L_pan, L_full - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centroids - REAL(KIND=dp), INTENT(IN) :: cutoff - INTEGER, INTENT(IN) :: blk0 - TYPE(dbcsr_type), INTENT(OUT) :: A_template - INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: col_map - - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_geo_template_panel' - - INTEGER :: c, cg, cs, handle, my_pcol, my_prow, & - n_grid_blks, n_pan_blks, npcols, & - nprows, r, rs - INTEGER, DIMENSION(:), POINTER :: grid_blk_sizes, pan_blk_sizes - REAL(KIND=dp) :: cutoff2 - REAL(KIND=dp), ALLOCATABLE :: zero_blk(:, :) - TYPE(dbcsr_distribution_type) :: dist - - CALL timeset(routineN, handle) - - cutoff2 = cutoff**2 - CALL dbcsr_get_info(L_pan, nblkrows_total=n_pan_blks, row_blk_size=pan_blk_sizes) - CALL dbcsr_get_info(L_full, nblkrows_total=n_grid_blks, row_blk_size=grid_blk_sizes) - - ! create_product_matrix assigns row r to process MOD(r-1,nprows) and - ! col c to MOD(c-1,npcols), so we can determine local ownership analytically. - CALL create_product_matrix(L_pan, L_full, 'N', 'T', A_template) - CALL dbcsr_get_info(A_template, distribution=dist) - CALL dbcsr_distribution_get(dist, nprows=nprows, npcols=npcols, & - myprow=my_prow, mypcol=my_pcol) - - ALLOCATE (zero_blk(MAXVAL(pan_blk_sizes(1:n_pan_blks)), & - MAXVAL(grid_blk_sizes(1:n_grid_blks)))) - zero_blk(:, :) = 0.0_dp - - DO r = 1, n_pan_blks - IF (MOD(r - 1, nprows) /= my_prow) CYCLE - rs = pan_blk_sizes(r) - DO c = 1, n_grid_blks - IF (MOD(c - 1, npcols) /= my_pcol) CYCLE - cg = c - IF (PRESENT(col_map)) cg = col_map(c) - IF ((centroids(1, blk0 + r - 1) - centroids(1, cg))**2 + & - (centroids(2, blk0 + r - 1) - centroids(2, cg))**2 + & - (centroids(3, blk0 + r - 1) - centroids(3, cg))**2 <= cutoff2) THEN - cs = grid_blk_sizes(c) - CALL dbcsr_put_block(A_template, r, c, zero_blk(1:rs, 1:cs)) - END IF - END DO - END DO - CALL dbcsr_finalize(A_template) - - DEALLOCATE (zero_blk) - CALL timestop(handle) - - END SUBROUTINE build_geo_template_panel - -! ************************************************************************************************** -!> \brief Slices a contiguous range of grid row-blocks [blk0, blk1] out of a (grid x n) DBCSR -!> matrix into a new (P x n) panel matrix: iterate the source's local blocks, put the -!> in-range ones into the panel with a remapped row-block index, then finalize. Row-block -!> index i of the panel corresponds to source row-block blk0+i-1. -!> \param mat_full ... -!> \param blk0 ... -!> \param blk1 ... -!> \param mat_panel ... -! ************************************************************************************************** - SUBROUTINE extract_grid_panel(mat_full, blk0, blk1, mat_panel) - - TYPE(dbcsr_type), INTENT(INOUT) :: mat_full - INTEGER, INTENT(IN) :: blk0, blk1 - TYPE(dbcsr_type), INTENT(OUT) :: mat_panel - CHARACTER(LEN=*), PARAMETER :: routineN = 'extract_grid_panel' - - INTEGER :: ib, jb, npb - INTEGER, DIMENSION(:), POINTER :: col_blk_full, col_dist_full, & - row_blk_full, row_blk_pan, & - row_dist_full, row_dist_pan - REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk - TYPE(dbcsr_distribution_type) :: dist_full, dist_pan - TYPE(dbcsr_iterator_type) :: iter - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL dbcsr_get_info(mat_full, distribution=dist_full, & - row_blk_size=row_blk_full, col_blk_size=col_blk_full) - CALL dbcsr_distribution_get(dist_full, row_dist=row_dist_full, col_dist=col_dist_full) - - npb = blk1 - blk0 + 1 - ALLOCATE (row_dist_pan(npb), row_blk_pan(npb)) - row_dist_pan(:) = row_dist_full(blk0:blk1) - row_blk_pan(:) = row_blk_full(blk0:blk1) - - CALL dbcsr_distribution_new(dist_pan, template=dist_full, & - row_dist=row_dist_pan, col_dist=col_dist_full) - CALL dbcsr_create(mat_panel, name="grid_panel", dist=dist_pan, & - matrix_type=dbcsr_type_no_symmetry, & - row_blk_size=row_blk_pan, col_blk_size=col_blk_full) - - CALL dbcsr_iterator_start(iter, mat_full) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, ib, jb, blk) - IF (ib < blk0 .OR. ib > blk1) CYCLE - CALL dbcsr_put_block(mat_panel, ib - blk0 + 1, jb, blk) - END DO - CALL dbcsr_iterator_stop(iter) - CALL dbcsr_finalize(mat_panel) - - CALL dbcsr_distribution_release(dist_pan) - DEALLOCATE (row_dist_pan, row_blk_pan) - - CALL timestop(handle) - - END SUBROUTINE extract_grid_panel - -! ************************************************************************************************** -!> \brief Marks which column blocks of a DBCSR matrix carry at least one non-zero block anywhere -!> (global union). Used to restrict the inner index of the panel multiplies to the -!> AO/RI atoms that actually touch the panel (exact: dropped rows only meet zeros). -!> \param matrix ... -!> \param para_env ... -!> \param used ... -! ************************************************************************************************** - SUBROUTINE collect_used_col_blocks(matrix, para_env, used) - - TYPE(dbcsr_type), INTENT(INOUT) :: matrix - TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env - LOGICAL, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: used - CHARACTER(LEN=*), PARAMETER :: routineN = 'collect_used_col_blocks' - - INTEGER :: ib, jb, nblkcols - INTEGER, ALLOCATABLE, DIMENSION(:) :: iused - REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk - TYPE(dbcsr_iterator_type) :: iter - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL dbcsr_get_info(matrix, nblkcols_total=nblkcols) - ALLOCATE (iused(nblkcols)) - iused(:) = 0 - - CALL dbcsr_iterator_start(iter, matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, ib, jb, blk) - iused(jb) = 1 - END DO - CALL dbcsr_iterator_stop(iter) - - CALL para_env%sum(iused) - - ALLOCATE (used(nblkcols)) - used(:) = (iused(:) > 0) - DEALLOCATE (iused) - - CALL timestop(handle) - - END SUBROUTINE collect_used_col_blocks - -! ************************************************************************************************** -!> \brief Copies the flagged block rows (compress_rows=.TRUE.) or block columns (.FALSE.) of a -!> DBCSR matrix into a compressed matrix. The subset keeps the parent's process assignment -!> along the compressed dimension, so every block stays on its owning rank: the extraction -!> is purely local (zero communication), like extract_grid_panel. -!> \param mat_full ... -!> \param used ... -!> \param mat_out ... -!> \param compress_rows ... -!> \param blk_map ... -! ************************************************************************************************** - SUBROUTINE extract_masked_blocks(mat_full, used, mat_out, compress_rows, blk_map) - - TYPE(dbcsr_type), INTENT(INOUT) :: mat_full - LOGICAL, DIMENSION(:), INTENT(IN) :: used - TYPE(dbcsr_type), INTENT(OUT) :: mat_out - LOGICAL, INTENT(IN) :: compress_rows - INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT), & - OPTIONAL :: blk_map - - CHARACTER(LEN=*), PARAMETER :: routineN = 'extract_masked_blocks' - - INTEGER :: ib, jb, n_blk, n_sub, r - INTEGER, ALLOCATABLE, DIMENSION(:) :: inv_map - INTEGER, DIMENSION(:), POINTER :: blk_full, blk_sub, col_blk_full, & - col_dist_full, dist_full_1d, & - dist_sub_1d, row_blk_full, & - row_dist_full - REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk - TYPE(dbcsr_distribution_type) :: dist_full, dist_sub - TYPE(dbcsr_iterator_type) :: iter - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL dbcsr_get_info(mat_full, distribution=dist_full, & - row_blk_size=row_blk_full, col_blk_size=col_blk_full) - CALL dbcsr_distribution_get(dist_full, row_dist=row_dist_full, col_dist=col_dist_full) - - IF (compress_rows) THEN - blk_full => row_blk_full - dist_full_1d => row_dist_full - ELSE - blk_full => col_blk_full - dist_full_1d => col_dist_full - END IF - n_blk = SIZE(blk_full) - - n_sub = COUNT(used) - CPASSERT(n_sub > 0) - ALLOCATE (inv_map(n_blk), blk_sub(n_sub), dist_sub_1d(n_sub)) - IF (PRESENT(blk_map)) ALLOCATE (blk_map(n_sub)) - inv_map(:) = 0 - r = 0 - DO ib = 1, n_blk - IF (used(ib)) THEN - r = r + 1 - inv_map(ib) = r - blk_sub(r) = blk_full(ib) - dist_sub_1d(r) = dist_full_1d(ib) - IF (PRESENT(blk_map)) blk_map(r) = ib - END IF - END DO - - IF (compress_rows) THEN - CALL dbcsr_distribution_new(dist_sub, template=dist_full, & - row_dist=dist_sub_1d, col_dist=col_dist_full) - CALL dbcsr_create(mat_out, name="row_subset", dist=dist_sub, & - matrix_type=dbcsr_type_no_symmetry, & - row_blk_size=blk_sub, col_blk_size=col_blk_full) - ELSE - CALL dbcsr_distribution_new(dist_sub, template=dist_full, & - row_dist=row_dist_full, col_dist=dist_sub_1d) - CALL dbcsr_create(mat_out, name="col_subset", dist=dist_sub, & - matrix_type=dbcsr_type_no_symmetry, & - row_blk_size=row_blk_full, col_blk_size=blk_sub) - END IF - - CALL dbcsr_iterator_start(iter, mat_full) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, ib, jb, blk) - IF (compress_rows) THEN - IF (inv_map(ib) > 0) CALL dbcsr_put_block(mat_out, inv_map(ib), jb, blk) - ELSE - IF (inv_map(jb) > 0) CALL dbcsr_put_block(mat_out, ib, inv_map(jb), blk) - END IF - END DO - CALL dbcsr_iterator_stop(iter) - CALL dbcsr_finalize(mat_out) - - CALL dbcsr_distribution_release(dist_sub) - DEALLOCATE (inv_map, blk_sub, dist_sub_1d) - - CALL timestop(handle) - - END SUBROUTINE extract_masked_blocks - -! ************************************************************************************************** -!> \brief Pre-seeds a square per-atom-blocked DBCSR matrix (G_munu, D_munu, V_PQ, W_PQ) with zero -!> blocks only for atom pairs within radius, for use with copy_fm_to_dbcsr(keep_sparsity=T): -!> the CUTOFF_RADIUS_G_W operator truncation. -!> \param matrix ... -!> \param centers ... -!> \param radius ... -! ************************************************************************************************** - SUBROUTINE reserve_blocks_within_radius(matrix, centers, radius) - - TYPE(dbcsr_type), INTENT(INOUT) :: matrix - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: centers - REAL(KIND=dp), INTENT(IN) :: radius - - CHARACTER(LEN=*), PARAMETER :: routineN = 'reserve_blocks_within_radius' - - INTEGER :: handle, i, j, my_pcol, my_prow, & - nblkcols, nblkrows - INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist, row_blk, row_dist - REAL(KIND=dp) :: radius2 - REAL(KIND=dp), ALLOCATABLE :: zero_blk(:, :) - TYPE(dbcsr_distribution_type) :: dist - - CALL timeset(routineN, handle) - - CALL dbcsr_get_info(matrix, nblkrows_total=nblkrows, nblkcols_total=nblkcols, & - row_blk_size=row_blk, col_blk_size=col_blk, distribution=dist) - CALL dbcsr_distribution_get(dist, row_dist=row_dist, col_dist=col_dist, & - myprow=my_prow, mypcol=my_pcol) - CPASSERT(nblkrows == SIZE(centers, 2)) - CPASSERT(nblkcols == SIZE(centers, 2)) - - radius2 = radius**2 - ALLOCATE (zero_blk(MAXVAL(row_blk(1:nblkrows)), MAXVAL(col_blk(1:nblkcols)))) - zero_blk(:, :) = 0.0_dp - - DO i = 1, nblkrows - IF (row_dist(i) /= my_prow) CYCLE - DO j = 1, nblkcols - IF (col_dist(j) /= my_pcol) CYCLE - IF ((centers(1, i) - centers(1, j))**2 + (centers(2, i) - centers(2, j))**2 + & - (centers(3, i) - centers(3, j))**2 <= radius2) THEN - CALL dbcsr_put_block(matrix, i, j, zero_blk(1:row_blk(i), 1:col_blk(j))) - END IF - END DO - END DO - CALL dbcsr_finalize(matrix) - - DEALLOCATE (zero_blk) - CALL timestop(handle) - - END SUBROUTINE reserve_blocks_within_radius - -! ************************************************************************************************** -!> \brief Creates the (empty) result matrix of op(mat_left) * op(mat_right) with the correct block -!> structure and a distribution on the shared process grid, ready to be filled by -!> dbcsr_multiply. Row structure comes from op(left), column structure from op(right). -!> \param mat_left ... -!> \param mat_right ... -!> \param transa 'N' or 'T' applied to mat_left -!> \param transb 'N' or 'T' applied to mat_right -!> \param mat_out ... -! ************************************************************************************************** - SUBROUTINE create_product_matrix(mat_left, mat_right, transa, transb, mat_out) - - TYPE(dbcsr_type), INTENT(IN) :: mat_left, mat_right - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - TYPE(dbcsr_type), INTENT(OUT) :: mat_out - CHARACTER(LEN=*), PARAMETER :: routineN = 'create_product_matrix' - - INTEGER :: i, npcols, nprows - INTEGER, DIMENSION(:), POINTER :: col_blk_l, col_blk_r, out_col_blk, & - out_col_dist, out_row_blk, out_row_dist, & - row_blk_l, row_blk_r - TYPE(dbcsr_distribution_type) :: dist_l, dist_out - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL dbcsr_get_info(mat_left, distribution=dist_l, row_blk_size=row_blk_l, col_blk_size=col_blk_l) - CALL dbcsr_get_info(mat_right, row_blk_size=row_blk_r, col_blk_size=col_blk_r) - CALL dbcsr_distribution_get(dist_l, nprows=nprows, npcols=npcols) - - ! block SIZES follow op(left)/op(right); DISTRIBUTIONS are freshly round-robined onto the - ! shared process grid (a transposed operand's row-dist is NOT a valid col-dist on a - ! non-square grid). dbcsr_multiply redistributes internally, so any valid mapping works. - IF (transa == 'N') THEN - out_row_blk => row_blk_l - ELSE - out_row_blk => col_blk_l - END IF - IF (transb == 'N') THEN - out_col_blk => col_blk_r - ELSE - out_col_blk => row_blk_r - END IF - - ALLOCATE (out_row_dist(SIZE(out_row_blk)), out_col_dist(SIZE(out_col_blk))) - DO i = 1, SIZE(out_row_blk) - out_row_dist(i) = MOD(i - 1, nprows) - END DO - DO i = 1, SIZE(out_col_blk) - out_col_dist(i) = MOD(i - 1, npcols) - END DO - - CALL dbcsr_distribution_new(dist_out, template=dist_l, & - row_dist=out_row_dist, col_dist=out_col_dist) - CALL dbcsr_create(mat_out, name="panel_product", dist=dist_out, & - matrix_type=dbcsr_type_no_symmetry, & - row_blk_size=out_row_blk, col_blk_size=out_col_blk) - CALL dbcsr_distribution_release(dist_out) - DEALLOCATE (out_row_dist, out_col_dist) - - CALL timestop(handle) - - END SUBROUTINE create_product_matrix - -! ************************************************************************************************** -!> \brief Builds the AO-space Green's function operator G^occ/vir_µν (AO x AO DBCSR) +!> \brief Computes Green's Function in grid basis !> \param bs_env ... !> \param tau ... !> \param ispin ... !> \param occ ... !> \param vir ... -!> \param template ... -!> \param matrix_G_ao ... +!> \param mat_phi_mu_l ... +!> \param matrix_G_grid ... +!> \param eps_filter ... ! ************************************************************************************************** - SUBROUTINE build_G_ao(bs_env, tau, ispin, occ, vir, template, matrix_G_ao) + + SUBROUTINE build_G_grid(bs_env, tau, ispin, occ, vir, mat_phi_mu_l, matrix_G_grid, eps_filter) TYPE(post_scf_bandstructure_type), POINTER :: bs_env REAL(KIND=dp), INTENT(IN) :: tau INTEGER, INTENT(IN) :: ispin LOGICAL, INTENT(IN) :: occ, vir - TYPE(dbcsr_type), INTENT(INOUT) :: template - TYPE(dbcsr_type), INTENT(OUT) :: matrix_G_ao - CHARACTER(LEN=*), PARAMETER :: routineN = 'build_G_ao' + TYPE(dbcsr_type), INTENT(INOUT) :: mat_phi_mu_l, matrix_G_grid + REAL(KIND=dp), INTENT(IN) :: eps_filter + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_G_grid' + + INTEGER :: handle INTEGER, DIMENSION(:), POINTER :: blk_ao, dist_row_ao TYPE(cp_fm_type), POINTER :: fm_G TYPE(dbcsr_distribution_type) :: dist_ao_ao - INTEGER :: handle + TYPE(dbcsr_type) :: matrix_G_ao CALL timeset(routineN, handle) + ! 1. Select the FM matrix based on occ/vir flags IF (occ) THEN fm_G => bs_env%fm_Gocc ELSE fm_G => bs_env%fm_Gvir END IF + ! 2. Compute Dense FM Green's Function + ! G^occ/vir_µλ(i|τ|) = sum_G^occ/vir_µλn^occ/vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn CALL G_occ_vir(bs_env, tau, fm_G, ispin, occ=occ, vir=vir) - CALL setup_square_topology(template, dist_ao_ao, blk_ao, dist_row_ao) + ! 3. Setup AO DBCSR Topology and Create Matrix dynamically + CALL setup_square_topology(mat_phi_mu_l, 'COL', dist_ao_ao, blk_ao, dist_row_ao) + CALL dbcsr_create(matrix_G_ao, name="G_ao", dist=dist_ao_ao, & matrix_type=dbcsr_type_no_symmetry, & row_blk_size=blk_ao, col_blk_size=blk_ao) - ! Optional CUTOFF_RADIUS_G_W operator truncation: only atom-pair blocks within the radius - ! are reserved and filled. - IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp .AND. & - ALLOCATED(bs_env%ri_rs%atom_centers)) THEN - CALL reserve_blocks_within_radius(matrix_G_ao, bs_env%ri_rs%atom_centers, & - bs_env%ri_rs%cutoff_radius_g_w) - CALL copy_fm_to_dbcsr(fm_G, matrix_G_ao, keep_sparsity=.TRUE.) + ! 4. Convert FM to Sparse DBCSR + CALL copy_fm_to_dbcsr(fm_G, matrix_G_ao, keep_sparsity=.FALSE.) + + ! 5. Transform to Grid Basis: G_grid = phi * G_ao * phi^T + ! G^occ/vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ/vir_µν Φ_ν(r_l') + CALL contract_A_B_A("N", "T", mat_phi_mu_l, matrix_G_ao, matrix_G_grid, eps_filter) + + ! 6. Release AO matrix and topology + CALL release_dbcsr_topology_and_matrices(dist=dist_ao_ao, mapped_dist=dist_row_ao, m1=matrix_G_ao) + + CALL timestop(handle) + + END SUBROUTINE build_G_grid + +! ************************************************************************************************** +!> \brief Generalized routine to compute OUT = A * B * A^T OR OUT = A^T * B * A using DBCSR +!> \param transA_left ... +!> \param transA_right ... +!> \param matrix_A ... +!> \param matrix_B ... +!> \param matrix_out ... +!> \param eps_filter ... +! ************************************************************************************************** + + SUBROUTINE contract_A_B_A(transA_left, transA_right, matrix_A, matrix_B, matrix_out, eps_filter) + + CHARACTER(LEN=1), INTENT(IN) :: transA_left, transA_right + TYPE(dbcsr_type), INTENT(INOUT) :: matrix_A, matrix_B, matrix_out + REAL(KIND=dp), INTENT(IN) :: eps_filter + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_A_B_A' + + INTEGER :: handle + TYPE(dbcsr_type) :: matrix_tmp + + CALL timeset(routineN, handle) + + CALL dbcsr_create(matrix_tmp, template=matrix_A) + + IF (transA_left == "N" .AND. transA_right == "T") THEN + ! Path 1: Out = A * B * A^T + CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_A, matrix_B, & + 0.0_dp, matrix_tmp, filter_eps=eps_filter) + CALL dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp, matrix_A, & + 0.0_dp, matrix_out, filter_eps=eps_filter) + + ELSE IF (transA_left == "T" .AND. transA_right == "N") THEN + ! Path 2: Out = A^T * B * A + CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_B, matrix_A, & + 0.0_dp, matrix_tmp, filter_eps=eps_filter) + CALL dbcsr_multiply("T", "N", 1.0_dp, matrix_A, matrix_tmp, & + 0.0_dp, matrix_out, filter_eps=eps_filter) ELSE - CALL copy_fm_to_dbcsr(fm_G, matrix_G_ao, keep_sparsity=.FALSE.) + CPABORT("Unsupported transposition pair in contract_A_B_A") END IF - CALL dbcsr_filter(matrix_G_ao, bs_env%eps_filter) - ! release only the topology; keep matrix_G_ao for the caller - CALL release_square_topology(dist=dist_ao_ao, mapped_dist=dist_row_ao) + CALL dbcsr_release(matrix_tmp) CALL timestop(handle) - END SUBROUTINE build_G_ao - -! ************************************************************************************************** -!> \brief Panel-streaming evaluation of out += scale * L_out^T (A_grid ∘ B_grid) L_out, -!> where A_grid = L_A M_A L_A^T and B_grid = L_B M_B L_B^T, WITHOUT ever forming the full -!> grid x grid objects. The grid (row) index is processed in panels of ~panel_size rows; for -!> each panel only P x grid slabs are built, Hadamard-multiplied, and contracted into the -!> (small) output. Algebraically identical to L_out^T (A_grid ∘ B_grid) L_out summed over -!> grid rows, so the result matches the non-streamed path to eps_filter. -!> -!> Mapping (L in {phi (grid x AO), Z (grid x RI)}, M the AO/RI-space operator): -!> chi : L_A=L_B=phi, M_A=G_occ_ao, M_B=G_vir_ao, L_out=Z -> RI x RI -!> Sig : L_A=phi (M_A=D/G), L_B=Z (M_B=V/W), L_out=phi -> AO x AO -!> \param L_A ... -!> \param M_A ... -!> \param L_B ... -!> \param M_B ... -!> \param L_out ... -!> \param mat_out ... -!> \param scale ... -!> \param eps ... -!> \param para_env ... -!> \param pan_first ... -!> \param pan_last ... -!> \param lb_eq_la ... -!> \param lout_eq_la ... -!> \param zero_out ... -!> \param keep_sparsity ... -!> \param centroids ... -!> \param cutoff ... -!> \param grid_occupation ... -! ************************************************************************************************** - SUBROUTINE contract_grid_panels(L_A, M_A, L_B, M_B, L_out, mat_out, scale, eps, para_env, & - pan_first, pan_last, lb_eq_la, lout_eq_la, zero_out, & - keep_sparsity, centroids, cutoff, grid_occupation) - - TYPE(dbcsr_type), INTENT(INOUT), TARGET :: L_A - TYPE(dbcsr_type), INTENT(INOUT) :: M_A - TYPE(dbcsr_type), INTENT(INOUT), TARGET :: L_B - TYPE(dbcsr_type), INTENT(INOUT) :: M_B - TYPE(dbcsr_type), INTENT(INOUT), TARGET :: L_out - TYPE(dbcsr_type), INTENT(INOUT) :: mat_out - REAL(KIND=dp), INTENT(IN) :: scale, eps - TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env - INTEGER, DIMENSION(:), INTENT(IN) :: pan_first, pan_last - LOGICAL, INTENT(IN) :: lb_eq_la, lout_eq_la, zero_out - LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), OPTIONAL :: centroids - REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff - REAL(KIND=dp), INTENT(OUT), OPTIONAL :: grid_occupation - - CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_grid_panels' - - INTEGER :: blk0, blk1, handle, ipan, & - n_grid_total, ncols_pan, nrows_pan - INTEGER, ALLOCATABLE, DIMENSION(:) :: gmap - LOGICAL :: my_keep_sparsity, use_cutoff - LOGICAL, ALLOCATABLE, DIMENSION(:) :: grid_used, usedA, usedB - TYPE(dbcsr_type) :: A_pan, B_pan, C_pan, LA_pan, LA_panC, & - LB_pan, LB_panC, Lout_pan, MA_sub, & - MB_sub, tmp2, tmpA, tmpB - TYPE(dbcsr_type), POINTER :: RB_A, RB_B, RB_out - TYPE(dbcsr_type), TARGET :: LA_near, LB_near, Lout_near - - CALL timeset(routineN, handle) - - my_keep_sparsity = .FALSE. - IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity - use_cutoff = PRESENT(centroids) .AND. PRESENT(cutoff) - IF (use_cutoff) use_cutoff = cutoff > 0.0_dp - IF (PRESENT(grid_occupation)) grid_occupation = 0.0_dp - - CALL dbcsr_get_info(L_A, nfullrows_total=n_grid_total) - - IF (zero_out) CALL dbcsr_set(mat_out, 0.0_dp) - - DO ipan = 1, SIZE(pan_first) - blk0 = pan_first(ipan) - blk1 = pan_last(ipan) - - ! phi/Z panel slices (P x n) - CALL extract_grid_panel(L_A, blk0, blk1, LA_pan) - IF (.NOT. lb_eq_la) CALL extract_grid_panel(L_B, blk0, blk1, LB_pan) - IF (.NOT. lout_eq_la) CALL extract_grid_panel(L_out, blk0, blk1, Lout_pan) - - ! Which AO/RI atoms (column blocks) actually touch this panel: the inner index of - ! every multiply below is restricted to them, so only the matching rows of the - ! system-wide operators M_A/M_B ever enter Cannon (exact: dropped rows meet zeros). - CALL collect_used_col_blocks(LA_pan, para_env, usedA) - IF (.NOT. lb_eq_la) THEN - CALL collect_used_col_blocks(LB_pan, para_env, usedB) - ELSE - IF (ALLOCATED(usedB)) DEALLOCATE (usedB) - ALLOCATE (usedB, SOURCE=usedA) - END IF - IF (.NOT. (ANY(usedA) .AND. ANY(usedB))) THEN - ! empty panel slice: its Hadamard contribution is exactly zero on all ranks - CALL dbcsr_release(LA_pan) - IF (.NOT. lb_eq_la) CALL dbcsr_release(LB_pan) - IF (.NOT. lout_eq_la) CALL dbcsr_release(Lout_pan) - CYCLE - END IF - - ! Grid rows within reach of the panel: with the CUTOFF_RADIUS_RL_W truncation only - ! they can appear as columns of the panel products / inner rows of the L_out multiply, - ! so the system-wide phi/Z right operands are cut down to this neighborhood slice - ! (local extraction, zero communication; exact w.r.t. the geo template). - IF (use_cutoff) THEN - CALL mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, grid_used) - CALL extract_masked_blocks(L_A, grid_used, LA_near, compress_rows=.TRUE., blk_map=gmap) - IF (.NOT. lb_eq_la) CALL extract_masked_blocks(L_B, grid_used, LB_near, compress_rows=.TRUE.) - IF (.NOT. lout_eq_la) CALL extract_masked_blocks(L_out, grid_used, Lout_near, compress_rows=.TRUE.) - RB_A => LA_near - ELSE - RB_A => L_A - END IF - IF (lb_eq_la) THEN - RB_B => RB_A - ELSE IF (use_cutoff) THEN - RB_B => LB_near - ELSE - RB_B => L_B - END IF - IF (lout_eq_la) THEN - RB_out => RB_A - ELSE IF (use_cutoff) THEN - RB_out => Lout_near - ELSE - RB_out => L_out - END IF - - ! A_pan = LA_pan * M_A * L_A^T (P x grid_near). - ! When cutoff is active, A_pan is pre-seeded with only nearby blocks via - ! build_geo_template_panel, and the multiply uses retain_sparsity to skip - ! computing distant blocks entirely (exact: they are zero by locality). - CALL extract_masked_blocks(LA_pan, usedA, LA_panC, compress_rows=.FALSE.) - CALL extract_masked_blocks(M_A, usedA, MA_sub, compress_rows=.TRUE.) - CALL create_product_matrix(LA_panC, MA_sub, 'N', 'N', tmpA) - CALL dbcsr_multiply('N', 'N', 1.0_dp, LA_panC, MA_sub, 0.0_dp, tmpA, filter_eps=eps) - CALL dbcsr_release(MA_sub) - IF (use_cutoff) THEN - CALL build_geo_template_panel(LA_pan, LA_near, centroids, cutoff, blk0, A_pan, & - col_map=gmap) - ELSE - CALL create_product_matrix(tmpA, RB_A, 'N', 'T', A_pan) - END IF - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpA, RB_A, 0.0_dp, A_pan, & - filter_eps=eps, retain_sparsity=use_cutoff) - CALL dbcsr_release(tmpA) - - ! Grid-basis occupation of A_pan = φ G φ^T, accumulated over ALL panels into the - ! occupation of the (never formed) full grid x grid object: - ! sum_panels nnz(A_pan) / n_grid^2, with nnz = occ * pan_rows * pan_cols. - ! Panel-independent by construction -- a single-panel sample would instead report the - ! local neighbor count of whichever region happens to land in that panel. - IF (PRESENT(grid_occupation)) THEN - CALL dbcsr_get_info(A_pan, nfullrows_total=nrows_pan, nfullcols_total=ncols_pan) - grid_occupation = grid_occupation + dbcsr_get_occupation(A_pan)* & - REAL(ncols_pan, dp)*REAL(nrows_pan, dp)/ & - (REAL(n_grid_total, dp)*REAL(n_grid_total, dp)) - END IF - - ! B_pan = LB_pan * M_B * L_B^T (P x grid_near); reuse the L_A slices when L_B == L_A. - ! With keep_sparsity, B_pan is pre-populated with A_pan's block structure so that - ! retain_sparsity forces the final multiply to fill only those blocks (exact for ∘). - IF (lb_eq_la) THEN - CALL extract_masked_blocks(M_B, usedA, MB_sub, compress_rows=.TRUE.) - CALL create_product_matrix(LA_panC, MB_sub, 'N', 'N', tmpB) - CALL dbcsr_multiply('N', 'N', 1.0_dp, LA_panC, MB_sub, 0.0_dp, tmpB, filter_eps=eps) - ELSE - CALL extract_masked_blocks(LB_pan, usedB, LB_panC, compress_rows=.FALSE.) - CALL extract_masked_blocks(M_B, usedB, MB_sub, compress_rows=.TRUE.) - CALL create_product_matrix(LB_panC, MB_sub, 'N', 'N', tmpB) - CALL dbcsr_multiply('N', 'N', 1.0_dp, LB_panC, MB_sub, 0.0_dp, tmpB, filter_eps=eps) - CALL dbcsr_release(LB_panC) - END IF - CALL dbcsr_release(MB_sub) - IF (my_keep_sparsity) THEN - CALL dbcsr_create(B_pan, template=A_pan) - CALL dbcsr_copy(B_pan, A_pan) - CALL dbcsr_set(B_pan, 0.0_dp) - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_B, 0.0_dp, B_pan, & - filter_eps=eps, retain_sparsity=.TRUE.) - ELSE - CALL create_product_matrix(tmpB, RB_B, 'N', 'T', B_pan) - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_B, 0.0_dp, B_pan, filter_eps=eps) - END IF - CALL dbcsr_release(tmpB) - CALL dbcsr_release(LA_panC) - - ! C_pan = scale * (A_pan ∘ B_pan) (P x grid_near) - CALL dbcsr_create(C_pan, template=A_pan) - CALL hadamard_product(A_pan, B_pan, C_pan, scale) - CALL dbcsr_release(A_pan) - CALL dbcsr_release(B_pan) - - ! tmp2 = C_pan * L_out (P x n_out; inner index restricted to the neighborhood) - CALL create_product_matrix(C_pan, RB_out, 'N', 'N', tmp2) - CALL dbcsr_multiply('N', 'N', 1.0_dp, C_pan, RB_out, 0.0_dp, tmp2, filter_eps=eps) - CALL dbcsr_release(C_pan) - - ! mat_out += L_out_pan^T * tmp2 (accumulate: beta = 1) - IF (lout_eq_la) THEN - CALL dbcsr_multiply('T', 'N', 1.0_dp, LA_pan, tmp2, 1.0_dp, mat_out, filter_eps=eps) - ELSE - CALL dbcsr_multiply('T', 'N', 1.0_dp, Lout_pan, tmp2, 1.0_dp, mat_out, filter_eps=eps) - CALL dbcsr_release(Lout_pan) - END IF - CALL dbcsr_release(tmp2) - IF (.NOT. lb_eq_la) CALL dbcsr_release(LB_pan) - CALL dbcsr_release(LA_pan) - IF (use_cutoff) THEN - CALL dbcsr_release(LA_near) - IF (.NOT. lb_eq_la) CALL dbcsr_release(LB_near) - IF (.NOT. lout_eq_la) CALL dbcsr_release(Lout_near) - END IF - - END DO - - CALL timestop(handle) - - END SUBROUTINE contract_grid_panels - -! ************************************************************************************************** -!> \brief Σ^c-specific panel loop: computes both the occupied (neg) and virtual (pos) contributions -!> in a single pass over grid panels, forming W_pan = Z_panel × W_aux × Z^T only ONCE per -!> panel and reusing it for both the G^occ and G^vir Hadamard contractions. -!> -!> Computes: -!> mat_Sigma_neg = φ^T ( (φ G^occ φ^T) ∘ (Z W^MIC Z^T) ) φ -!> mat_Sigma_pos = φ^T ( (φ G^vir φ^T) ∘ (Z W^MIC Z^T) ) φ -!> -!> \param mat_phi ... -!> \param mat_Z ... -!> \param mat_G_occ_ao ... -!> \param mat_G_vir_ao ... -!> \param mat_W_aux ... -!> \param mat_Sigma_neg ... -!> \param mat_Sigma_pos ... -!> \param eps ... -!> \param para_env ... -!> \param pan_first ... -!> \param pan_last ... -!> \param keep_sparsity ... -!> \param centroids ... -!> \param cutoff ... -! ************************************************************************************************** - SUBROUTINE contract_grid_panels_sigma_c(mat_phi, mat_Z, mat_G_occ_ao, mat_G_vir_ao, & - mat_W_aux, mat_Sigma_neg, mat_Sigma_pos, eps, para_env, & - pan_first, pan_last, keep_sparsity, centroids, cutoff) - - TYPE(dbcsr_type), INTENT(INOUT), TARGET :: mat_phi, mat_Z - TYPE(dbcsr_type), INTENT(INOUT) :: mat_G_occ_ao, mat_G_vir_ao, mat_W_aux - TYPE(dbcsr_type), INTENT(INOUT) :: mat_Sigma_neg, mat_Sigma_pos - REAL(KIND=dp), INTENT(IN) :: eps - TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env - INTEGER, DIMENSION(:), INTENT(IN) :: pan_first, pan_last - LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), OPTIONAL :: centroids - REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff - - CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_grid_panels_sigma_c' - - INTEGER :: blk0, blk1, handle, ipan - INTEGER, ALLOCATABLE, DIMENSION(:) :: gmap - LOGICAL :: my_keep_sparsity, use_cutoff - LOGICAL, ALLOCATABLE, DIMENSION(:) :: grid_used, used_ao, used_ri - TYPE(dbcsr_type) :: A_occ, A_vir, C_pan, G_occ_sub, & - G_vir_sub, phi_pan, phi_panC, tmp2, & - tmpA, tmpB, W_pan, W_sub, Z_pan, & - Z_panC - TYPE(dbcsr_type), POINTER :: RB_phi, RB_Z - TYPE(dbcsr_type), TARGET :: phi_near, Z_near - - CALL timeset(routineN, handle) - - my_keep_sparsity = .FALSE. - IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity - use_cutoff = PRESENT(centroids) .AND. PRESENT(cutoff) - IF (use_cutoff) use_cutoff = cutoff > 0.0_dp - - CALL dbcsr_set(mat_Sigma_neg, 0.0_dp) - CALL dbcsr_set(mat_Sigma_pos, 0.0_dp) - - DO ipan = 1, SIZE(pan_first) - blk0 = pan_first(ipan) - blk1 = pan_last(ipan) - - CALL extract_grid_panel(mat_phi, blk0, blk1, phi_pan) - CALL extract_grid_panel(mat_Z, blk0, blk1, Z_pan) - - ! AO/RI atoms touching this panel: only the matching rows of G_occ/G_vir/W ever - ! enter the multiplies below (exact: dropped rows meet zero columns of the panel). - CALL collect_used_col_blocks(phi_pan, para_env, used_ao) - CALL collect_used_col_blocks(Z_pan, para_env, used_ri) - IF (.NOT. (ANY(used_ao) .AND. ANY(used_ri))) THEN - CALL dbcsr_release(phi_pan) - CALL dbcsr_release(Z_pan) - CYCLE - END IF - - ! Neighborhood slices of phi/Z (grid rows within cutoff of the panel): they replace - ! the system-wide right operands in every multiply (local extraction, zero comm). - IF (use_cutoff) THEN - CALL mask_grid_blocks_near_panel(centroids, blk0, blk1, cutoff, grid_used) - CALL extract_masked_blocks(mat_phi, grid_used, phi_near, compress_rows=.TRUE., blk_map=gmap) - CALL extract_masked_blocks(mat_Z, grid_used, Z_near, compress_rows=.TRUE.) - RB_phi => phi_near - RB_Z => Z_near - ELSE - RB_phi => mat_phi - RB_Z => mat_Z - END IF - - CALL extract_masked_blocks(phi_pan, used_ao, phi_panC, compress_rows=.FALSE.) - CALL extract_masked_blocks(Z_pan, used_ri, Z_panC, compress_rows=.FALSE.) - CALL extract_masked_blocks(mat_G_occ_ao, used_ao, G_occ_sub, compress_rows=.TRUE.) - CALL extract_masked_blocks(mat_G_vir_ao, used_ao, G_vir_sub, compress_rows=.TRUE.) - CALL extract_masked_blocks(mat_W_aux, used_ri, W_sub, compress_rows=.TRUE.) - - ! A_occ = phi_pan × G_occ × phi^T (built first so W_pan can inherit its pattern). - ! With cutoff active, A_occ is pre-seeded with geo-local blocks so that the - ! phi^T multiply uses retain_sparsity and never computes distant blocks. - CALL create_product_matrix(phi_panC, G_occ_sub, 'N', 'N', tmpA) - CALL dbcsr_multiply('N', 'N', 1.0_dp, phi_panC, G_occ_sub, 0.0_dp, tmpA, filter_eps=eps) - IF (use_cutoff) THEN - CALL build_geo_template_panel(phi_pan, phi_near, centroids, cutoff, blk0, A_occ, & - col_map=gmap) - ELSE - CALL create_product_matrix(tmpA, RB_phi, 'N', 'T', A_occ) - END IF - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpA, RB_phi, 0.0_dp, A_occ, & - filter_eps=eps, retain_sparsity=use_cutoff) - CALL dbcsr_release(tmpA) - CALL dbcsr_release(G_occ_sub) - - ! A_vir = phi_pan × G_vir × phi^T (same pre-screen as A_occ) - CALL create_product_matrix(phi_panC, G_vir_sub, 'N', 'N', tmpA) - CALL dbcsr_multiply('N', 'N', 1.0_dp, phi_panC, G_vir_sub, 0.0_dp, tmpA, filter_eps=eps) - IF (use_cutoff) THEN - CALL build_geo_template_panel(phi_pan, phi_near, centroids, cutoff, blk0, A_vir, & - col_map=gmap) - ELSE - CALL create_product_matrix(tmpA, RB_phi, 'N', 'T', A_vir) - END IF - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpA, RB_phi, 0.0_dp, A_vir, & - filter_eps=eps, retain_sparsity=use_cutoff) - CALL dbcsr_release(tmpA) - CALL dbcsr_release(G_vir_sub) - - ! W_pan = Z_pan × W_aux × Z^T (computed once, reused for both Σ^c terms). - ! With keep_sparsity, W_pan is pre-seeded with the union of A_occ and A_vir block - ! patterns so that retain_sparsity forces the multiply to fill only those blocks: - ! exact since W outside G_occ∪G_vir is multiplied by zero in the Hadamard. - CALL create_product_matrix(Z_panC, W_sub, 'N', 'N', tmpB) - CALL dbcsr_multiply('N', 'N', 1.0_dp, Z_panC, W_sub, 0.0_dp, tmpB, filter_eps=eps) - IF (my_keep_sparsity) THEN - CALL dbcsr_create(W_pan, template=A_occ) - CALL dbcsr_copy(W_pan, A_occ) - CALL dbcsr_add(W_pan, A_vir, 1.0_dp, 1.0_dp) - CALL dbcsr_set(W_pan, 0.0_dp) - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_Z, 0.0_dp, W_pan, & - filter_eps=eps, retain_sparsity=.TRUE.) - ELSE - CALL create_product_matrix(tmpB, RB_Z, 'N', 'T', W_pan) - CALL dbcsr_multiply('N', 'T', 1.0_dp, tmpB, RB_Z, 0.0_dp, W_pan, filter_eps=eps) - END IF - CALL dbcsr_release(tmpB) - CALL dbcsr_release(W_sub) - CALL dbcsr_release(phi_panC) - CALL dbcsr_release(Z_panC) - - ! Σ^c_neg: φ^T ( A_occ ∘ W_pan ) φ - CALL dbcsr_create(C_pan, template=A_occ) - CALL hadamard_product(A_occ, W_pan, C_pan, 1.0_dp) - CALL dbcsr_release(A_occ) - CALL create_product_matrix(C_pan, RB_phi, 'N', 'N', tmp2) - CALL dbcsr_multiply('N', 'N', 1.0_dp, C_pan, RB_phi, 0.0_dp, tmp2, filter_eps=eps) - CALL dbcsr_release(C_pan) - CALL dbcsr_multiply('T', 'N', 1.0_dp, phi_pan, tmp2, 1.0_dp, mat_Sigma_neg, filter_eps=eps) - CALL dbcsr_release(tmp2) - - ! Σ^c_pos: φ^T ( A_vir ∘ W_pan ) φ — W_pan reused - CALL dbcsr_create(C_pan, template=A_vir) - CALL hadamard_product(A_vir, W_pan, C_pan, 1.0_dp) - CALL dbcsr_release(A_vir) - CALL create_product_matrix(C_pan, RB_phi, 'N', 'N', tmp2) - CALL dbcsr_multiply('N', 'N', 1.0_dp, C_pan, RB_phi, 0.0_dp, tmp2, filter_eps=eps) - CALL dbcsr_release(C_pan) - CALL dbcsr_multiply('T', 'N', 1.0_dp, phi_pan, tmp2, 1.0_dp, mat_Sigma_pos, filter_eps=eps) - CALL dbcsr_release(tmp2) - - CALL dbcsr_release(W_pan) - CALL dbcsr_release(Z_pan) - CALL dbcsr_release(phi_pan) - IF (use_cutoff) THEN - CALL dbcsr_release(phi_near) - CALL dbcsr_release(Z_near) - END IF - - END DO - - CALL timestop(handle) - - END SUBROUTINE contract_grid_panels_sigma_c + END SUBROUTINE contract_A_B_A ! ************************************************************************************************** !> \brief Computes C = A ◦ B (Element-wise Hadamard product) for sparse DBCSR matrices. @@ -3805,6 +1669,7 @@ CONTAINS !> \param matrix_C ... !> \param fac (Scaling factor applied to the product) ! ************************************************************************************************** + SUBROUTINE hadamard_product(matrix_A, matrix_B, matrix_C, fac) TYPE(dbcsr_type), INTENT(INOUT) :: matrix_A, matrix_B, matrix_C @@ -3841,19 +1706,13 @@ CONTAINS END SUBROUTINE hadamard_product ! ************************************************************************************************** -!> \brief Computes the screened Coulomb interaction on the imaginary-time grid, entirely in the -!> RI auxiliary (PQ) basis: -!> χ_PQ(iω) = Σ_τ w(ω,τ) cos(ωτ) χ_PQ(iτ) (cosine transform) -!> ε(iω) = Id - V^0.5 M^-1 χ(iω) M^-1 V^0.5 (dielectric function) -!> W(iω) = V^0.5 ( ε^-1(iω) - Id ) V^0.5 (correlation part only) -!> W(iτ) = Σ_ω w̃(τ,ω) cos(ωτ) W(iω) (back transform) -!> W(iτ) <- M^-1 W(iτ) M^-1 (fold in the RI metric) -!> where V is the bare Coulomb matrix and M the RI metric. +!> \brief Compute screened Coulomb interaction matrix !> \param bs_env ... !> \param qs_env ... !> \param mat_chi_Gamma_tau ... !> \param fm_W_time ... ! ************************************************************************************************** + SUBROUTINE compute_W(bs_env, qs_env, mat_chi_Gamma_tau, fm_W_time) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(qs_environment_type), POINTER :: qs_env @@ -3898,7 +1757,7 @@ CONTAINS CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_W_time) IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & + WRITE (bs_env%unit_nr, '(T2,A,T55,A,F10.1,A)') & 'Computed W(iτ),', ' Execution time', m_walltime() - t1, ' s' END IF @@ -3925,7 +1784,7 @@ CONTAINS CALL fm_write(bs_env%fm_W_MIC_freq_zero, 0, "W_freq_rtp", qs_env) ! Report calculation IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,T57,A,F7.1,A)') & + WRITE (bs_env%unit_nr, '(T2,A,T55,A,F10.1,A)') & 'Computed W(0),', ' Execution time', m_walltime() - t1, ' s' END IF END IF @@ -3937,15 +1796,14 @@ CONTAINS END SUBROUTINE compute_W ! ************************************************************************************************** -!> \brief Computes the static RI-basis Coulomb operators entering the dielectric function: -!> the bare Coulomb matrix V_PQ(k=0), its Cholesky/matrix square root V^0.5, and -!> M^-1 V^0.5 with M the RI metric (2c integrals of the RI_METRIC operator). +!> \brief Computes V, V^0.5, and M^-1 * V^0.5 !> \param bs_env ... !> \param qs_env ... !> \param fm_V ... !> \param fm_V_sqrt ... !> \param fm_Minv_Vsqrt ... ! ************************************************************************************************** + SUBROUTINE compute_V_MinvVsqrt(bs_env, qs_env, fm_V, fm_V_sqrt, fm_Minv_Vsqrt) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(qs_environment_type), POINTER :: qs_env @@ -4043,17 +1901,14 @@ CONTAINS END SUBROUTINE compute_V_MinvVsqrt ! ************************************************************************************************** -!> \brief Computes the screened interaction at one imaginary frequency: -!> ε(iω_j) = Id - (M^-1 V^0.5)^T χ(iω_j) (M^-1 V^0.5) -!> W(iω_j) = V^0.5^T ( ε^-1(iω_j) - Id ) V^0.5 -!> ε is inverted via Cholesky; if that fails due to conditioning, via -!> eigendecomposition (cp_fm_power) with eigenvalue filtering. +!> \brief Computes W(iω) from χ_PQ(iω_j) !> \param bs_env ... !> \param fm_chi_freq_j ... !> \param fm_V_sqrt ... !> \param fm_Minv_Vsqrt ... !> \param fm_W_freq_j ... ! ************************************************************************************************** + SUBROUTINE compute_fm_W_freq(bs_env, fm_chi_freq_j, fm_V_sqrt, fm_Minv_Vsqrt, fm_W_freq_j) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(cp_fm_type), INTENT(IN) :: fm_chi_freq_j, fm_V_sqrt, fm_Minv_Vsqrt @@ -4125,10 +1980,11 @@ CONTAINS END SUBROUTINE compute_fm_W_freq ! ************************************************************************************************** -!> \brief Adds a real scalar value to the diagonal of a real full matrix +!> \brief Adds a real scalar value to the diagonal of a real full matrix (fm) !> \param fm ... !> \param alpha ... ! ************************************************************************************************** + SUBROUTINE fm_add_on_diag(fm, alpha) TYPE(cp_fm_type), INTENT(INOUT) :: fm REAL(KIND=dp), INTENT(IN) :: alpha @@ -4192,16 +2048,14 @@ CONTAINS END SUBROUTINE clean_lower_part ! ************************************************************************************************** -!> \brief Computes the exact-exchange part of the GW self-energy: -!> D_μν = Σ_n^occ C_μn C_νn (density matrix = G^occ at τ=0) -!> V^tr_PQ = M^-1 (P|Q)_trunc M^-1 (truncated Coulomb, RI basis) -!> Σ^x_λσ(k=0) = -Σ_ll' Φ_λ(r_l) [ (φ D φ^T)_ll' ∘ (Z V^tr Z^T)_ll' ] Φ_σ(r_l') +!> \brief Computes the exact exchange part of the GW self-energy !> \param bs_env ... !> \param qs_env ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... !> \param fm_Sigma_x_Gamma ... ! ************************************************************************************************** + SUBROUTINE compute_Sigma_x(bs_env, qs_env, mat_phi_mu_l, mat_Z_lP, fm_Sigma_x_Gamma) TYPE(post_scf_bandstructure_type), POINTER :: bs_env @@ -4212,13 +2066,14 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Sigma_x' INTEGER :: handle, ispin - INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last - INTEGER, DIMENSION(:), POINTER :: blk_aux, dist_row_aux + INTEGER, DIMENSION(:), POINTER :: blk_aux, blk_grid, dist_col_grid, & + dist_row_aux REAL(KIND=dp) :: t1 TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma - TYPE(dbcsr_distribution_type) :: dist_aux_aux - TYPE(dbcsr_type) :: mat_Sigma_x_Gamma, matrix_D_ao, & - matrix_V_aux + TYPE(dbcsr_distribution_type) :: dist_aux_aux, dist_grid_grid + TYPE(dbcsr_type) :: mat_Sigma_x_Gamma, matrix_D_grid, & + matrix_Sigma_x_grid, matrix_V_aux, & + matrix_V_grid CALL timeset(routineN, handle) @@ -4231,13 +2086,15 @@ CONTAINS CALL dbcsr_create(mat_Sigma_x_Gamma, template=bs_env%mat_ao_ao%matrix) - CALL resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) + ! ========================================================================= + ! 1. SETUP CORE TOPOLOGIES + ! ========================================================================= + CALL setup_square_topology(mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, dist_col_grid) + CALL setup_square_topology(mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) ! ========================================================================= - ! 1. COMPUTE V^tr_PQ (RI x RI) + ! 2. COMPUTE V^tr_ll' ! ========================================================================= - CALL setup_square_topology(mat_Z_lP, dist_aux_aux, blk_aux, dist_row_aux) - CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & bs_env%trunc_coulomb, do_kpoints=.FALSE.) @@ -4245,40 +2102,38 @@ CONTAINS CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) CALL dbcsr_create(matrix_V_aux, "V_aux", dist_aux_aux, dbcsr_type_no_symmetry, blk_aux, blk_aux) - ! Optional CUTOFF_RADIUS_G_W operator truncation + filter (see build_G_ao) - IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp .AND. & - ALLOCATED(bs_env%ri_rs%atom_centers)) THEN - CALL reserve_blocks_within_radius(matrix_V_aux, bs_env%ri_rs%atom_centers, & - bs_env%ri_rs%cutoff_radius_g_w) - CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.TRUE.) - ELSE - CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.FALSE.) - END IF - CALL dbcsr_filter(matrix_V_aux, bs_env%eps_filter) + CALL dbcsr_create(matrix_V_grid, "V_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + + CALL copy_fm_to_dbcsr(fm_Vtr_Gamma(1, 1), matrix_V_aux, keep_sparsity=.FALSE.) + + ! V^tr_ll' = sum_PQ Z_lP V^trunc_PQ Z_l'Q + CALL contract_A_B_A("N", "T", mat_Z_lP, matrix_V_aux, matrix_V_grid, bs_env%eps_filter) + CALL dbcsr_release(matrix_V_aux) ! ========================================================================= - ! 2. SPIN LOOP FOR EXACT EXCHANGE - ! Σ^x_λσ = -Σ_ll' Φ_λ(r_l) ( D_ll' V^tr_ll' ) Φ_σ(r_l') - ! = -φ^T ( (φ D φ^T) ∘ (Z V^tr Z^T) ) φ + ! 3. SPIN LOOP FOR EXACT EXCHANGE ! ========================================================================= DO ispin = 1, bs_env%n_spin - ! AO-space density matrix D_µν = G^occ at τ = 0 - CALL build_G_ao(bs_env, 0.0_dp, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_D_ao) + ! Density matrix on grid is essentially G_occ at tau = 0.0 + ! D_µν = sum_n^occ C_µn C_νn + ! D_ll' = sum_µν Φ_µ(r_l) D_µν Φ_ν(r_l') + CALL dbcsr_create(matrix_D_grid, "D_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + CALL build_G_grid(bs_env, 0.0_dp, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_D_grid, bs_env%eps_filter) - CALL contract_grid_panels(L_A=mat_phi_mu_l, M_A=matrix_D_ao, & - L_B=mat_Z_lP, M_B=matrix_V_aux, & - L_out=mat_phi_mu_l, mat_out=mat_Sigma_x_Gamma, & - scale=1.0_dp, eps=bs_env%eps_filter, & - para_env=bs_env%para_env, & - pan_first=pan_first, pan_last=pan_last, & - lb_eq_la=.FALSE., lout_eq_la=.TRUE., zero_out=.TRUE., & - keep_sparsity=bs_env%ri_rs%keep_sparsity_rirs, & - centroids=bs_env%ri_rs%chunk_centroids, & - cutoff=bs_env%ri_rs%cutoff_radius_v_w) + ! Element-wise Hadamard product: Σ^x_grid = D_grid ◦ V_grid + ! Σ^x_ll' = D_ll' * V^tr_ll' + CALL dbcsr_create(matrix_Sigma_x_grid, template=matrix_V_grid) + CALL hadamard_product(matrix_D_grid, matrix_V_grid, matrix_Sigma_x_grid, 1.0_dp) + + CALL dbcsr_release(matrix_D_grid) + + ! Transform back to AO basis: Σ^x_ao = -1.0 * phi^T * Σ^x_grid * phi + ! Σ^x_λσ = -sum_ll' Φ_λ(r_l) Σ^x_ll' Φ_σ(r_l') + CALL contract_A_B_A("T", "N", mat_phi_mu_l, matrix_Sigma_x_grid, mat_Sigma_x_Gamma, bs_env%eps_filter) CALL dbcsr_scale(mat_Sigma_x_Gamma, -1.0_dp) - CALL dbcsr_release(matrix_D_ao) + CALL dbcsr_release(matrix_Sigma_x_grid) ! Data I/O and Export to CP2K Full Matrices CALL copy_dbcsr_to_fm(mat_Sigma_x_Gamma, fm_Sigma_x_Gamma(ispin)) @@ -4292,11 +2147,11 @@ CONTAINS END IF ! ========================================================================= - ! 3. CLEANUP + ! 4. CLEANUP ! ========================================================================= - CALL dbcsr_release(matrix_V_aux) - CALL dbcsr_release(mat_Sigma_x_Gamma) - CALL release_square_topology(dist=dist_aux_aux, mapped_dist=dist_row_aux) + CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid, & + m1=mat_Sigma_x_Gamma, m2=matrix_V_grid) + CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux) CALL cp_fm_release(fm_Vtr_Gamma) @@ -4305,15 +2160,14 @@ CONTAINS END SUBROUTINE compute_Sigma_x ! ************************************************************************************************** -!> \brief Computes the correlation part of the GW self-energy on the imaginary-time grid: -!> Σ^c_λσ(iτ<0) = -Σ_ll' Φ_λ(r_l) [ (φ G^occ φ^T)_ll' ∘ (Z W^MIC Z^T)_ll' ] Φ_σ(r_l') -!> Σ^c_λσ(iτ>0) = +Σ_ll' Φ_λ(r_l) [ (φ G^vir φ^T)_ll' ∘ (Z W^MIC Z^T)_ll' ] Φ_σ(r_l') +!> \brief Computes the correlation part of the GW self-energy !> \param bs_env ... !> \param fm_W_time ... !> \param mat_phi_mu_l ... !> \param mat_Z_lP ... !> \param fm_Sigma_c_Gamma_time ... ! ************************************************************************************************** + SUBROUTINE compute_Sigma_c(bs_env, fm_W_time, mat_phi_mu_l, mat_Z_lP, fm_Sigma_c_Gamma_time) TYPE(post_scf_bandstructure_type), POINTER :: bs_env @@ -4324,22 +2178,21 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Sigma_c' INTEGER :: handle, i_t, ispin - INTEGER, ALLOCATABLE, DIMENSION(:) :: pan_first, pan_last - INTEGER, DIMENSION(:), POINTER :: blk_aux, dist_row_aux + INTEGER, DIMENSION(:), POINTER :: blk_aux, blk_grid, dist_col_grid, & + dist_row_aux REAL(KIND=dp) :: t1, tau - TYPE(dbcsr_distribution_type) :: dist_aux_aux + TYPE(dbcsr_distribution_type) :: dist_aux_aux, dist_grid_grid TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_Sigma_neg_tau, mat_Sigma_pos_tau - TYPE(dbcsr_type) :: matrix_G_occ_ao, matrix_G_vir_ao, & - matrix_W_aux + TYPE(dbcsr_type) :: matrix_G_occ_grid, matrix_G_vir_grid, matrix_Sigma_neg_grid, & + matrix_Sigma_pos_grid, matrix_W_aux, matrix_W_grid CALL timeset(routineN, handle) ! ========================================================================= - ! 1. SETUP AUXILIARY TOPOLOGY AND PRE-ALLOCATE OUTPUT ARRAYS + ! 1. SETUP CORE TOPOLOGIES AND PRE-ALLOCATE OUTPUT ARRAYS ! ========================================================================= - CALL setup_square_topology(mat_Z_lP, dist_aux_aux, blk_aux, dist_row_aux) - - CALL resolve_grid_panels(bs_env, mat_phi_mu_l, pan_first, pan_last) + CALL setup_square_topology(mat_phi_mu_l, 'ROW', dist_grid_grid, blk_grid, dist_col_grid) + CALL setup_square_topology(mat_Z_lP, 'COL', dist_aux_aux, blk_aux, dist_row_aux) ! Pre-allocate local DBCSR matrices to act as targets for final output NULLIFY (mat_Sigma_neg_tau, mat_Sigma_pos_tau) @@ -4356,58 +2209,87 @@ CONTAINS END DO ! ========================================================================= - ! 2. IMAGINARY TIME LOOP - ! Σ^c_neg_λσ(iτ) = -φ^T ( (φ G^occ φ^T) ∘ (Z W^MIC Z^T) ) φ - ! Σ^c_pos_λσ(iτ) = φ^T ( (φ G^vir φ^T) ∘ (Z W^MIC Z^T) ) φ + ! 2. MAIN IMAGINARY TIME LOOP ! ========================================================================= DO i_t = 1, bs_env%num_time_freq_points tau = bs_env%imag_time_points(i_t) + ! ------------------------------------------------------------------- + ! Compute W_grid = Z * W_aux * Z^T + ! ------------------------------------------------------------------- CALL dbcsr_create(matrix_W_aux, "W_aux", dist_aux_aux, dbcsr_type_no_symmetry, blk_aux, blk_aux) - IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp .AND. & - ALLOCATED(bs_env%ri_rs%atom_centers)) THEN - CALL reserve_blocks_within_radius(matrix_W_aux, bs_env%ri_rs%atom_centers, & - bs_env%ri_rs%cutoff_radius_g_w) - CALL copy_fm_to_dbcsr(fm_W_time(i_t), matrix_W_aux, keep_sparsity=.TRUE.) - ELSE - CALL copy_fm_to_dbcsr(fm_W_time(i_t), matrix_W_aux, keep_sparsity=.FALSE.) - END IF - CALL dbcsr_filter(matrix_W_aux, bs_env%eps_filter) + CALL dbcsr_create(matrix_W_grid, "W_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + + CALL copy_fm_to_dbcsr(fm_W_time(i_t), matrix_W_aux, keep_sparsity=.FALSE.) + + ! W^MIC_ll'(iτ,k=0) = sum_PQ Z_lP W^MIC_PQ(iτ) Z_l'Q + CALL contract_A_B_A("N", "T", mat_Z_lP, matrix_W_aux, matrix_W_grid, bs_env%eps_filter) + + CALL dbcsr_release(matrix_W_aux) ! Clean up aux basis immediately DO ispin = 1, bs_env%n_spin t1 = m_walltime() - ! AO-space Green's functions G^occ_µν, G^vir_µν (dense AO x AO, small) - CALL build_G_ao(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_G_occ_ao) - CALL build_G_ao(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, matrix_G_vir_ao) + ! ------------------------------------------------------------------- + ! A. Transform Green's Functions to the Grid + ! ------------------------------------------------------------------- + CALL dbcsr_create(matrix_G_occ_grid, "G_occ_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) + CALL dbcsr_create(matrix_G_vir_grid, "G_vir_grid", dist_grid_grid, dbcsr_type_no_symmetry, blk_grid, blk_grid) - ! Σ^c_neg and Σ^c_pos in a single panel loop: W_pan = Z_panel × W × Z^T built once - CALL contract_grid_panels_sigma_c(mat_phi=mat_phi_mu_l, mat_Z=mat_Z_lP, & - mat_G_occ_ao=matrix_G_occ_ao, & - mat_G_vir_ao=matrix_G_vir_ao, & - mat_W_aux=matrix_W_aux, & - mat_Sigma_neg=mat_Sigma_neg_tau(i_t, ispin)%matrix, & - mat_Sigma_pos=mat_Sigma_pos_tau(i_t, ispin)%matrix, & - eps=bs_env%eps_filter, & - para_env=bs_env%para_env, & - pan_first=pan_first, pan_last=pan_last, & - keep_sparsity=bs_env%ri_rs%keep_sparsity_rirs, & - centroids=bs_env%ri_rs%chunk_centroids, & - cutoff=bs_env%ri_rs%cutoff_radius_v_w) + ! G^occ_µλ(i|τ|) = sum_G^occ_µλn^occ C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + ! G^occ_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^occ_µν Φ_ν(r_l') + CALL build_G_grid(bs_env, tau, ispin, .TRUE., .FALSE., mat_phi_mu_l, matrix_G_occ_grid, bs_env%eps_filter) + + ! G^vir_µλ(i|τ|) = sum_n^vir C_µn e^(-|(ϵ_n-ϵ_F)τ|) C_λn + ! G^vir_ll'(i|τ|) = sum_µν Φ_µ(r_l) G^vir_µν Φ_ν(r_l') + CALL build_G_grid(bs_env, tau, ispin, .FALSE., .TRUE., mat_phi_mu_l, matrix_G_vir_grid, bs_env%eps_filter) + + ! ------------------------------------------------------------------- + ! B. Element-wise Hadamard Products for Sigma_c on Grid + ! Σ_neg_grid = G_occ_grid ◦ W_grid + ! Σ_pos_grid = G_vir_grid ◦ W_grid + ! ------------------------------------------------------------------- + CALL dbcsr_create(matrix_Sigma_neg_grid, template=matrix_W_grid) + CALL dbcsr_create(matrix_Sigma_pos_grid, template=matrix_W_grid) + + ! Σ^c_ll'(iτ) = -G^occ_ll'(i|τ|) * W^MIC_ll'(iτ), for τ < 0 + CALL hadamard_product(matrix_G_occ_grid, matrix_W_grid, matrix_Sigma_neg_grid, 1.0_dp) + + ! Σ^c_ll'(iτ) = G^vir_ll'(i|τ|) * W^MIC_ll'(iτ), for τ > 0 + CALL hadamard_product(matrix_G_vir_grid, matrix_W_grid, matrix_Sigma_pos_grid, 1.0_dp) + + ! Instantly purge massive G_grid arrays to save memory + CALL dbcsr_release(matrix_G_occ_grid) + CALL dbcsr_release(matrix_G_vir_grid) + + ! ------------------------------------------------------------------- + ! C. Transform Sigma back to AO Basis + ! Σ_AO = phi^T * Σ_grid * phi + ! ------------------------------------------------------------------- + + ! Σ^c_λσ(iτ) = sum_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l'), for τ < 0 + CALL contract_A_B_A("T", "N", mat_phi_mu_l, matrix_Sigma_neg_grid, & + mat_Sigma_neg_tau(i_t, ispin)%matrix, bs_env%eps_filter) CALL dbcsr_scale(mat_Sigma_neg_tau(i_t, ispin)%matrix, -1.0_dp) - CALL dbcsr_release(matrix_G_occ_ao) - CALL dbcsr_release(matrix_G_vir_ao) + ! Σ^c_λσ(iτ) = sum_ll' Φ_λ(r_l) Σ^c_ll'(iτ) Φ_σ(r_l'), for τ > 0 + CALL contract_A_B_A("T", "N", mat_phi_mu_l, matrix_Sigma_pos_grid, & + mat_Sigma_pos_tau(i_t, ispin)%matrix, bs_env%eps_filter) + + ! Purge Grid Sigma arrays + CALL dbcsr_release(matrix_Sigma_neg_grid) + CALL dbcsr_release(matrix_Sigma_pos_grid) IF (bs_env%unit_nr > 0) THEN - WRITE (bs_env%unit_nr, '(T2,A,I15,A,I3,A,F7.1,A)') & - 'Computed Σ^c(iτ) for time point', i_t, ' /', bs_env%num_time_freq_points, & + WRITE (bs_env%unit_nr, '(T2,A,I10,A,I3,A,F7.1,A)') & + 'Computed Σ^c(iτ) for time point ', i_t, ' /', bs_env%num_time_freq_points, & ', Execution time', m_walltime() - t1, ' s' END IF END DO ! ispin - CALL dbcsr_release(matrix_W_aux) + ! Release the W_grid for this time point + CALL dbcsr_release(matrix_W_grid) END DO ! i_t @@ -4424,7 +2306,8 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(mat_Sigma_neg_tau) CALL dbcsr_deallocate_matrix_set(mat_Sigma_pos_tau) - CALL release_square_topology(dist=dist_aux_aux, mapped_dist=dist_row_aux) + CALL release_dbcsr_topology_and_matrices(dist=dist_grid_grid, mapped_dist=dist_col_grid) + CALL release_dbcsr_topology_and_matrices(dist=dist_aux_aux, mapped_dist=dist_row_aux) CALL delete_unnecessary_files(bs_env) CALL timestop(handle) @@ -4432,57 +2315,84 @@ CONTAINS END SUBROUTINE compute_Sigma_c ! ************************************************************************************************** -!> \brief Builds the DBCSR distribution. +!> \brief DBCSR Topology Generation !> \param matrix_template ... +!> \param dim_type ... !> \param square_dist ... !> \param blk_sizes ... !> \param mapped_dist ... ! ************************************************************************************************** - SUBROUTINE setup_square_topology(matrix_template, square_dist, blk_sizes, mapped_dist) + + SUBROUTINE setup_square_topology(matrix_template, dim_type, square_dist, blk_sizes, mapped_dist) TYPE(dbcsr_type), INTENT(IN) :: matrix_template + CHARACTER(LEN=*), INTENT(IN) :: dim_type TYPE(dbcsr_distribution_type), INTENT(OUT) :: square_dist INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: blk_sizes, mapped_dist - CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_square_topology' - - INTEGER :: handle, i, nprows - INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist + INTEGER :: i, np + INTEGER, DIMENSION(:), POINTER :: col_blk, col_dist, row_blk, row_dist TYPE(dbcsr_distribution_type) :: dist_template - CALL timeset(routineN, handle) + CALL dbcsr_get_info(matrix_template, distribution=dist_template, & + row_blk_size=row_blk, col_blk_size=col_blk) + CALL dbcsr_distribution_get(dist_template, row_dist=row_dist, col_dist=col_dist) - CALL dbcsr_get_info(matrix_template, distribution=dist_template, col_blk_size=col_blk) - CALL dbcsr_distribution_get(dist_template, col_dist=col_dist, nprows=nprows) + IF (TRIM(dim_type) == 'ROW') THEN + ! Creates ROW x ROW (e.g., Grid x Grid from mat_phi_mu_l) + blk_sizes => row_blk + np = MAXVAL(col_dist) + 1 ! npcol + ALLOCATE (mapped_dist(SIZE(blk_sizes))) + DO i = 1, SIZE(blk_sizes) + mapped_dist(i) = MOD(i - 1, np) + END DO + CALL dbcsr_distribution_new(square_dist, template=dist_template, & + row_dist=row_dist, col_dist=mapped_dist) - blk_sizes => col_blk - ALLOCATE (mapped_dist(SIZE(blk_sizes))) - DO i = 1, SIZE(blk_sizes) - mapped_dist(i) = MOD(i - 1, nprows) - END DO - CALL dbcsr_distribution_new(square_dist, template=dist_template, & - row_dist=mapped_dist, col_dist=col_dist) - - CALL timestop(handle) + ELSE IF (TRIM(dim_type) == 'COL') THEN + ! Creates COL x COL (e.g., Aux x Aux from mat_Z_lP) + blk_sizes => col_blk + np = MAXVAL(row_dist) + 1 ! nprow + ALLOCATE (mapped_dist(SIZE(blk_sizes))) + DO i = 1, SIZE(blk_sizes) + mapped_dist(i) = MOD(i - 1, np) + END DO + CALL dbcsr_distribution_new(square_dist, template=dist_template, & + row_dist=mapped_dist, col_dist=col_dist) + END IF END SUBROUTINE setup_square_topology ! ************************************************************************************************** -!> \brief Releases a distribution created by setup_square_topology. +!> \brief DBCSR matrices deallocation !> \param dist ... -!> \param mapped_dist ... +!> \param mapped_dist ... +!> \param m1 ... +!> \param m2 ... +!> \param m3 ... +!> \param m4 ... ! ************************************************************************************************** - SUBROUTINE release_square_topology(dist, mapped_dist) - TYPE(dbcsr_distribution_type), INTENT(INOUT) :: dist - INTEGER, DIMENSION(:), INTENT(INOUT), POINTER :: mapped_dist + SUBROUTINE release_dbcsr_topology_and_matrices(dist, mapped_dist, m1, m2, m3, m4) - CALL dbcsr_distribution_release(dist) - IF (ASSOCIATED(mapped_dist)) THEN - DEALLOCATE (mapped_dist) - NULLIFY (mapped_dist) + TYPE(dbcsr_distribution_type), INTENT(INOUT), & + OPTIONAL :: dist + INTEGER, DIMENSION(:), INTENT(INOUT), OPTIONAL, & + POINTER :: mapped_dist + TYPE(dbcsr_type), INTENT(INOUT), OPTIONAL :: m1, m2, m3, m4 + + IF (PRESENT(dist)) CALL dbcsr_distribution_release(dist) + IF (PRESENT(mapped_dist)) THEN + IF (ASSOCIATED(mapped_dist)) THEN + DEALLOCATE (mapped_dist) + NULLIFY (mapped_dist) + END IF END IF + IF (PRESENT(m1)) CALL dbcsr_release(m1) + IF (PRESENT(m2)) CALL dbcsr_release(m2) + IF (PRESENT(m3)) CALL dbcsr_release(m3) + IF (PRESENT(m4)) CALL dbcsr_release(m4) - END SUBROUTINE release_square_topology + END SUBROUTINE release_dbcsr_topology_and_matrices END MODULE gw_non_periodic_ri_rs diff --git a/src/gw_small_cell_full_kp.F b/src/gw_small_cell_full_kp.F index 9dc891c980..6090d40408 100644 --- a/src/gw_small_cell_full_kp.F +++ b/src/gw_small_cell_full_kp.F @@ -112,7 +112,7 @@ CONTAINS ! Σ^c_λσ^R(iτ,k=0) -> Σ^c_nn(ϵ,k); ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ,k) + Σ^x_nn(k) - v^xc_nn(k) CALL compute_QP_energies(bs_env) - CALL de_init_bs_env(qs_env, bs_env) + CALL de_init_bs_env(bs_env) CALL timestop(handle) diff --git a/src/gw_utils.F b/src/gw_utils.F index c039f425a5..e1f635b340 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -60,10 +60,14 @@ MODULE gw_utils USE distribution_2d_types, ONLY: distribution_2d_type USE gw_communication, ONLY: fm_to_local_array USE gw_integrals, ONLY: build_3c_integral_block - USE input_constants, ONLY: & - do_potential_truncated, large_cell_Gamma, large_cell_Gamma_ri_rs, non_periodic_ri_rs, & - ri_rpa_g0w0_crossing_newton, rtp_bse_kernel_ri_ao, rtp_bse_kernel_ri_rs, rtp_method_bse, & - rtp_method_bse_linearized, small_cell_full_kp, xc_none + USE input_constants, ONLY: do_potential_truncated,& + large_cell_Gamma,& + large_cell_Gamma_ri_rs,& + non_periodic_ri_rs,& + ri_rpa_g0w0_crossing_newton,& + rtp_method_bse,& + small_cell_full_kp,& + xc_none USE input_section_types, ONLY: section_vals_get,& section_vals_get_subs_vals,& section_vals_type,& @@ -135,8 +139,7 @@ MODULE gw_utils PUBLIC :: create_and_init_bs_env_for_gw, de_init_bs_env, get_i_j_atoms, & compute_xkp, time_to_freq, analyt_conti_and_print, & - add_R, is_cell_in_index_to_cell, get_V_tr_R, power, & - rtbse_resolve_rirs_flag + add_R, is_cell_in_index_to_cell, get_V_tr_R, power CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_utils' @@ -231,19 +234,15 @@ CONTAINS END SUBROUTINE create_and_init_bs_env_for_gw ! ************************************************************************************************** -!> \brief Releases the memory-heavy GW intermediates that cannot be freed in bs_env_release, -!> retaining the 3c neighbor list only when an AO-RI RT-BSE self-energy still needs it -!> \param qs_env Quickstep environment - used to resolve the RT-BSE kernel-RI setting -!> \param bs_env Bandstructure environment whose intermediates are released +!> \brief ... +!> \param bs_env ... ! ************************************************************************************************** - SUBROUTINE de_init_bs_env(qs_env, bs_env) - TYPE(qs_environment_type), POINTER :: qs_env + SUBROUTINE de_init_bs_env(bs_env) TYPE(post_scf_bandstructure_type), POINTER :: bs_env CHARACTER(LEN=*), PARAMETER :: routineN = 'de_init_bs_env' INTEGER :: handle - LOGICAL :: retain_nl_3c, rirs_kernel CALL timeset(routineN, handle) ! deallocate quantities here which: @@ -251,16 +250,8 @@ CONTAINS ! 2. consume a lot of memory and should not be kept until the quantity is ! deallocated in bs_env_release - ! nl_3c feeds only the AO-RI SEX self-energy (compute_3c_integrals); the RI-RS SEX - ! path never reads it, and AO-RI Hartree builds its own blocks. Retain iff AO-RI SEX. - retain_nl_3c = .FALSE. IF (ASSOCIATED(bs_env%nl_3c%ij_list) .AND. (bs_env%rtp_method == rtp_method_bse)) THEN - CALL rtbse_resolve_rirs_flag(qs_env, bs_env, rirs_kernel=rirs_kernel) - retain_nl_3c = .NOT. rirs_kernel - END IF - - IF (retain_nl_3c) THEN - IF (bs_env%unit_nr > 0) WRITE (bs_env%unit_nr, *) "Retaining nl_3c for AO-RI RT-BSE self-energy" + IF (bs_env%unit_nr > 0) WRITE (bs_env%unit_nr, *) "Retaining nl_3c for RTBSE" ELSE CALL neighbor_list_3c_destroy(bs_env%nl_3c) END IF @@ -271,52 +262,6 @@ CONTAINS END SUBROUTINE de_init_bs_env -! ************************************************************************************************** -!> \brief Resolve the linRTBSE RI-RS kernel switch from the KERNEL_RI input and the GW default. -!> \param qs_env Quickstep environment - source of the input section and the RTP method -!> \param bs_env Bandstructure environment - provides the do_gw_ri_rs default -!> \param rirs_kernel (optional) .TRUE. if the Hartree + SEX kernels use the RI-RS grid backend -!> \author Maximilian Graml -!> \note Single source of truth shared by create_rtbse_env (sets the flag) and de_init_bs_env -!> (decides whether to retain nl_3c). KERNEL_RI=DEFAULT follows bs_env%do_gw_ri_rs; -!> RS/AO force; forced .FALSE. for non-linearized (full) RT-BSE (warn on explicit RS). -! ************************************************************************************************** - SUBROUTINE rtbse_resolve_rirs_flag(qs_env, bs_env, rirs_kernel) - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - LOGICAL, INTENT(OUT), OPTIONAL :: rirs_kernel - - INTEGER :: kernel_ri - LOGICAL :: my_rirs_kernel - TYPE(dft_control_type), POINTER :: dft_control - TYPE(section_vals_type), POINTER :: input - - NULLIFY (dft_control, input) - CALL get_qs_env(qs_env, dft_control=dft_control, input=input) - - CALL section_vals_val_get(input, "DFT%REAL_TIME_PROPAGATION%RTBSE%KERNEL_RI", & - i_val=kernel_ri) - SELECT CASE (kernel_ri) - CASE (rtp_bse_kernel_ri_rs) - my_rirs_kernel = .TRUE. - CASE (rtp_bse_kernel_ri_ao) - my_rirs_kernel = .FALSE. - CASE DEFAULT ! rtp_bse_kernel_ri_default - my_rirs_kernel = bs_env%do_gw_ri_rs - END SELECT - - ! RI-RS kernels are implemented for linearized RT-BSE only; full RT-BSE always uses AO-RI. - IF (dft_control%rtp_control%rtp_method /= rtp_method_bse_linearized) THEN - IF (kernel_ri == rtp_bse_kernel_ri_rs) THEN - CPWARN("RI-RS kernels are implemented for linearized RT-BSE only; forcing AO") - END IF - my_rirs_kernel = .FALSE. - END IF - - IF (PRESENT(rirs_kernel)) rirs_kernel = my_rirs_kernel - - END SUBROUTINE rtbse_resolve_rirs_flag - ! ************************************************************************************************** !> \brief ... !> \param bs_env ... @@ -351,14 +296,8 @@ CONTAINS CALL section_vals_val_get(gw_sec, "PRINT%PRINT_DBT_CONTRACT_VERBOSE", l_val=bs_env%print_contract_verbose) CALL section_vals_val_get(gw_sec, "TIKHONOV", r_val=bs_env%ri_rs%tikhonov) CALL section_vals_val_get(gw_sec, "GRID_SELECT", i_val=bs_env%ri_rs%grid_select) - CALL section_vals_val_get(gw_sec, "GRID_FILE_SUFFIX", c_val=bs_env%ri_rs%grid_file_suffix) - CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_RI", r_val=bs_env%ri_rs%cutoff_radius_ri_rs) - CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_AO", r_val=bs_env%ri_rs%cutoff_radius_ri_ao) + CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RI_RS", r_val=bs_env%ri_rs%cutoff_radius_ri_rs) CALL section_vals_val_get(gw_sec, "N_PROCS_PER_ATOM_Z_LP", i_val=bs_env%ri_rs%n_procs_per_atom_z_lp) - CALL section_vals_val_get(gw_sec, "N_PANELS", i_val=bs_env%ri_rs%n_panels) - CALL section_vals_val_get(gw_sec, "KEEP_SPARSITY_RL", l_val=bs_env%ri_rs%keep_sparsity_rirs) - CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_RL_W", r_val=bs_env%ri_rs%cutoff_radius_v_w) - CALL section_vals_val_get(gw_sec, "CUTOFF_RADIUS_G_W", r_val=bs_env%ri_rs%cutoff_radius_g_w) IF (bs_env%print_contract) THEN bs_env%unit_nr_contract = bs_env%unit_nr @@ -1380,12 +1319,10 @@ CONTAINS WRITE (frmt, '(A)') '(3A,I1,A)' WRITE (f_S_p, frmt) TRIM(prefix), bs_env%Sigma_p_name, "_0", ind, ".matrix" WRITE (f_S_n, frmt) TRIM(prefix), bs_env%Sigma_n_name, "_0", ind, ".matrix" - ELSE IF (ind < 100) THEN + ELSE IF (i_t_or_w < 100) THEN WRITE (frmt, '(A)') '(3A,I2,A)' WRITE (f_S_p, frmt) TRIM(prefix), bs_env%Sigma_p_name, "_", ind, ".matrix" WRITE (f_S_n, frmt) TRIM(prefix), bs_env%Sigma_n_name, "_", ind, ".matrix" - ELSE - CPABORT('Please implement more than 99 combined spin+freq indices.') END IF INQUIRE (file=TRIM(f_S_p), exist=Sigma_pos_time_exists) @@ -1399,8 +1336,7 @@ CONTAINS END DO ! Marek : In the RTBSE run, check also for zero frequency W - IF (bs_env%rtp_method == rtp_method_bse .OR. & - bs_env%rtp_method == rtp_method_bse_linearized) THEN + IF (bs_env%rtp_method == rtp_method_bse) THEN WRITE (f_W_t, '(3A,I1,A)') TRIM(prefix), "W_freq_rtp", "_0", 0, ".matrix" INQUIRE (file=TRIM(f_W_t), exist=W_time_exists) bs_env%all_W_exist = bs_env%all_W_exist .AND. W_time_exists @@ -1465,9 +1401,8 @@ CONTAINS num_pe = para_env%num_pe ! if not already set, use all processors for the group (for large-cell GW, performance ! seems to be best for a single group with all MPI processes per group) - IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) THEN + IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) & bs_env%group_size_tensor = num_pe - END IF ! group_size_tensor must divide num_pe without rest; otherwise everything will be complicated IF (MODULO(num_pe, bs_env%group_size_tensor) /= 0) THEN @@ -1761,30 +1696,15 @@ CONTAINS WRITE (u, '(T2,A,F37.1,A)') 'Input: Available memory per MPI process', & bs_env%input_memory_per_proc_GB, ' GB' IF (bs_env%do_gw_ri_rs) THEN - WRITE (u, '(A)') ' ' - WRITE (u, '(T2,A,ES43.2)') 'Input: RI-RS Tikhonov regularization', & - bs_env%ri_rs%tikhonov - IF (bs_env%ri_rs%cutoff_radius_ri_rs > 0.0_dp) THEN - WRITE (u, '(T2,A,F39.2,A)') 'Input: RI-RS integration sphere cutoff', & - bs_env%ri_rs%cutoff_radius_ri_rs*angstrom, ' Å' + WRITE (u, FMT="(T2,A,ES44.1)") " " + WRITE (u, FMT="(T2,A,ES37.1)") "INPUT: Regularization parameter for RI-RS ", bs_env%ri_rs%tikhonov + IF (bs_env%ri_rs%cutoff_radius_ri_rs /= -1.0_dp) THEN + WRITE (u, FMT="(T2,A,F31.1,A)") "INPUT: Cutoff radius for grid points in RI-RS ", & + bs_env%ri_rs%cutoff_radius_ri_rs*angstrom, " Å" END IF - IF (bs_env%ri_rs%cutoff_radius_ri_ao > 0.0_dp) THEN - WRITE (u, '(T2,A,F44.2,A)') 'Input: AO grid hard cutoff radius', & - bs_env%ri_rs%cutoff_radius_ri_ao*angstrom, ' Å' - END IF - WRITE (u, '(T2,A,I40)') 'Input: MPI ranks per atom in Z_lP solve', & + WRITE (u, FMT="(T2,A,I35)") "INPUT: Number of MPI ranks per atom in Z_lP solve ", & bs_env%ri_rs%n_procs_per_atom_z_lp - WRITE (u, '(T2,A,L43)') 'Input: Keep sparsity in χ/G/W panels', & - bs_env%ri_rs%keep_sparsity_rirs - IF (bs_env%ri_rs%cutoff_radius_v_w > 0.0_dp) THEN - WRITE (u, '(T2,A,F43.2,A)') 'Input: G/W panel truncation radius', & - bs_env%ri_rs%cutoff_radius_v_w*angstrom, ' Å' - END IF - IF (bs_env%ri_rs%cutoff_radius_g_w > 0.0_dp) THEN - WRITE (u, '(T2,A,F40.2,A)') 'Input: G/W operator truncation radius', & - bs_env%ri_rs%cutoff_radius_g_w*angstrom, ' Å' - END IF - WRITE (u, '(A)') ' ' + WRITE (u, FMT="(T2,A,ES44.1)") " " END IF END IF @@ -1977,15 +1897,6 @@ CONTAINS E_max = MAX(E_max, E_max_ispin) END DO - ! Open-shell uses ONE minimax grid for the combined [min gap, max span] over both spins (the - ! superset covers each channel, so it is accurate; per-spin grids would only be more efficient). - IF (bs_env%n_spin > 1) THEN - CALL cp_hint(__LOCATION__, & - "Open-shell GW uses one minimax grid spanning [min gap, max span] across both "// & - "spin channels; raise NUM_TIME_FREQ_POINTS if QP convergence is marginal for "// & - "strongly spin-asymmetric systems.") - END IF - E_range = E_max/E_min ALLOCATE (points_and_weights(2*num_time_freq_points)) @@ -2141,17 +2052,15 @@ CONTAINS DO i = 1, SIZE(exp_RI, 1) DO j = 1, SIZE(exp_RI, 2) IF (exp_RI(i, j) < exp_min_RI .AND. exp_RI(i, j) > 1E-3_dp) exp_min_RI = exp_RI(i, j) - IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) THEN + IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) & exp_RI_kind(ikind) = exp_RI(i, j) - END IF END DO END DO DO i = 1, SIZE(exp_ao, 1) DO j = 1, SIZE(exp_ao, 2) IF (exp_ao(i, j) < exp_min_ao .AND. exp_ao(i, j) > 1E-3_dp) exp_min_ao = exp_ao(i, j) - IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) THEN + IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) & exp_ao_kind(ikind) = exp_ao(i, j) - END IF END DO END DO radius_ao_kind(ikind) = SQRT(-LOG(eps)/exp_ao_kind(ikind)) diff --git a/src/gx_ac_unittest.F b/src/gx_ac_unittest.F index d962c3e789..edbb4a1617 100644 --- a/src/gx_ac_unittest.F +++ b/src/gx_ac_unittest.F @@ -11,21 +11,17 @@ ! ************************************************************************************************** PROGRAM gx_ac_unittest #include "base/base_uses.f90" -#if defined(__GREENX) - USE kinds, ONLY: dp - USE gx_ac, ONLY: create_thiele_pade, & - evaluate_thiele_pade_at, & - free_params, & - params -#endif - - IMPLICIT NONE - #if !defined(__GREENX) ! Abort and inform that GreenX was not included in the compilation ! Ideally, this will be avoided in testing by the conditional tests CPABORT("CP2K not compiled with GreenX library.") #else + USE kinds, ONLY: dp + USE gx_ac, ONLY: create_thiele_pade, & + evaluate_thiele_pade_at, & + free_params, & + params + ! Create the dataset containing the fitting data ! Two Lorentzian peaks with some overlap COMPLEX(kind=dp) :: damp_one = (2, 0), & diff --git a/src/hartree_local_methods.F b/src/hartree_local_methods.F index 44e58782e8..78f4033388 100644 --- a/src/hartree_local_methods.F +++ b/src/hartree_local_methods.F @@ -329,9 +329,8 @@ CONTAINS basis_set=basis_1c, basis_type="GAPW_1C") cneo = ASSOCIATED(cneo_potential) - IF (cneo .AND. tddft) THEN + IF (cneo .AND. tddft) & CPABORT("Electronic TDDFT with CNEO quantum nuclei is not implemented.") - END IF NULLIFY (nuc_basis) max_iso_not0_nuc = 0 @@ -373,9 +372,8 @@ CONTAINS END IF nchan_0 = nsoset(lmax0) - IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) THEN + IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) & CPABORT("channels for rho0 > # max of spherical harmonics") - END IF NULLIFY (Vh1_h, Vh1_s) ALLOCATE (Vh1_h(nr, max_iso_not0)) diff --git a/src/hdf5_wrapper.F b/src/hdf5_wrapper.F index d80bd6b9cc..24a9388303 100644 --- a/src/hdf5_wrapper.F +++ b/src/hdf5_wrapper.F @@ -35,16 +35,9 @@ MODULE hdf5_wrapper IMPLICIT NONE - PRIVATE - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hdf5_wrapper' #ifdef __HDF5 INTEGER, PARAMETER, PUBLIC :: hdf5_id = hid_t - - PUBLIC :: h5aread_double_scalar, h5awrite_boolean, h5awrite_double_scalar, h5awrite_double_simple - PUBLIC :: h5awrite_fixlen_string, h5awrite_integer_scalar, h5awrite_integer_simple - PUBLIC :: h5awrite_string_simple, h5close, h5dread_double_simple, h5dwrite_double_simple, h5fclose - PUBLIC :: h5fcreate, h5fopen, h5gclose, h5gcreate, h5gopen, h5open #endif CONTAINS diff --git a/src/hfx_ace_methods.F b/src/hfx_ace_methods.F index e095b59ca0..501997a8ef 100644 --- a/src/hfx_ace_methods.F +++ b/src/hfx_ace_methods.F @@ -182,17 +182,15 @@ CONTAINS nspins = dft_control%nspins IF (n_rep_hf /= 1) CPABORT("ACE: only one &HF section is supported.") - IF (dft_control%nimages /= 1) THEN + IF (dft_control%nimages /= 1) & CPABORT("ACE: k-points / multiple images are not implemented.") - END IF ! ACE requires explicit MO coefficients (C_occ) which are only available ! with diagonalization-based SCF. OT never constructs mo_coeff during ! the SCF, so the ACE projector build loop would silently get garbage. CALL get_qs_env(qs_env, scf_control=scf_control) - IF (scf_control%use_ot) THEN + IF (scf_control%use_ot) & CPABORT("ACE: OT doesn't work, use diagonalization-based SCF.") - END IF rebuild_freq = MAX(1, ace_rebuild_frequency) @@ -200,9 +198,8 @@ CONTAINS ! Bypass A: energy-only call ! ------------------------------------------------------------------ IF (just_energy) THEN - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T2,A)') 'ACE | just_energy=T: full HFX (no matrix update)' - END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -214,9 +211,8 @@ CONTAINS ! Bypass B: ionic forces requested ! ------------------------------------------------------------------ IF (calculate_forces) THEN - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T2,A)') 'ACE | calculate_forces=T: full HFX for exact forces' - END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -275,15 +271,13 @@ CONTAINS IF (ace_built_now) THEN ace_is_built = .TRUE. ace_step_counter = 1 - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T4,A)') 'ACE | W built. Projector live from next step.' - END IF ELSE ace_is_built = .FALSE. ace_step_counter = 0 - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T4,A)') 'ACE | Build deferred (C_occ=0). Full HFX in ks_matrix.' - END IF END IF ELSE @@ -415,9 +409,8 @@ CONTAINS v_rspace_new, v_tau_rspace, ext_xc_section) ehfx_full = energy%ex - IF (DBG_BUILD .AND. iw > 0) THEN + IF (DBG_BUILD .AND. iw > 0) & WRITE (iw, '(/,T2,A,F20.10)') 'ACE BUILD | E_x(full HFX) = ', ehfx_full - END IF ! Allocate / resize module storage IF (ALLOCATED(ace_W)) THEN @@ -433,10 +426,9 @@ CONTAINS ! ---------------------------------------------------------------- DO ispin = 1, nspins - IF (mos_for_ace(ispin)%use_mo_coeff_b) THEN + IF (mos_for_ace(ispin)%use_mo_coeff_b) & CALL copy_dbcsr_to_fm(mos_for_ace(ispin)%mo_coeff_b, & mos_for_ace(ispin)%mo_coeff) - END IF CALL get_mo_set(mos_for_ace(ispin), mo_coeff=mo_coeff, & nao=nao, nmo=nmo, homo=nocc, & @@ -458,9 +450,8 @@ CONTAINS END IF IF (frob < 1.0e-20_dp) THEN - IF (DBG_BUILD .AND. iw > 0) THEN + IF (DBG_BUILD .AND. iw > 0) & WRITE (iw, '(T4,A)') 'mo_coeff=0: build deferred to next step.' - END IF CALL timestop(handle) RETURN END IF @@ -539,14 +530,12 @@ CONTAINS CPABORT("ACE: Cholesky of -M failed (not positive definite).") END IF - IF (DBG_BUILD .AND. iw > 0) THEN + IF (DBG_BUILD .AND. iw > 0) & WRITE (iw, '(T4,A)') 'Cholesky OK (info=0).' - END IF ! Step 7: W = xi * U^{-1} - IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) THEN + IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) & CALL cp_fm_release(ace_W(1, ispin)) - END IF CALL cp_fm_create(ace_W(1, ispin), xi_fm%matrix_struct, name="W_ACE") CALL cp_fm_to_fm(xi_fm, ace_W(1, ispin)) @@ -746,10 +735,9 @@ CONTAINS CALL cp_fm_release(P_fm) CALL cp_fm_release(PW_fm) - IF (DBG_ENERGY .AND. iw > 0) THEN + IF (DBG_ENERGY .AND. iw > 0) & WRITE (iw, '(T4,A,I4,A,F20.10)') & - 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val - END IF + 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val END DO energy%ex = ehfx_ace @@ -788,17 +776,15 @@ CONTAINS IF (do_admm) THEN CALL get_admm_env(admm_env, mos_aux_fit=mos_aux_diag) - IF (mos_aux_diag(ispin)%use_mo_coeff_b) THEN + IF (mos_aux_diag(ispin)%use_mo_coeff_b) & CALL copy_dbcsr_to_fm(mos_aux_diag(ispin)%mo_coeff_b, & mos_aux_diag(ispin)%mo_coeff) - END IF CALL get_mo_set(mos_aux_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) ELSE - IF (mos_diag(ispin)%use_mo_coeff_b) THEN + IF (mos_diag(ispin)%use_mo_coeff_b) & CALL copy_dbcsr_to_fm(mos_diag(ispin)%mo_coeff_b, & mos_diag(ispin)%mo_coeff) - END IF CALL get_mo_set(mos_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) END IF diff --git a/src/hfx_admm_utils.F b/src/hfx_admm_utils.F index 502353ae25..95aa6eb99c 100644 --- a/src/hfx_admm_utils.F +++ b/src/hfx_admm_utils.F @@ -213,9 +213,8 @@ CONTAINS IF (PRESENT(ext_xc_section)) hfx_sections => section_vals_get_subs_vals(ext_xc_section, "HF") CALL section_vals_get(hfx_sections, n_repetition=n_rep_hf) - IF (n_rep_hf > 1) THEN + IF (n_rep_hf > 1) & CPABORT("ADMM can handle only one HF section.") - END IF IF (.NOT. ASSOCIATED(admm_env)) THEN ! setup admm environment @@ -229,9 +228,8 @@ CONTAINS admm_env=admm_env) ! Initialize the GAPW data types - IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN + IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) & CALL init_admm_gapw(qs_env) - END IF ! ADMM neighbor lists and overlap matrices CALL admm_init_hamiltonians(admm_env, qs_env, "AUX_FIT") @@ -306,13 +304,11 @@ CONTAINS CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) !Test combinations of input values. So far, only ADMM2 is availavle - IF (.NOT. admm_env%purification_method == do_admm_purify_none) THEN + IF (.NOT. admm_env%purification_method == do_admm_purify_none) & CPABORT("Only ADMM_PURIFICATION_METHOD NONE implemeted for ADMM K-points") - END IF IF (.NOT. (dft_control%admm_control%method == do_admm_basis_projection & - .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) THEN + .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) & CPABORT("Only BASIS_PROJECTION and CHARGE_CONSTRAINED_PROJECTION implemented for KP") - END IF IF (admm_env%do_admms .OR. admm_env%do_admmp .OR. admm_env%do_admmq) THEN IF (use_real_wfn) CPABORT("Only KP-HFX ADMM2 is implemented with REAL wavefunctions") END IF @@ -641,7 +637,7 @@ CONTAINS mic = molecule_only IF (kpoints%nkp > 0) THEN mic = .FALSE. - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN mic = .TRUE. END IF @@ -1243,9 +1239,8 @@ CONTAINS ! Remember: Vhfx is added, energy is calclulated from total Vhfx, ! so energy of last iteration is correct - IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) THEN + IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) & CPABORT("HFX_TREAT_LSD_IN_CORE not implemented for adiabatically rescaled hybrids") - END IF ! everything is calculated with adiabatic rescaling but the potential is not added in a first step distribute_fock_matrix = .NOT. do_adiabatic_rescaling diff --git a/src/hfx_compression_methods.F b/src/hfx_compression_methods.F index 6b9e07e456..d6d0df4ae7 100644 --- a/src/hfx_compression_methods.F +++ b/src/hfx_compression_methods.F @@ -225,9 +225,7 @@ CONTAINS !! This happens in case a container has fully been filled in the compression step !! but no other was needed for the current bit size !! Therefore we can safely igonore an eof error - ! We still need to ask for it to read the data correctly, so we mark it as used READ (container%unit, IOSTAT=stat) container%current%data - MARK_USED(stat) memory_usage = memory_usage + 1 container%file_counter = container%file_counter + 1 ELSE diff --git a/src/hfx_energy_potential.F b/src/hfx_energy_potential.F index eec9821017..679a821530 100644 --- a/src/hfx_energy_potential.F +++ b/src/hfx_energy_potential.F @@ -3123,13 +3123,12 @@ CONTAINS DO mb = 1, mb_max DO ma = 1, ma_max iint = iint + 1 - IF (ABS(prim(iint)) > 0.0000000000001) THEN + IF (ABS(prim(iint)) > 0.0000000000001) & WRITE (99, *) atom_offsets(i, 1) + ma + set_offsets(iset, 1, i, 1) - 1, & - atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & - atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & - atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & - prim(iint) - END IF + atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & + atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & + atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & + prim(iint) END DO END DO END DO diff --git a/src/hfx_exx.F b/src/hfx_exx.F index c083d86131..4116db4143 100644 --- a/src/hfx_exx.F +++ b/src/hfx_exx.F @@ -567,7 +567,7 @@ CONTAINS xc_section_aux => qs_env%mp2_env%ri_rpa%xc_section_aux xc_section_primary => qs_env%mp2_env%ri_rpa%xc_section_primary END IF - ELSE IF (qs_env%energy_correction) THEN + ELSEIF (qs_env%energy_correction) THEN IF (ASSOCIATED(qs_env%ec_env%xc_section_aux) .AND. & ASSOCIATED(qs_env%ec_env%xc_section_primary)) THEN xc_section_aux => qs_env%ec_env%xc_section_aux diff --git a/src/hfx_load_balance_methods.F b/src/hfx_load_balance_methods.F index 38f34ce1e0..5b13c6a164 100644 --- a/src/hfx_load_balance_methods.F +++ b/src/hfx_load_balance_methods.F @@ -1860,10 +1860,9 @@ CONTAINS ! it also avoids degenerate cases where thousands of zero sized tasks ! are assigned to the same (least loaded) cpu ! - IF (do_randomize) THEN + IF (do_randomize) & rng_stream = rng_stream_type(name="uniform_rng", & distribution_type=UNIFORM) - END IF DO i = total_number_of_bins, 1, -nstep tmp_cpu_cost = my_cost_cpu diff --git a/src/hfx_pw_methods.F b/src/hfx_pw_methods.F index f4a1e7ca5b..8551fc0b85 100644 --- a/src/hfx_pw_methods.F +++ b/src/hfx_pw_methods.F @@ -147,7 +147,7 @@ CONTAINS END IF IF (potential_type == do_potential_coulomb) THEN CALL pw_copy(poisson_env%green_fft%influence_fn, greenfn) - ELSE IF (potential_type == do_potential_truncated) THEN + ELSEIF (potential_type == do_potential_truncated) THEN CALL section_vals_val_get(ip_section, "CUTOFF_RADIUS", r_val=rcut) grid => poisson_env%green_fft%influence_fn%pw_grid DO ig = grid%first_gne0, grid%ngpts_cut_local @@ -156,10 +156,9 @@ CONTAINS g3d = fourpi/g2 greenfn%array(ig) = g3d*(1.0_dp - COS(rcut*gg)) END DO - IF (grid%have_g0) THEN + IF (grid%have_g0) & greenfn%array(1) = 0.5_dp*fourpi*rcut*rcut - END IF - ELSE IF (potential_type == do_potential_short) THEN + ELSEIF (potential_type == do_potential_short) THEN CALL section_vals_val_get(ip_section, "OMEGA", r_val=omega) IF (omega > 0.0_dp) omega = 0.25_dp/(omega*omega) grid => poisson_env%green_fft%influence_fn%pw_grid diff --git a/src/hfx_ri.F b/src/hfx_ri.F index 087348e6b3..23675f8016 100644 --- a/src/hfx_ri.F +++ b/src/hfx_ri.F @@ -3708,10 +3708,9 @@ CONTAINS CALL get_RI_density_coeffs(density_coeffs, rho_ao, 1, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) - IF (nspins == 2) THEN + IF (nspins == 2) & CALL get_RI_density_coeffs(density_coeffs_2, rho_ao, 2, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) - END IF unit_nr = cp_print_key_unit_nr(logger, input, "DFT%XC%HF%RI%PRINT%RI_DENSITY_COEFFS", & extension=".dat", file_status="REPLACE", & diff --git a/src/hfx_ri_kp.F b/src/hfx_ri_kp.F index 2093e39aad..238d2f9b50 100644 --- a/src/hfx_ri_kp.F +++ b/src/hfx_ri_kp.F @@ -250,9 +250,8 @@ CONTAINS !We do all the checks on what we allow in this initial implementation IF (ri_data%flavor /= ri_pmat) CPABORT("K-points RI-HFX only with RHO flavor") IF (ri_data%same_op) ri_data%same_op = .FALSE. !force the full calculation with RI metric - IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) THEN + IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) & CPABORT("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points") - END IF CALL get_kp_and_ri_images(ri_data, qs_env) nimg = ri_data%nimg @@ -3638,9 +3637,8 @@ CONTAINS DO i_img = 1, nimg DO i_spin = 1, nspins - IF (.NOT. (i_img == 1 .AND. i_spin == 1)) THEN + IF (.NOT. (i_img == 1 .AND. i_spin == 1)) & CALL dbt_create(rho_ao_t_sub(1, 1), rho_ao_t_sub(i_spin, i_img)) - END IF CALL copy_2c_to_subgroup(rho_ao_t_sub(i_spin, i_img), rho_ao_t(i_spin, i_img), & group_size, ngroups, para_env) CALL dbt_destroy(rho_ao_t(i_spin, i_img)) @@ -4400,9 +4398,8 @@ CONTAINS CALL neighbor_list_iterator_release(nl_iterator) CALL release_neighbor_list_sets(nl_2c) CALL para_env%max(ri_data%nimg) - IF (ri_data%nimg > nimg) THEN + IF (ri_data%nimg > nimg) & CPABORT("Make sure the smallest exponent of the RI-HFX basis is larger than that of the ORB basis.") - END IF !Keep track of which images will not contribute, so that can be ignored before calculation CALL para_env%sum(present_img) diff --git a/src/hfx_types.F b/src/hfx_types.F index d81fd2de0e..1c11cc9d77 100644 --- a/src/hfx_types.F +++ b/src/hfx_types.F @@ -778,9 +778,8 @@ CONTAINS actual_x_data%load_balance_parameter%do_randomize = logic_val actual_x_data%load_balance_parameter%rtp_redistribute = .FALSE. - IF (ASSOCIATED(dft_control%rtp_control)) THEN + IF (ASSOCIATED(dft_control%rtp_control)) & actual_x_data%load_balance_parameter%rtp_redistribute = dft_control%rtp_control%hfx_redistribute - END IF CALL section_vals_val_get(hf_sub_section, "BLOCK_SIZE", i_val=int_val) ! negative values ask for a computed default @@ -1045,13 +1044,11 @@ CONTAINS ! Sanity checks IF (actual_x_data%use_ace) THEN ! ACE requires HFX to be meaningful - IF (actual_x_data%general_parameter%fraction <= 0.0_dp) THEN + IF (actual_x_data%general_parameter%fraction <= 0.0_dp) & CPABORT("ACE requires FRACTION > 0.") - END IF ! If frequency is 1, it is full HFX - IF (actual_x_data%ace_rebuild_freq < 1) THEN + IF (actual_x_data%ace_rebuild_freq < 1) & CPABORT("ACE: REBUILD_FREQUENCY must be >= 1") - END IF END IF END IF END DO @@ -1219,9 +1216,8 @@ CONTAINS ri_metric%scale_longrange = hfx_pot%scale_longrange END IF - IF (ri_metric%potential_type == do_potential_short) THEN + IF (ri_metric%potential_type == do_potential_short) & CALL erfc_cutoff(ri_data%eps_schwarz, ri_metric%omega, ri_metric%cutoff_radius) - END IF IF (ri_metric%potential_type == do_potential_id) ri_metric%cutoff_radius = 0.0_dp END ASSOCIATE @@ -1436,7 +1432,7 @@ CONTAINS DEALLOCATE (dist1, dist2) CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(2, 1)) - ELSE IF (ri_data%flavor == ri_mo) THEN + ELSEIF (ri_data%flavor == ri_mo) THEN ALLOCATE (ri_data%t_2c_int(2, 1)) CALL create_2c_tensor(ri_data%t_2c_int(1, 1), dist1, dist2, ri_data%pgrid_2d, & @@ -1626,7 +1622,7 @@ CONTAINS DEALLOCATE (ri_data%blk_indices) DEALLOCATE (ri_data%store_3c) - ELSE IF (ri_data%flavor == ri_mo) THEN + ELSEIF (ri_data%flavor == ri_mo) THEN CALL dbt_destroy(ri_data%t_3c_int_ctr_1(1, 1)) CALL dbt_destroy(ri_data%t_3c_int_ctr_2(1, 1)) DEALLOCATE (ri_data%t_3c_int_ctr_1) diff --git a/src/hfxbase/hfx_compression_core_methods.F b/src/hfxbase/hfx_compression_core_methods.F index bdb6ca7c6a..302e5b90b6 100644 --- a/src/hfxbase/hfx_compression_core_methods.F +++ b/src/hfxbase/hfx_compression_core_methods.F @@ -21,38 +21,38 @@ MODULE hfx_compression_core_methods ! masks the corresponding number of bits from the right INTEGER(kind=int_8), PARAMETER :: mask_right(0:63) = & - [0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & + (/0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & 1023_int_8, 2047_int_8, 4095_int_8, 8191_int_8, 16383_int_8, 32767_int_8, 65535_int_8, 131071_int_8, & 262143_int_8, 524287_int_8, 1048575_int_8, 2097151_int_8, 4194303_int_8, 8388607_int_8, 16777215_int_8, & 33554431_int_8, 67108863_int_8, 134217727_int_8, 268435455_int_8, 536870911_int_8, 1073741823_int_8, & - 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & + 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & 68719476735_int_8, 137438953471_int_8, 274877906943_int_8, 549755813887_int_8, 1099511627775_int_8, & - 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & - 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & + 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & + 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & 562949953421311_int_8, 1125899906842623_int_8, 2251799813685247_int_8, 4503599627370495_int_8, & 9007199254740991_int_8, 18014398509481983_int_8, 36028797018963967_int_8, 72057594037927935_int_8, & - 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & - 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & - 9223372036854775807_int_8] + 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & + 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & + 9223372036854775807_int_8/) ! masks the corresponding number of bits from the left ! use ishft to avoid explicitly writing -HUGE-1, and keep it out of the array a work-around for a bug in pgi 6.1-1 INTEGER(kind=int_8), PARAMETER :: ugly_duck = ISHFT(1_int_8, 63) INTEGER(kind=int_8), PARAMETER :: mask_left(0:63) = & - [0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & - -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & - -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & + (/0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & + -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & + -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & -18014398509481984_int_8, -9007199254740992_int_8, -4503599627370496_int_8, -2251799813685248_int_8, & -1125899906842624_int_8, -562949953421312_int_8, -281474976710656_int_8, -140737488355328_int_8, & - -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & - -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & + -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & + -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & -274877906944_int_8, -137438953472_int_8, -68719476736_int_8, -34359738368_int_8, -17179869184_int_8, & -8589934592_int_8, -4294967296_int_8, -2147483648_int_8, -1073741824_int_8, -536870912_int_8, & - -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & + -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & -8388608_int_8, -4194304_int_8, -2097152_int_8, -1048576_int_8, -524288_int_8, -262144_int_8, & -131072_int_8, -65536_int_8, -32768_int_8, -16384_int_8, -8192_int_8, -4096_int_8, -2048_int_8, & -1024_int_8, -512_int_8, -256_int_8, -128_int_8, -64_int_8, -32_int_8, -16_int_8, -8_int_8, -4_int_8, & - -2_int_8] + -2_int_8/) PUBLIC :: bits2ints_specific, ints2bits_specific @@ -70,7 +70,7 @@ CONTAINS INTEGER(KIND=int_8), INTENT(OUT) :: full_data(*) full_data(1:Ndata) = packed_data(1:Ndata) - END SUBROUTINE ints2ints + END SUBROUTINE ! Nbits : number of relevant bits per int in the bit stream (this includes all bits) ! Ndata : number of ints that need to be extracted from the bit stream @@ -160,30 +160,22 @@ CONTAINS idata = idata + 1 IF (ibits_remaining >= Nbits) THEN data_tmp = full_data(idata) - ! put bits on the left - data_tmp = ISHFT(data_tmp, 64 - Nbits) - ! add to the packed data - pack_tmp = IOR(pack_tmp, data_tmp) + data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left + pack_tmp = IOR(pack_tmp, data_tmp) ! add to the packed data ibits_remaining = ibits_remaining - Nbits - ! and shift to the right to make place for the next - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! and shift to the right to make place for the next ELSE i_odd_bits = ibits_remaining data_tmp = full_data(idata) - ! put bits on the left - data_tmp = ISHFT(data_tmp, 64 - Nbits) - ! restrict to those bits for which we still have space - data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) + data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left + data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) ! restrict to those bits for which we still have space pack_tmp = IOR(pack_tmp, data_tmp) ! add them to the packed bits ipack = ipack + 1 - ! store the full packed data away and start with a new one - packed_data(ipack) = pack_tmp + packed_data(ipack) = pack_tmp ! store the full packed data away and start with a new one data_tmp = full_data(idata) - ! put the missing bits on the left if pack_tmp - pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) + pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) ! put the missing bits on the left if pack_tmp ibits_remaining = 64 - Nbits + i_odd_bits - ! shift to make place, but not more than the number of available bits - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! shift to make place, but not more than the number of available bits END IF END DO diff --git a/src/hirshfeld_methods.F b/src/hirshfeld_methods.F index f4dbc0691a..d045ff0a39 100644 --- a/src/hirshfeld_methods.F +++ b/src/hirshfeld_methods.F @@ -220,18 +220,16 @@ CONTAINS IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) THEN + IF (hirshfeld_env%use_bohr) & rco = cp_unit_to_cp2k(rco, "angstrom") - END IF END IF CASE (radius_covalent) CALL get_ptable_info(symbol=esym, covalent_radius=rco, found=found) IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) THEN + IF (hirshfeld_env%use_bohr) & rco = cp_unit_to_cp2k(rco, "angstrom") - END IF END IF CASE (radius_single) CPASSERT(PRESENT(radius)) diff --git a/src/iao_analysis.F b/src/iao_analysis.F index 080d92ca5c..0e658efcd6 100644 --- a/src/iao_analysis.F +++ b/src/iao_analysis.F @@ -1179,7 +1179,7 @@ CONTAINS WRITE (filename, '(A18,I1.1)') "IBO_CENTERS_SPREAD" iw = cp_print_key_unit_nr(logger, print_section, "", extension=".csp", & middle_name=TRIM(filename), file_position="REWIND", log_filename=.FALSE.) - ELSE IF (PRESENT(iounit)) THEN + ELSEIF (PRESENT(iounit)) THEN iw = iounit ELSE iw = -1 @@ -1702,7 +1702,7 @@ CONTAINS IF (order == 2) THEN aij = aij + 4._dp*mij**2 - (mii - mjj)**2 bij = bij + 4._dp*mij*(mii - mjj) - ELSE IF (order == 4) THEN + ELSEIF (order == 4) THEN aij = aij - mii**4 - mjj**4 + 6._dp*(mii**2 + mjj**2)*mij**2 + & mii**3*mjj + mii*mjj**3 bij = bij + 4._dp*mij*(mii**3 - mjj**3) diff --git a/src/iao_types.F b/src/iao_types.F index 27fa24a883..ce837e271c 100644 --- a/src/iao_types.F +++ b/src/iao_types.F @@ -239,9 +239,8 @@ CONTAINS nfrags = 0 DO ii = 1, SIZE(particle_set) - IF (nfrags < particle_set(ii)%fragment_index) THEN + IF (nfrags < particle_set(ii)%fragment_index) & nfrags = particle_set(ii)%fragment_index - END IF END DO logger => cp_get_default_logger() @@ -270,13 +269,13 @@ CONTAINS IF (particle_set(iatom)%fragment_index == jj) THEN totalcol = totalcol + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcoljj = .FALSE. - ELSE IF (lfirstcoljj) THEN + ELSEIF (lfirstcoljj) THEN colskip = colskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF IF (particle_set(iatom)%fragment_index == ii) THEN totalrow = totalrow + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcol = .FALSE. - ELSE IF (lfirstcol) THEN + ELSEIF (lfirstcol) THEN rowskip = rowskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF rowfrag = rowfrag + orb_basis_set_list(ikind)%gto_basis_set%nsgf diff --git a/src/input/cp_output_handling.F b/src/input/cp_output_handling.F index ca7c1fb19e..8abac352bf 100644 --- a/src/input/cp_output_handling.F +++ b/src/input/cp_output_handling.F @@ -981,38 +981,33 @@ CONTAINS filename_bak_2 = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(i - 1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Moving file "//TRIM(filename_bak_2)// & - " into file "//TRIM(filename_bak_1)//"." - END IF + " into file "//TRIM(filename_bak_1)//"." END IF INQUIRE (FILE=filename_bak_2, EXIST=found) IF (.NOT. found) THEN IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "File "//TRIM(filename_bak_2)//" not existing.." - END IF END IF ELSE ! Shared file: rotate on the source rank only; per-task ! (my_local) files are per-rank, rotated by their owner. - IF (my_local .OR. logger%para_env%is_source()) THEN + IF (my_local .OR. logger%para_env%is_source()) & CALL m_mov(TRIM(filename_bak_2), TRIM(filename_bak_1)) - END IF END IF END DO ! The last backup is always the one with index 1 filename_bak = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Moving file "//TRIM(filename)//" into file "//TRIM(filename_bak)//"." - END IF END IF - IF (my_local .OR. logger%para_env%is_source()) THEN + IF (my_local .OR. logger%para_env%is_source()) & CALL m_mov(TRIM(filename), TRIM(filename_bak)) - END IF ELSE ! Zero the backup history for this new iteration level.. print_key%ibackup(my_backup_level) = 0 @@ -1033,11 +1028,10 @@ CONTAINS END IF IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Writing "//TRIM(print_key%section%name)//" "// & - TRIM(cp_iter_string(logger%iter_info))//" to "// & - TRIM(filename) - END IF + TRIM(cp_iter_string(logger%iter_info))//" to "// & + TRIM(filename) END IF END IF ELSE diff --git a/src/input/cp_parser_ilist_methods.F b/src/input/cp_parser_ilist_methods.F index 6b178f7ab2..bb8b41979c 100644 --- a/src/input/cp_parser_ilist_methods.F +++ b/src/input/cp_parser_ilist_methods.F @@ -44,12 +44,11 @@ CONTAINS ind = INDEX(token, "..") READ (UNIT=token(:ind - 1), FMT=*) ilist%istart READ (UNIT=token(ind + 2:), FMT=*) ilist%iend - IF (ilist%istart > ilist%iend) THEN + IF (ilist%istart > ilist%iend) & CALL cp_abort(__LOCATION__, & "Invalid list range specified: "// & TRIM(ADJUSTL(cp_to_string(ilist%istart)))//".."// & TRIM(ADJUSTL(cp_to_string(ilist%iend)))) - END IF ilist%nel_list = ilist%iend - ilist%istart + 1 ilist%ipresent = ilist%istart ilist%in_use = .TRUE. diff --git a/src/input/cp_parser_inpp_methods.F b/src/input/cp_parser_inpp_methods.F index 1ba2e7f5dc..dd2d552f06 100644 --- a/src/input/cp_parser_inpp_methods.F +++ b/src/input/cp_parser_inpp_methods.F @@ -53,18 +53,15 @@ CONTAINS is_valid_varname = .FALSE. - IF (LEN(str) == 0) then + IF (LEN(str) == 0) & RETURN - end if - IF (INDEX(alpha, str(1:1)) == 0) then + IF (INDEX(alpha, str(1:1)) == 0) & RETURN - end if DO idx = 2, LEN(str) - IF (INDEX(alphanum, str(idx:idx)) == 0) then + IF (INDEX(alphanum, str(idx:idx)) == 0) & RETURN - end if END DO is_valid_varname = .TRUE. @@ -595,9 +592,8 @@ CONTAINS CPABORT(TRIM(message)) END IF - IF (idx > 0) then + IF (idx > 0) & var_value = TRIM(inpp%variable_value(idx)) - end if newline = input_line(1:pos1 - 3)//var_value//input_line(pos2 + 2:) input_line = newline @@ -609,9 +605,8 @@ CONTAINS pos1 = pos1 + 1 ! move to the start of the variable name pos2 = INDEX(input_line(pos1:), ' ') - IF (pos2 == 0) then + IF (pos2 == 0) & pos2 = LEN_TRIM(input_line(pos1:)) + 1 - end if pos2 = pos1 + pos2 - 2 ! end of the variable name, minus the separating whitespace var_name = input_line(pos1:pos2) diff --git a/src/input/cp_parser_methods.F b/src/input/cp_parser_methods.F index 8b9b1bbbc7..a57066f206 100644 --- a/src/input/cp_parser_methods.F +++ b/src/input/cp_parser_methods.F @@ -548,9 +548,8 @@ CONTAINS ! Read input string of fixed length (single line) ! Check for EOF - IF (parser%icol == -1) THEN + IF (parser%icol == -1) & CPABORT("Unexpectetly reached EOF"//TRIM(parser_location(parser))) - END IF length = MIN(len_trim_inputline - parser%icol1 + 1, length) parser%icol1 = parser%icol + 1 diff --git a/src/input/cp_parser_types.F b/src/input/cp_parser_types.F index f8a4340268..d4fec0975d 100644 --- a/src/input/cp_parser_types.F +++ b/src/input/cp_parser_types.F @@ -196,9 +196,8 @@ CONTAINS parser%input_unit = unit_nr IF (PRESENT(file_name)) parser%input_file_name = TRIM(ADJUSTL(file_name)) ELSE - IF (.NOT. PRESENT(file_name)) THEN + IF (.NOT. PRESENT(file_name)) & CPABORT("at least one of filename and unit_nr must be present") - END IF CALL open_file(file_name=TRIM(ADJUSTL(file_name)), & unit_number=parser%input_unit) parser%input_file_name = TRIM(ADJUSTL(file_name)) diff --git a/src/input/input_enumeration_types.F b/src/input/input_enumeration_types.F index ca21d04940..112b8b49ae 100644 --- a/src/input/input_enumeration_types.F +++ b/src/input/input_enumeration_types.F @@ -175,9 +175,8 @@ CONTAINS END DO PRINT *, enum%i_vals END IF - IF (enum%strict) THEN + IF (enum%strict) & CPABORT("invalid value for enumeration:"//cp_to_string(i)) - END IF res = ADJUSTL(cp_to_string(i)) END IF END FUNCTION enum_i2c @@ -212,13 +211,11 @@ CONTAINS END DO IF (.NOT. found) THEN - IF (enum%strict) THEN + IF (enum%strict) & CPABORT("invalid value for enumeration:"//TRIM(c)) - END IF READ (c, "(i10)", iostat=iostat) res - IF (iostat /= 0) THEN + IF (iostat /= 0) & CPABORT("invalid value for enumeration2:"//TRIM(c)) - END IF END IF END FUNCTION enum_c2i diff --git a/src/input/input_keyword_types.F b/src/input/input_keyword_types.F index 8f33f0b1bd..1665d10024 100644 --- a/src/input/input_keyword_types.F +++ b/src/input/input_keyword_types.F @@ -274,9 +274,8 @@ CONTAINS IF (PRESENT(default_l_val) .OR. PRESENT(default_l_vals) .OR. & PRESENT(default_i_val) .OR. PRESENT(default_i_vals) .OR. & PRESENT(default_r_val) .OR. PRESENT(default_r_vals) .OR. & - PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) THEN + PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) & CPABORT("you should pass either default_val or a default value, not both") - END IF keyword%default_value => default_val IF (ASSOCIATED(default_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN @@ -311,11 +310,10 @@ CONTAINS " assumed undefined type by default") END IF ELSE IF (PRESENT(type_of_var)) THEN - IF (keyword%type_of_var /= type_of_var) THEN + IF (keyword%type_of_var /= type_of_var) & CALL cp_abort(__LOCATION__, & "keyword "//TRIM(keyword%names(1))// & " has a type different from the type of the default_value") - END IF keyword%type_of_var = type_of_var END IF @@ -327,17 +325,15 @@ CONTAINS IF (PRESENT(lone_keyword_l_val) .OR. PRESENT(lone_keyword_l_vals) .OR. & PRESENT(lone_keyword_i_val) .OR. PRESENT(lone_keyword_i_vals) .OR. & PRESENT(lone_keyword_r_val) .OR. PRESENT(lone_keyword_r_vals) .OR. & - PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) THEN + PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) & CALL cp_abort(__LOCATION__, & "you should pass either lone_keyword_val or a lone_keyword value, not both") - END IF keyword%lone_keyword_value => lone_keyword_val CALL val_retain(lone_keyword_val) IF (ASSOCIATED(lone_keyword_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN - IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) THEN + IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) & CPABORT("keyword%enum/=lone_keyword_val%enum") - END IF ELSE IF (ASSOCIATED(keyword%lone_keyword_value)) THEN CPABORT(".NOT. ASSOCIATED(keyword%lone_keyword_value)") @@ -359,9 +355,8 @@ CONTAINS IF (keyword%lone_keyword_value%type_of_var == no_t) THEN CALL val_release(keyword%lone_keyword_value) ELSE - IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) THEN + IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) & CPABORT("lone_keyword_value type incompatible with keyword type") - END IF ! lc_val cannot have lone_keyword_value! IF (keyword%type_of_var == enum_t) THEN IF (keyword%enum%strict) THEN @@ -369,9 +364,8 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) THEN + IF (.NOT. check) & CPABORT("default value not in enumeration : "//keyword%names(1)) - END IF END IF END IF END IF @@ -390,9 +384,8 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) THEN + IF (.NOT. check) & CPABORT("default value not in enumeration : "//keyword%names(1)) - END IF END IF keyword%n_var = SIZE(keyword%default_value%i_val) CASE (real_t) @@ -408,9 +401,8 @@ CONTAINS END SELECT END IF IF (PRESENT(n_var)) keyword%n_var = n_var - IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) THEN + IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) & CPABORT("arrays of lchar_t not supported : "//keyword%names(1)) - END IF IF (PRESENT(unit_str)) THEN ALLOCATE (keyword%unit) @@ -768,11 +760,10 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(keyword%description))) & //"" - IF (ALLOCATED(keyword%deprecation_notice)) THEN + IF (ALLOCATED(keyword%deprecation_notice)) & WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & - //"" - END IF + TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & + //"" IF (ASSOCIATED(keyword%default_value) .AND. & (keyword%type_of_var /= no_t)) THEN diff --git a/src/input/input_parsing.F b/src/input/input_parsing.F index 332e6791ef..dab4ca7b6b 100644 --- a/src/input/input_parsing.F +++ b/src/input/input_parsing.F @@ -93,25 +93,22 @@ CONTAINS output_unit = cp_logger_get_default_io_unit() CPASSERT(section_vals%ref_count > 0) - IF (root_sect .AND. parser%icol1 > parser%icol2) THEN + IF (root_sect .AND. parser%icol1 > parser%icol2) & CALL cp_abort(__LOCATION__, & "Error 1: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) - END IF section => section_vals%section IF (root_sect) THEN token = TRIM(ADJUSTL(parser%input_line(parser%icol1:parser%icol2))) ! Ignore leading or trailing blanks CALL uppercase(token) - IF (token /= parser%section_character//section%name) THEN + IF (token /= parser%section_character//section%name) & CALL cp_abort(__LOCATION__, & "Error 2: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) - END IF END IF - IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) THEN + IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) & CALL cp_abort(__LOCATION__, "Section "//TRIM(section%name)// & " should not repeat "//TRIM(parser_location(parser))) - END IF CALL section_vals_add_values(section_vals) irs = SIZE(section_vals%values, 2) @@ -141,11 +138,10 @@ CONTAINS lower_to_upper=.TRUE., at_end=at_end) token = TRIM(ADJUSTL(token)) ! Ignore leading or trailing blanks IF (at_end) THEN - IF (root_sect) THEN + IF (root_sect) & CALL cp_abort(__LOCATION__, & "unexpected end of file while parsing section "// & TRIM(section%name)//" "//TRIM(parser_location(parser))) - END IF EXIT END IF IF (token(1:1) == parser%section_character) THEN @@ -273,17 +269,15 @@ CONTAINS END IF END IF - IF (ALLOCATED(keyword%deprecation_notice)) THEN + IF (ALLOCATED(keyword%deprecation_notice)) & CALL cp_warn(__LOCATION__, & "The specified keyword '"//TRIM(token)// & "' is deprecated and may be removed in a future version: "// & keyword%deprecation_notice) - END IF NULLIFY (el) - IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) THEN + IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) & CALL parser_skip_space(parser) - END IF CALL val_create_parsing(el, type_of_var=keyword%type_of_var, & n_var=keyword%n_var, default_value=keyword%lone_keyword_value, & enum=keyword%enum, unit=keyword%unit, & @@ -295,11 +289,10 @@ CONTAINS IF (.NOT. ASSOCIATED(last_val)) THEN section_vals%values(ik, irs)%list => new_val ELSE - IF (.NOT. keyword%repeats) THEN + IF (.NOT. keyword%repeats) & CALL cp_abort(__LOCATION__, & "Keyword "//TRIM(token)// & " in section "//TRIM(section%name)//" should not repeat.") - END IF IF (ASSOCIATED(last_val, previous_list)) THEN last_val => previous_last ELSE @@ -531,18 +524,16 @@ CONTAINS END IF END IF CASE (lchar_t) - IF (ASSOCIATED(default_value)) THEN + IF (ASSOCIATED(default_value)) & CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot have a lone keyword attribute,"// & " no value is interpreted as empty string"// & TRIM(parser_location(parser))) - END IF - IF (n_var /= 1) THEN + IF (n_var /= 1) & CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot be repeated,"// & " one always represent a whole line, till the end"// & TRIM(parser_location(parser))) - END IF IF (parser_test_next_token(parser) == "EOL") THEN ALLOCATE (c_val_p(1)) c_val_p(1) = ' ' @@ -686,12 +677,11 @@ CONTAINS my_unit => unit END IF END IF - IF (.NOT. cp_unit_compatible(unit, my_unit)) THEN + IF (.NOT. cp_unit_compatible(unit, my_unit)) & CALL cp_abort(__LOCATION__, & "Incompatible units. Defined as ("// & TRIM(cp_unit_desc(unit))//") specified in input as ("// & TRIM(cp_unit_desc(my_unit))//"). These units are incompatible!") - END IF END IF CALL parser_get_object(parser, r_val) IF (ASSOCIATED(unit)) THEN diff --git a/src/input/input_section_types.F b/src/input/input_section_types.F index 44662e9ed1..917c8edeb1 100644 --- a/src/input/input_section_types.F +++ b/src/input/input_section_types.F @@ -326,9 +326,8 @@ CONTAINS IF (ASSOCIATED(section)) THEN CPASSERT(section%ref_count > 0) - IF (.NOT. my_hide_root) THEN + IF (.NOT. my_hide_root) & WRITE (UNIT=unit_nr, FMT="('*** section &',A,' ***')") TRIM(ADJUSTL(section%name)) - END IF IF (level > 1) THEN message = get_section_info(section) CALL print_message(TRIM(a2s(section%description))//TRIM(message), unit_nr, 0, 0, 0) @@ -348,9 +347,8 @@ CONTAINS END DO END IF IF (section%n_subsections > 0 .AND. my_recurse >= 0) THEN - IF (.NOT. my_hide_root) THEN + IF (.NOT. my_hide_root) & WRITE (UNIT=unit_nr, FMT="('** subsections **')") - END IF DO isub = 1, section%n_subsections IF (my_recurse > 0) THEN CALL section_describe(section%subsections(isub)%section, unit_nr, & @@ -360,9 +358,8 @@ CONTAINS END IF END DO END IF - IF (.NOT. my_hide_root) THEN + IF (.NOT. my_hide_root) & WRITE (UNIT=unit_nr, FMT="('*** &end section ',A,' ***')") TRIM(ADJUSTL(section%name)) - END IF ELSE WRITE (unit_nr, "(a)") '
' END IF @@ -589,12 +586,11 @@ CONTAINS section%subsections => new_subsections END IF DO i = 1, section%n_subsections - IF (subsection%name == section%subsections(i)%section%name) THEN + IF (subsection%name == section%subsections(i)%section%name) & CALL cp_abort(__LOCATION__, & "trying to add a subsection with a name ("// & TRIM(subsection%name)//") that was already used in section " & //TRIM(section%name)) - END IF END DO CALL section_retain(subsection) section%n_subsections = section%n_subsections + 1 @@ -765,11 +761,10 @@ CONTAINS isection = section_get_subsection_index(section_vals%section, subsection_name(1:my_index)) IF (isection > 0) res => section_vals%subs_vals(isection, irep)%section_vals - IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) THEN + IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) & CALL cp_abort(__LOCATION__, & "could not find subsection "//TRIM(subsection_name(1:my_index))//" in section "// & TRIM(section_vals%section%name)//" at ") - END IF IF (is_path .AND. ASSOCIATED(res)) THEN res => section_vals_get_subs_vals(res, subsection_name(my_index + 2:LEN_TRIM(subsection_name)), & i_rep_section, can_return_null) @@ -1101,18 +1096,16 @@ CONTAINS PRESENT(c_val) .OR. PRESENT(l_vals) .OR. PRESENT(i_vals) .OR. & PRESENT(r_vals) .OR. PRESENT(c_vals) ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF keyword => section%keywords(ik)%keyword - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF NULLIFY (my_val) IF (PRESENT(n_rep_val)) n_rep_val = 0 IF (irs <= SIZE(s_vals%values, 2)) THEN ! the section was parsed @@ -1135,12 +1128,11 @@ CONTAINS END IF IF (PRESENT(val)) val => my_val IF (valRequested) THEN - IF (.NOT. ASSOCIATED(my_val)) THEN + IF (.NOT. ASSOCIATED(my_val)) & CALL cp_abort(__LOCATION__, & "Value requested, but no value set getting value from "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF CALL val_get(my_val, l_val=l_val, i_val=i_val, r_val=r_val, & c_val=c_val, l_vals=l_vals, i_vals=i_vals, r_vals=r_vals, & c_vals=c_vals) @@ -1191,17 +1183,15 @@ CONTAINS IF (PRESENT(i_rep_section)) irs = i_rep_section section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF list => s_vals%values(ik, irs)%list END SUBROUTINE section_vals_list_get @@ -1276,22 +1266,20 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF ! Add values.. DO IF (irs <= SIZE(s_vals%values, 2)) EXIT CALL section_vals_add_values(s_vals) END DO - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF keyword => s_vals%section%keywords(ik)%keyword NULLIFY (my_val) IF (PRESENT(val)) my_val => val @@ -1300,20 +1288,18 @@ CONTAINS PRESENT(r_vals_ptr) .OR. PRESENT(c_vals_ptr) IF (ASSOCIATED(my_val)) THEN ! check better? - IF (valSet) THEN + IF (valSet) & CALL cp_abort(__LOCATION__, & " both val and values present, in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF ELSE ! ignore ? - IF (.NOT. valSet) THEN + IF (.NOT. valSet) & CALL cp_abort(__LOCATION__, & " empty value in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF CPASSERT(valSet) IF (keyword%type_of_var == lchar_t) THEN CALL val_create(my_val, lc_val=c_val, lc_vals_ptr=c_vals_ptr) @@ -1330,12 +1316,11 @@ CONTAINS IF (irk == -1) THEN CALL cp_sll_val_insert_el_at(vals, my_val, index=-1) ELSE IF (irk <= cp_sll_val_get_length(vals)) THEN - IF (irk <= 0) THEN + IF (irk <= 0) & CALL cp_abort(__LOCATION__, & "invalid irk "//TRIM(ADJUSTL(cp_to_string(irk)))// & " in keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF old_val => cp_sll_val_get_el_at(vals, index=irk) CALL val_release(old_val) CALL cp_sll_val_set_el_at(vals, value=my_val, index=irk) @@ -1401,19 +1386,17 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF ! ignore unset of non set values IF (irs <= SIZE(s_vals%values, 2)) THEN - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF IF (irk == -1) THEN pos => cp_sll_val_get_rest(s_vals%values(ik, irs)%list, iter=-1) ELSE @@ -1606,11 +1589,10 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(section%description))) & //"" - IF (ALLOCATED(section%deprecation_notice)) THEN + IF (ALLOCATED(section%deprecation_notice)) & WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & - //"" - END IF + TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & + //"" IF (ASSOCIATED(section%citations)) THEN DO i = 1, SIZE(section%citations, 1) @@ -1753,11 +1735,10 @@ CONTAINS CPASSERT(irep <= SIZE(s_vals%subs_vals, 2)) isection = section_get_subsection_index(s_vals%section, subsection_name(my_index:LEN_TRIM(subsection_name))) - IF (isection <= 0) THEN + IF (isection <= 0) & CALL cp_abort(__LOCATION__, & "could not find subsection "//subsection_name(my_index:LEN_TRIM(subsection_name))//" in section "// & TRIM(section_vals%section%name)//" at ") - END IF CALL section_vals_retain(new_section_vals) CALL section_vals_release(s_vals%subs_vals(isection, irep)%section_vals) s_vals%subs_vals(isection, irep)%section_vals => new_section_vals @@ -1832,12 +1813,10 @@ CONTAINS END DO END DO IF (.NOT. PRESENT(i_rep_low) .AND. (.NOT. PRESENT(i_rep_high))) THEN - IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) THEN + IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) & CPABORT("Incompatible sizes of values between input and output") - END IF - IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) THEN + IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) & CPABORT("Incompatible sizes of subsections between input and output") - END IF END IF iend = SIZE(section_vals_in%subs_vals, 2) IF (PRESENT(i_rep_high)) iend = i_rep_high diff --git a/src/input/input_val_types.F b/src/input/input_val_types.F index 83580f89e0..9ac7220f12 100644 --- a/src/input/input_val_types.F +++ b/src/input/input_val_types.F @@ -399,26 +399,23 @@ CONTAINS IF (val%type_of_var == lchar_t) THEN l_in = default_string_length*(SIZE(val%c_val) - 1) + & LEN_TRIM(val%c_val(SIZE(val%c_val))) - IF (l_out < l_in) THEN + IF (l_out < l_in) & CALL cp_warn(__LOCATION__, & "val_get will truncate value, value beginning with '"// & TRIM(val%c_val(1))//"' is too long for variable") - END IF DO i = 1, SIZE(val%c_val) c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = & val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length)) IF (l_out <= i*default_string_length) EXIT END DO - IF (l_out > SIZE(val%c_val)*default_string_length) THEN + IF (l_out > SIZE(val%c_val)*default_string_length) & c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = "" - END IF ELSE l_in = LEN_TRIM(val%c_val(1)) - IF (l_out < l_in) THEN + IF (l_out < l_in) & CALL cp_warn(__LOCATION__, & "val_get will truncate value, value '"// & TRIM(val%c_val(1))//"' is too long for variable") - END IF c_val = val%c_val(1) END IF ELSE diff --git a/src/input_constants.F b/src/input_constants.F index 3de5c8335e..093c401959 100644 --- a/src/input_constants.F +++ b/src/input_constants.F @@ -980,16 +980,11 @@ MODULE input_constants rtp_localize_each = 2 INTEGER, PARAMETER, PUBLIC :: rtp_method_tddft = 1, & - rtp_method_bse = 2, & - rtp_method_bse_linearized = 3 + rtp_method_bse = 2 INTEGER, PARAMETER, PUBLIC :: rtp_bse_ham_ks = 1, & rtp_bse_ham_g0w0 = 2 - INTEGER, PARAMETER, PUBLIC :: rtp_bse_kernel_ri_default = 0, & - rtp_bse_kernel_ri_rs = 1, & - rtp_bse_kernel_ri_ao = 2 - ! how to solve polarizable force fields INTEGER, PARAMETER, PUBLIC :: do_fist_pol_none = 1, & do_fist_pol_sc = 2, & diff --git a/src/input_cp2k_check.F b/src/input_cp2k_check.F index 87a01c5aaf..273e17ad76 100644 --- a/src/input_cp2k_check.F +++ b/src/input_cp2k_check.F @@ -80,9 +80,8 @@ CONTAINS CPASSERT(ASSOCIATED(input_file)) CPASSERT(input_file%ref_count > 0) ! ext_restart - IF (PRESENT(output_unit)) THEN + IF (PRESENT(output_unit)) & CALL handle_ext_restart(input_declaration, input_file, para_env, output_unit) - END IF ! checks on force_eval section sections => section_vals_get_subs_vals(input_file, "FORCE_EVAL") @@ -147,15 +146,13 @@ CONTAINS ! do not allow the use of external potential section => section_vals_get_subs_vals(sections, "DFT%EXTERNAL_POTENTIAL") CALL section_vals_get(section, explicit=apply_ext_potential) - IF (apply_ext_potential) THEN + IF (apply_ext_potential) & CPABORT("The EXTERNAL_POTENTIAL section is not allowed for the MiMiC runtype.") - END IF ! force eval methods supported with MiMiC CALL section_vals_val_get(sections, "METHOD", i_val=force_eval_method) - IF (force_eval_method /= do_qs) THEN + IF (force_eval_method /= do_qs) & CPABORT("At the moment, only Quickstep method is supported with MiMiC.") - END IF END IF CALL timestop(handle) @@ -434,33 +431,29 @@ CONTAINS IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_COORD") CALL section_vals_set_subs_vals(section2, "SHELL_COORD", section) - IF (check_restart(section1, section2, "SHELL_COORD")) THEN + IF (check_restart(section1, section2, "SHELL_COORD")) & CALL set_restart_info("SHELL COORDINATES", restarted_infos) - END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_POS", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_COORD") CALL section_vals_set_subs_vals(section2, "CORE_COORD", section) - IF (check_restart(section1, section2, "CORE_COORD")) THEN + IF (check_restart(section1, section2, "CORE_COORD")) & CALL set_restart_info("CORE COORDINATES", restarted_infos) - END IF END IF CALL section_vals_val_get(r_section, "RESTART_SHELL_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_VELOCITY") CALL section_vals_set_subs_vals(section2, "SHELL_VELOCITY", section) - IF (check_restart(section1, section2, "SHELL_VELOCITY")) THEN + IF (check_restart(section1, section2, "SHELL_VELOCITY")) & CALL set_restart_info("SHELL VELOCITIES", restarted_infos) - END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_VELOCITY") CALL section_vals_set_subs_vals(section2, "CORE_VELOCITY", section) - IF (check_restart(section1, section2, "CORE_VELOCITY")) THEN + IF (check_restart(section1, section2, "CORE_VELOCITY")) & CALL set_restart_info("CORE VELOCITIES", restarted_infos) - END IF END IF END IF ELSE @@ -984,20 +977,18 @@ CONTAINS CALL section_vals_set_subs_vals(input_file, TRIM(path)//"%AD_LANGEVIN%MASS", section) END SELECT ELSE - IF (input_type /= restart_type) THEN + IF (input_type /= restart_type) & CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of thermostat! Restarting is not possible! "// & "Thermostat will not be restarted! ") - END IF - IF (input_region /= restart_region) THEN + IF (input_region /= restart_region) & CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of REGION! Restarting is not possible! "// & "Thermostat will not be restarted! ") - END IF END IF END IF END SUBROUTINE restart_thermostat diff --git a/src/input_cp2k_dft.F b/src/input_cp2k_dft.F index 5ed7d32a5a..082cc27f4b 100644 --- a/src/input_cp2k_dft.F +++ b/src/input_cp2k_dft.F @@ -44,8 +44,7 @@ MODULE input_cp2k_dft numerical, plus_u_lowdin, plus_u_mulliken, plus_u_mulliken_charges, real_time_propagation, & rel_dkh, rel_none, rel_pot_erfc, rel_pot_full, rel_sczora_mp, rel_trans_atom, & rel_trans_full, rel_trans_molecule, rel_zora, rel_zora_full, rel_zora_mp, & - rtp_bse_ham_g0w0, rtp_bse_ham_ks, rtp_bse_kernel_ri_ao, rtp_bse_kernel_ri_default, & - rtp_bse_kernel_ri_rs, rtp_method_bse, rtp_method_tddft, sccs_andreussi, & + rtp_bse_ham_g0w0, rtp_bse_ham_ks, rtp_method_bse, rtp_method_tddft, sccs_andreussi, & sccs_derivative_cd3, sccs_derivative_cd5, sccs_derivative_cd7, sccs_derivative_fft, & sccs_fattebert_gygi, sccs_saa_andreussi, sic_ad, sic_eo, sic_list_all, sic_list_unpaired, & sic_mauri_spz, sic_mauri_us, sic_none, slater, use_mom_ref_coac, use_mom_ref_com, & @@ -251,14 +250,8 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify type and size of automatically generated auxiliary "// & - "(RI) basis sets. Exactly two arguments are required for this option. "// & - "The first argument of basis type should be one of the following: "// & - "`RI_AUX`, `AUX_FIT`, `LRI_AUX`, `P_LRI_AUX`, `RI_HXC`, `RI_XAS`, or "// & - "`RI_HFX`. The second argument of basis size should be one of the "// & - "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & - "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & - "as written here).", & + description="Specify size of automatically generated auxiliary (RI) basis sets: "// & + "Options={small,medium,large,huge}", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) @@ -1981,21 +1974,6 @@ CONTAINS CALL keyword_release(keyword) CALL section_add_subsection(print_section, print_key) CALL section_release(print_key) - ! Liouvillian eigenvalue diagnostic (linearized RT-BSE, TDA only) - CALL cp_print_key_section_create(print_key, __LOCATION__, "LIOUVILLIAN_EIG", & - description="Prints the eigenvalues of the linearized RT-BSE "// & - "Liouvillian on the OV subspace, computed once at job init from a "// & - "matrix-free probe of the kernel (no time propagation). In TDA this "// & - "equals the Casida-A eigenvalue problem and gives a broadening-free, "// & - "finite-time-free correctness check against bse_full.F. "// & - "Activated by RTBSE%DIAGNOSE_LIOUVILLIAN_EIG. Output lists "// & - "eigenvalues in atomic units and eV.", & - print_level=medium_print_level, common_iter_levels=0, & - each_iter_names=s2a("MD"), & - each_iter_values=[1], & - filename="LIOUVILLIAN_EIG") - CALL section_add_subsection(print_section, print_key) - CALL section_release(print_key) CALL cp_print_key_section_create(print_key, __LOCATION__, "E_CONSTITUENTS", & description="Print the energy constituents (relevant to RTP) which make up "// & @@ -2071,133 +2049,6 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - ! Switch for linearized rtbse propagation - CALL keyword_create(keyword, __LOCATION__, name="LINEARIZED_BSE_PROPAGATION", & - variants=s2a("LRRTBSE"), & - description="Linearizes the BSE propagation", & - usage="LINEARIZED_BSE_PROPAGATION .T.", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - ! Energy cutoff (occupied) for active MO window in linearized RT-BSE - CALL keyword_create(keyword, __LOCATION__, name="ENERGY_CUTOFF_OCC", & - description="Energy cutoff (relative to HOMO) defining the lowest "// & - "occupied molecular orbital included in the active MO window of the "// & - "linearized RT-BSE propagation. Only used when "// & - "LINEARIZED_BSE_PROPAGATION=.TRUE.. A non-positive value disables the "// & - "occupied truncation.", & - usage="ENERGY_CUTOFF_OCC 5.0", & - unit_str="eV", & - default_r_val=-1.0_dp/evolt) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - ! Energy cutoff (empty) for active MO window in linearized RT-BSE - CALL keyword_create(keyword, __LOCATION__, name="ENERGY_CUTOFF_EMPTY", & - description="Energy cutoff (relative to LUMO) defining the highest "// & - "virtual molecular orbital included in the active MO window of the "// & - "linearized RT-BSE propagation. Only used when "// & - "LINEARIZED_BSE_PROPAGATION=.TRUE.. A non-positive value disables the "// & - "virtual truncation.", & - usage="ENERGY_CUTOFF_EMPTY 5.0", & - unit_str="eV", & - default_r_val=-1.0_dp/evolt) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="ENFORCE_MAX_DT", & - description="For linearized RT-BSE, recompute TIMESTEP and STEPS so the same total "// & - "propagation time is covered with the largest timestep that does not exceed the "// & - "estimated RK4 stability limit.", & - usage="ENFORCE_MAX_DT", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - ! Tamm-Dancoff approximation for the linearized RT-BSE kernel - CALL keyword_create(keyword, __LOCATION__, name="TDA", & - description="Apply the Tamm-Dancoff approximation to the linearized RT-BSE kernel: "// & - "the Hartree and screened-exchange contributions are restricted so that the OV and VO "// & - "blocks of the density response remain decoupled (i.e. only A-block coupling is kept, "// & - "B-block coupling is dropped). Only effective when "// & - "LINEARIZED_BSE_PROPAGATION=.TRUE..", & - usage="TDA", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - ! First-peak shift for the TDA path - CALL keyword_create(keyword, __LOCATION__, name="TDA_SHIFT_TO_FIRST_PEAK", & - description="For the linearized RT-BSE TDA path, shift the active-MO single-particle "// & - "diagonals by +Omega_0/2 (occupied) and -Omega_0/2 (virtual) with "// & - "Omega_0 = eps_min_ai, so the lowest active OV mode oscillates at zero frequency "// & - "in the rotating frame (RK4-exact for peak 1). omega_max becomes the full active "// & - "OV width Delta = eps_max_ai - eps_min_ai. The rotation is undone at I/O so "// & - "observables remain in the lab frame. Only effective when TDA=.TRUE.. "// & - "Use with caution, additional convergence checks w.r.t. dt needed.", & - usage="TDA_SHIFT_TO_FIRST_PEAK", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="DEBUG_DISABLE_HARTREE", & - description="Debug option for linearized RT-BSE: disables the Hartree kernel in both "// & - "the static reference initialization and the propagation. The Coulomb RI setup is "// & - "still built so the run stays internally consistent.", & - usage="DEBUG_DISABLE_HARTREE", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="KERNEL_RI", & - description="Select the RI framework used to evaluate the linearized RT-BSE "// & - "Hartree and screened-exchange kernels (propagation and reference). "// & - "DEFAULT infers from the GW flavor: RI-RS if the GW_RI_RS section was active, "// & - "AO-RI otherwise. RS/AO force that framework regardless of how GW was run. The "// & - "RI-RS grid (mat_phi_mu_l, mat_Z_lP) and the V_grid/W0_grid kernels are built on "// & - "demand. RI-RS is implemented for linearized RT-BSE only; for full RT-BSE an "// & - "explicit RS is overridden to AO with a warning.", & - usage="KERNEL_RI RS", & - enum_c_vals=s2a("DEFAULT", "RS", "AO"), & - enum_i_vals=[rtp_bse_kernel_ri_default, rtp_bse_kernel_ri_rs, rtp_bse_kernel_ri_ao], & - enum_desc=s2a("Infer from the GW flavor (GW_RI_RS active -> RS, else AO).", & - "Real-space RI grid kernels (linearized RT-BSE only).", & - "AO-RI kernels."), & - default_i_val=rtp_bse_kernel_ri_default, n_var=1) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="DEBUG_DISABLE_SEX", & - description="Debug option for linearized RT-BSE: disables the screened-exchange kernel "// & - "in both the static reference initialization and the propagation.", & - usage="DEBUG_DISABLE_SEX", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - ! Liouvillian eigenvalue diagnostic (matrix-free probe at init; TDA + ABBA) - CALL keyword_create(keyword, __LOCATION__, name="DIAGNOSE_LIOUVILLIAN_EIG", & - description="Diagnostic for linearized RT-BSE: at job initialization, build the "// & - "Liouvillian on the OV subspace by probing the kernel routine with canonical OV basis "// & - "vectors, then diagonalize. In TDA this equals the Casida-A eigenvalue problem, giving a "// & - "broadening-free, finite-time-free correctness check against bse_full.F. "// & - "In ABBA it builds and diagonalizes the full coupled (A, B) Liouvillian via the "// & - "Furche reduction. "// & - "Output is controlled by the LIOUVILLIAN_EIG print key in the parent "// & - "&REAL_TIME_PROPAGATION%&PRINT section.", & - usage="DIAGNOSE_LIOUVILLIAN_EIG", & - default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - END SUBROUTINE create_rtbse_section ! ************************************************************************************************** !> \brief Creates the subsection for Fourier transform options applicable to RTP output diff --git a/src/input_cp2k_mm.F b/src/input_cp2k_mm.F index 4938f9cfea..aeb0be36a1 100644 --- a/src/input_cp2k_mm.F +++ b/src/input_cp2k_mm.F @@ -15,9 +15,9 @@ ! ************************************************************************************************** MODULE input_cp2k_mm USE bibliography, ONLY: & - Batatia2022, Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, & - Drautz2019, Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, & - Tan2025, Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 + Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, Drautz2019, & + Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, Tan2025, & + Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 USE cp_output_handling, ONLY: cp_print_key_section_create,& debug_print_level,& high_print_level,& @@ -1185,10 +1185,6 @@ CONTAINS CALL section_add_subsection(section, subsection) CALL section_release(subsection) - CALL create_MACE_section(subsection) - CALL section_add_subsection(section, subsection) - CALL section_release(subsection) - CALL create_DEEPMD_section(subsection) CALL section_add_subsection(section, subsection) CALL section_release(subsection) @@ -1487,48 +1483,6 @@ CONTAINS END SUBROUTINE create_NEQUIP_section -! ************************************************************************************************** -!> \brief This section specifies the input parameters for MACE potential type -!> \param section the section to create -!> \author Xinyue Sun -! ************************************************************************************************** - SUBROUTINE create_MACE_section(section) - TYPE(section_type), POINTER :: section - - TYPE(keyword_type), POINTER :: keyword - - CPASSERT(.NOT. ASSOCIATED(section)) - CALL section_create(section, __LOCATION__, name="MACE", & - description="This section specifies the input parameters for MACE potential type, "// & - "a higher-order equivariant message-passing neural network. "// & - "The MACE model must be exported to a TorchScript file that takes a single "// & - "dictionary argument (see the create_cp2k_model.py helper). "// & - "Requires linking with libtorch library from .", & - citations=[Batatia2022], n_keywords=1, n_subsections=0, repeats=.FALSE.) - - NULLIFY (keyword) - - CALL keyword_create(keyword, __LOCATION__, name="ATOMS", & - description="Defines the atomic kinds involved in the MACE potential. "// & - "Provide a list of each element, making sure that the mapping from the ATOMS list "// & - "to MACE atom types is correct. This mapping should also be consistent for the "// & - "atomic coordinates as specified in the sections COORDS or TOPOLOGY.", & - usage="ATOMS {KIND 1} {KIND 2} .. {KIND N}", type_of_var=char_t, & - n_var=-1) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="POT_FILE_NAME", & - variants=["MODEL_FILE_NAME"], & - description="Specifies the filename that contains the exported MACE model. "// & - "MACE models use standardized units (Angstrom for length, eV for energy, "// & - "eV/Angstrom for forces), so no unit keywords are required.", & - usage="POT_FILE_NAME {FILENAME}", default_lc_val=" ") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - END SUBROUTINE create_MACE_section - ! ************************************************************************************************** !> \brief This section specifies the input parameters for ACE potential type !> \param section the section to create diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index 9e9ecb5e4d..e120efee04 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -1803,13 +1803,8 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify type and size of automatically generated auxiliary "// & - "(RI) basis sets. Exactly two arguments are required for this option. "// & - "The first argument of basis type should be one of the following: "// & - "`P_LRI_AUX`. The second argument of basis size should be one of the "// & - "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & - "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & - "as written here).", & + description="Specify size of automatically generated auxiliary basis sets: "// & + "Options={small,medium,large,huge}", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) @@ -2484,9 +2479,7 @@ CONTAINS "use slurm, the number behind '--ntasks-per-node' is the number "// & "of MPI processes per node). Then calculate "// & "`MEMORY_PER_PROC` = mem_per_node / n_MPI_proc_per_node "// & - "(typically between 2 GB and 50 GB). Unit of keyword: Gigabyte (GB). "// & - "Note: This keyword is not used for GW calculations with RI-RS, "// & - "where the available memory is detected automatically.", & + "(typically between 2 GB and 50 GB). Unit of keyword: Gigabyte (GB).", & usage="MEMORY_PER_PROC 16", & default_r_val=2.0_dp) CALL section_add_keyword(section, keyword) @@ -2592,23 +2585,19 @@ CONTAINS CALL keyword_create(keyword, __LOCATION__, name="RI_RS", & description="Real-Space Resolution of Identity (RI-RS) method. This "// & - "approximation replaces the conventional 3-center RI integrals "// & - "$(\mu\nu|P)$ by a factorized representation on an atom-centered "// & - "real-space grid $\{\mathbf{r}_\ell\}$: "// & - "$(\mu\nu|P) \approx \sum_\ell \varphi_\mu(\mathbf{r}_\ell) "// & - "\varphi_\nu(\mathbf{r}_\ell) Z_{\ell P}$. "// & - "The coefficients $Z_{\ell P}$ combine the numerical integration "// & - "weights and the Coulomb potential of the auxiliary basis function "// & - "$P$ evaluated at grid point $\mathbf{r}_\ell$. To reduce the "// & - "computational cost, only grid points within the sphere $B^P$ are "// & - "included, where "// & - "$B^P = \{\mathbf{r} : |\mathbf{r} - \mathbf{R}_P| < R_c + r_P\}$. "// & - "Here, $r_P$ is the effective radius of the most diffuse RI "// & - "auxiliary Gaussian on atom $P$, at which the basis function "// & - "magnitude falls below a threshold $\delta$ "// & + "approximation replaces the conventional 3-center RI integrals (μν|P) "// & + "by a factorized representation on an atom-centered real-space grid "// & + "{r_ℓ}: (μν|P) ≈ ∑_ℓ φ_μ(r_ℓ) φ_ν(r_ℓ) Z_ℓP. "// & + "The coefficients Z_ℓP combine the numerical integration weights and "// & + "the Coulomb potential of the auxiliary basis function P evaluated "// & + "at grid point r_ℓ. To reduce the computational cost, only grid points "// & + "within the sphere B^P are included, where "// & + "B^P = {r : |r - R_P| < Rc + r_P}. "// & + "Here, r_P is the effective Gaussian basis radius for atom P at which "// & + "the basis function magnitude falls below a threshold δ "// & "(currently controlled through EPS_FILTER). "// & "This locality approximation yields a sparse representation of the "// & - "3-center integrals and enables reduced computational cost. "// & + "3-center integrals enables reduced computational cost. "// & "See details in https://doi.org/10.1063/1.5090605.", & usage="RI_RS", & default_l_val=.FALSE., & @@ -2617,56 +2606,35 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="TIKHONOV", & - description="Regularization parameter $\alpha$ used to stabilize "// & + description="Regularization parameter (α) used to stabilize "// & "the inversion of the grid-overlap matrix "// & - "$D$ in the RI-RS method. "// & - "See Equation (9) in https://doi.org/10.1063/1.5090605.", & + "D in the Real-Space RI (RI-RS) method. See Equation (9) in https://doi.org/10.1063/1.5090605.", & usage="TIKHONOV 1.0E-8", & default_r_val=1.0E-08_dp) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="GRID_SELECT", & - description="Selection of the atom-centered grid type used "// & + description="Selection of the atom-centeredgrid type used "// & "in RI-RS optimized by Duchemin and Blase. "// & - "(1) def2-TZVPP: Available for elements up to the fourth row "// & + "(1) def2-TZVPP: Grid optimized by Duchemin and Blase, "// & + "available for elements up to the fourth row "// & "of the periodic table (see https://doi.org/10.1021/acs.jctc.1c00101). "// & - "(2) cc-pVTZ: Available for H, C, N, and O atoms "// & - "(see https://doi.org/10.1063/1.5090605). "// & - "(3) User-provided grids: per-element grid files supplied by the "// & - "user, read as ri_rs_grid/ in the same format as "// & - "the built-in sets; the suffix is _rirs.ion by default and can be "// & - "changed with GRID_FILE_SUFFIX.", & + "(2) cc-pVTZ: Optimized grids available for H, C, N, and O atoms "// & + "(see https://doi.org/10.1063/1.5090605).", & usage="GRID_SELECT 1", & default_i_val=1) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="GRID_FILE_SUFFIX", & - description="Overrides the per-element grid file suffix used by "// & - "GRID_SELECT 3; grid files are read as ri_rs_grid/.", & - usage="GRID_FILE_SUFFIX _my-grids.ion", & - default_lc_val="") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_RI", & - description="Real-space cutoff radius (in Angstrom) for evaluating "// & - "the RI-RS integration domain $B^P$. Overrides the default "// & - "$R_c + r_P$, where $R_c$ is the truncated-Coulomb cutoff of the "// & - "RI metric and $r_P$ the radius of the most diffuse RI auxiliary "// & - "Gaussian on atom $P$.", & - usage="CUTOFF_RADIUS_RL_RI 15.0", & - default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & - type_of_var=real_t, unit_str="angstrom") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_AO", & - description="Real-space cutoff radius (in Angstrom) for evaluating "// & - "the AO basis functions on the RI-RS grid. Override the default radius "// & - "derived automatically from the most diffuse AO Gaussian on each atom. ", & - usage="CUTOFF_RADIUS_RL_AO 8.0", & + CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RI_RS", & + description="Override (in Angstrom) of the truncated-Coulomb cutoff radius Rc used "// & + "to size the per-atom RI-RS integration domain "// & + "B^P = {r : |r - R_P| < Rc + r_AO(P)}, where r_AO(P) is the spatial extent of the "// & + "most diffuse AO Gaussian on atom P. By default (-1.0) Rc falls back to "// & + "CUTOFF_RADIUS_RI from the GW section (the same Rc used to build the RI metric "// & + "integrals). Useful for convergence sweeps.", & + usage="CUTOFF_RADIUS_RI_RS 15.0", & default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & type_of_var=real_t, unit_str="angstrom") CALL section_add_keyword(section, keyword) @@ -2674,63 +2642,21 @@ CONTAINS CALL keyword_create(keyword, __LOCATION__, name="N_PROCS_PER_ATOM_Z_LP", & description="Number of MPI ranks that cooperate on one atom's "// & - "Cholesky factorisation in computation of $Z_{\ell P}$ in RI-RS. "// & - "Default -1 = AUTO: "// & - "each atom is solved single-rank (fast BLAS) unless its dense "// & - "grid-overlap matrix would exceed the available memory per process, "// & - "in which case it is distributed across a rank subgroup sized "// & - "automatically (ScaLAPACK). Set to 1 to force single-rank for all "// & - "atoms, or > 1 to force that fixed subgroup size for all atoms.", & - usage="N_PROCS_PER_ATOM_Z_LP 2", & - default_i_val=-1) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="N_PANELS", & - description="Number of grid panels (batches) the real-space grid is "// & - "split into for the streaming chi/W/Sigma contractions in RI-RS. More "// & - "panels means lower peak memory per step but more overhead. Default 1 = a "// & - "single whole-grid panel. On large cells the number of panels is "// & - "automatically increased beyond the request to keep per-rank DBCSR "// & - "messages under the 32-bit length limit.", & - usage="N_PANELS 4", & + "Cholesky factorisation in compute_coeff_Z_lP. Default 1 keeps "// & + "the single-rank LAPACK dpotrf path (BLAS, fastest when "// & + "D_local fits per rank). Setting > 1 enables a ScaLAPACK "// & + "pdpotrf path: ranks are split into atom-groups of this size, "// & + "D_local is block-cyclic distributed across each group (per-rank "// & + "memory ~1/G), the compute_d_lp build is also distributed across "// & + "the subgroup, and multiple groups process different atoms in "// & + "parallel. Use for systems where n_local_grid is large enough "// & + "that the dense (n_local_grid)^2 D_local does not fit in a "// & + "single rank's memory.", & + usage="N_PROCS_PER_ATOM_Z_LP 16", & default_i_val=1) CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="KEEP_SPARSITY_RL", & - description="If `.TRUE.` (default), the W/V matrices in the "// & - "grid-basis contractions of RI-RSwill used the sparsity pattern of the "// & - "corresponding G/D matrices. "// & - "Set `.FALSE.` to build W/V fully dense.", & - usage="KEEP_SPARSITY_RL .FALSE.", & - default_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_RL_W", & - description="Real-space truncation radius (Angstrom) for the grid-basis "// & - "G operators in the RI-RS GW self-energy. "// & - "Default -1.0 disables the truncation (exact grid-basis operators).", & - usage="CUTOFF_RADIUS_RL_W 20.0", & - default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & - type_of_var=real_t, unit_str="angstrom") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="CUTOFF_RADIUS_G_W", & - description="Atom-pair distance truncation radius (Angstrom) applied to "// & - "the AO/RI-space operator matrices G, D, V and W themselves in the RI-RS "// & - "GW contractions: matrix blocks between atoms further apart than this "// & - "radius are dropped. Physically consistent with CUTOFF_RADIUS_RL_W, "// & - "which truncates the grid-basis products at the same kind of range. "// & - "Default -1.0 disables the truncation (exact operators).", & - usage="CUTOFF_RADIUS_G_W 20.0", & - default_r_val=cp_unit_to_cp2k(value=-1.0_dp, unit_str="angstrom"), & - type_of_var=real_t, unit_str="angstrom") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection) CALL section_release(subsection) diff --git a/src/input_cp2k_restarts_util.F b/src/input_cp2k_restarts_util.F index c281e5f8b7..2411d815ec 100644 --- a/src/input_cp2k_restarts_util.F +++ b/src/input_cp2k_restarts_util.F @@ -62,11 +62,10 @@ CONTAINS CPASSERT(velocity_section%ref_count > 0) section => velocity_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF ! At least one of the two arguments must be present.. check = PRESENT(particles) .NEQV. PRESENT(velocity) diff --git a/src/input_cp2k_tb.F b/src/input_cp2k_tb.F index 8c5443b8a5..ba3342df1b 100644 --- a/src/input_cp2k_tb.F +++ b/src/input_cp2k_tb.F @@ -243,12 +243,6 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="SPIN_POLARISATION", & - description="Use the spin polarisation Hamiltonian for gfn1/2", & - usage="SPIN_POLARISATION T", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="COULOMB_INTERACTION", & description="Use Coulomb interaction terms (electrostatics + TB3); for debug only", & usage="COULOMB_INTERACTION T", default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) @@ -444,14 +438,6 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="SPINPOL_PARAM_FILE_NAME", & - description="Specify file that contains parameters for "// & - "xTB spin polarisation Hamiltonian", & - usage="SPINPOL_PARAM_FILE_NAME filename", & - n_var=1, type_of_var=char_t, default_c_val="xTB_sp_param_060") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="DISPERSION_PARAMETER_FILE", & description="Specify file that contains the atomic dispersion "// & "parameters for the D3 method", & @@ -539,13 +525,6 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="SPIN_POL_PARAM", & - description="Specifies the spin polarisation parameters for kind A.", & - usage="SPIN_POL_PARAM atomtype Wss Wsp Wpp Wsd Wpd Wdd", repeats=.TRUE., & - n_var=-1, type_of_var=char_t) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="XB_RADIUS", & description="Specifies the radius [Bohr] of the XB pair interaction in xTB.", & usage="XB_RADIUS 20.0 ", repeats=.FALSE., & diff --git a/src/input_restart_force_eval.F b/src/input_restart_force_eval.F index e333517e4b..77181ca694 100644 --- a/src/input_restart_force_eval.F +++ b/src/input_restart_force_eval.F @@ -555,11 +555,10 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT @@ -690,11 +689,10 @@ CONTAINS CPASSERT(dipoles_section%ref_count > 0) section => dipoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF ! At least one of the two arguments must be present.. nloop = SIZE(dipoles, 2) @@ -768,11 +766,10 @@ CONTAINS CPASSERT(quadrupoles_section%ref_count > 0) section => quadrupoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF ! At least one of the two arguments must be present.. nloop = SIZE(quadrupoles, 2) diff --git a/src/input_restart_rng.F b/src/input_restart_rng.F index ea236ff010..51913f61cf 100644 --- a/src/input_restart_rng.F +++ b/src/input_restart_rng.F @@ -61,11 +61,10 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(rng_section%values, 2) == 1) EXIT diff --git a/src/ipi_driver.F b/src/ipi_driver.F index 2cc3412c97..ea8b57b9a3 100644 --- a/src/ipi_driver.F +++ b/src/ipi_driver.F @@ -87,7 +87,7 @@ CONTAINS #else INTEGER, PARAMETER :: MSGLEN = 12 - CHARACTER(len=default_path_length) :: c_hostname, drv_hostname, drv_prefix + CHARACTER(len=default_path_length) :: c_hostname, drv_hostname CHARACTER(LEN=default_string_length) :: header INTEGER :: drv_port, handle, i_drv_unix, & idir, ii, inet, ip, iwait, & @@ -132,7 +132,6 @@ CONTAINS CALL section_vals_val_get(drv_section, "HOST", c_val=drv_hostname) CALL section_vals_val_get(drv_section, "PORT", i_val=drv_port) CALL section_vals_val_get(drv_section, "UNIX", l_val=drv_unix) - CALL section_vals_val_get(drv_section, "PREFIX", c_val=drv_prefix) CALL section_vals_val_get(drv_section, "SLEEP_TIME", r_val=sleeptime) CPASSERT(sleeptime >= 0) @@ -146,14 +145,7 @@ CONTAINS WRITE (output_unit, *) "@ INPUT DATA: ", TRIM(drv_hostname), drv_port, drv_unix END IF - IF (drv_unix) THEN - ! for UNIX sockets, HOST names the socket file which lives at - ! /tmp/_ (PREFIX must match the peer's convention, - ! e.g. "ipi" for i-PI) - c_hostname = "/tmp/"//TRIM(drv_prefix)//"_"//TRIM(drv_hostname)//C_NULL_CHAR - ELSE - c_hostname = TRIM(drv_hostname)//C_NULL_CHAR - END IF + c_hostname = TRIM(drv_hostname)//C_NULL_CHAR IF (ionode) CALL open_connect_socket(socket, i_drv_unix, drv_port, c_hostname) NULLIFY (wait_msg) @@ -220,9 +212,8 @@ CONTAINS CALL para_env%bcast(combuf) CALL force_env_get(force_env, subsys=subsys) - IF (nat /= subsys%particles%n_els) THEN + IF (nat /= subsys%particles%n_els) & CPABORT("@DRIVER MODE: Uh-oh! Particle number mismatch between i-PI and cp2k input!") - END IF ii = 0 DO ip = 1, subsys%particles%n_els DO idir = 1, 3 diff --git a/src/ipi_server.F b/src/ipi_server.F index 14146f1a6d..8cb6ac0d66 100644 --- a/src/ipi_server.F +++ b/src/ipi_server.F @@ -87,7 +87,7 @@ CONTAINS CALL timeset(routineN, handle) CPABORT("CP2K was compiled with the __NO_SOCKETS option!") #else - CHARACTER(len=default_path_length) :: c_hostname, drv_hostname, drv_prefix + CHARACTER(len=default_path_length) :: c_hostname, drv_hostname INTEGER :: drv_port, handle, i_drv_unix, & output_unit, socket, comm_socket CHARACTER(len=msglength) :: msgbuffer @@ -102,7 +102,6 @@ CONTAINS CALL section_vals_val_get(driver_section, "HOST", c_val=drv_hostname) CALL section_vals_val_get(driver_section, "PORT", i_val=drv_port) CALL section_vals_val_get(driver_section, "UNIX", l_val=drv_unix) - CALL section_vals_val_get(driver_section, "PREFIX", c_val=drv_prefix) IF (output_unit > 0) THEN WRITE (output_unit, *) "@ i-PI SERVER BEING STARTED" WRITE (output_unit, *) "@ HOSTNAME: ", TRIM(drv_hostname) @@ -116,14 +115,7 @@ CONTAINS i_drv_unix = 1 ! a bit convoluted. socket.c uses a different convention... IF (drv_unix) i_drv_unix = 0 - IF (drv_unix) THEN - ! for UNIX sockets, HOST names the socket file which lives at - ! /tmp/_ (PREFIX must match the peer's convention, - ! e.g. "ipi" for i-PI) - c_hostname = "/tmp/"//TRIM(drv_prefix)//"_"//TRIM(drv_hostname)//C_NULL_CHAR - ELSE - c_hostname = TRIM(drv_hostname)//C_NULL_CHAR - END IF + c_hostname = TRIM(drv_hostname)//C_NULL_CHAR IF (ionode) THEN CALL open_bind_socket(socket, i_drv_unix, drv_port, c_hostname) CALL listen_socket(socket, 1_c_int) @@ -187,18 +179,16 @@ CONTAINS ! Step 1: See if the client is ready CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "READY") THEN + IF (TRIM(msgbuffer) /= "READY") & CPABORT("i–PI: Expected READY header but recieved "//TRIM(msgbuffer)) - END IF ! Step 2: Send cell and position data to client CALL send_posdata(comm_socket, subsys=ipi_env%subsys) ! Step 3: Ask for status, should be done now CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "HAVEDATA") THEN + IF (TRIM(msgbuffer) /= "HAVEDATA") & CPABORT("i–PI: Expected HAVEDATA header but recieved "//TRIM(msgbuffer)) - END IF ! Step 4: Ask for data ALLOCATE (forces(3, nAtom)) @@ -277,9 +267,8 @@ CONTAINS ! Exchange headers CALL writebuffer(sockfd, msg, msglength) CALL get_header(sockfd, msgbuffer) - IF (TRIM(msgbuffer) /= "FORCEREADY") THEN + IF (TRIM(msgbuffer) /= "FORCEREADY") & CPABORT("i–PI: Expected FORCEREADY header but recieved "//TRIM(msgbuffer)) - END IF ! Recieve data CALL readbuffer(sockfd, energy) diff --git a/src/iterate_matrix.F b/src/iterate_matrix.F index 4a6b4b3a88..d78f5a3191 100644 --- a/src/iterate_matrix.F +++ b/src/iterate_matrix.F @@ -1177,9 +1177,8 @@ CONTAINS END IF END DO - IF (.NOT. converged) THEN + IF (.NOT. converged) & CPABORT("dense_matrix_sign_Newton_Schulz did not converge within 100 iterations") - END IF DEALLOCATE (tmp1) DEALLOCATE (tmp2) @@ -1808,9 +1807,8 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) THEN + IF (abnormal_value(conv)) & CPABORT("conv is an abnormal value (NaN/Inf).") - END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN @@ -2030,9 +2028,8 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) THEN + IF (abnormal_value(conv)) & CPABORT("conv is an abnormal value (NaN/Inf).") - END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN diff --git a/src/kg_correction.F b/src/kg_correction.F index 3377337cde..ab870ac90a 100644 --- a/src/kg_correction.F +++ b/src/kg_correction.F @@ -309,9 +309,8 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) THEN + IF (ASSOCIATED(vxc_tau)) & ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) - END IF END DO END IF END IF @@ -410,9 +409,8 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) THEN + IF (ASSOCIATED(vxc_tau)) & ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) - END IF END DO END IF END IF diff --git a/src/kg_vertex_coloring_methods.F b/src/kg_vertex_coloring_methods.F index d95ccc533a..bf437d443f 100644 --- a/src/kg_vertex_coloring_methods.F +++ b/src/kg_vertex_coloring_methods.F @@ -667,9 +667,8 @@ CONTAINS valid = .FALSE. CALL check_coloring(graph, valid) - IF (.NOT. valid) THEN + IF (.NOT. valid) & CPABORT("Coloring not valid.") - END IF nnodes = SIZE(kg_env%molecule_set) diff --git a/src/kpoint_io.F b/src/kpoint_io.F index a7e2ee483c..e7e544a0a0 100644 --- a/src/kpoint_io.F +++ b/src/kpoint_io.F @@ -231,7 +231,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -266,7 +266,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 diff --git a/src/kpoint_methods.F b/src/kpoint_methods.F index 6abad3f2a7..1c579b7dac 100644 --- a/src/kpoint_methods.F +++ b/src/kpoint_methods.F @@ -2299,14 +2299,14 @@ CONTAINS CALL dbcsr_iterator_next_block(iter, irow, icol, rblock) IF (.NOT. ALLOCATED(rwork)) THEN ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSE IF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN + ELSEIF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (rwork) ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF IF (.NOT. real_only) THEN IF (.NOT. ALLOCATED(cwork)) THEN ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSE IF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN + ELSEIF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (cwork) ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF diff --git a/src/kpoint_mo_symmetry_methods.F b/src/kpoint_mo_symmetry_methods.F deleted file mode 100644 index 3483dc7889..0000000000 --- a/src/kpoint_mo_symmetry_methods.F +++ /dev/null @@ -1,238 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief Utilities for transforming k-point MO coefficients under symmetry operations -! ************************************************************************************************** -MODULE kpoint_mo_symmetry_methods - USE cp_fm_types, ONLY: cp_fm_copy_general,& - cp_fm_get_info,& - cp_fm_get_submatrix,& - cp_fm_set_submatrix,& - cp_fm_type - USE kinds, ONLY: dp - USE kpoint_types, ONLY: kind_rotmat_type,& - kpoint_sym_type,& - kpoint_type - USE mathconstants, ONLY: twopi - USE message_passing, ONLY: mp_para_env_type -#include "./base/base_uses.f90" - - IMPLICIT NONE - PRIVATE - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'kpoint_mo_symmetry_methods' - - PUBLIC :: kpoint_same_periodic, & - kpoint_transform_scf_mo - -CONTAINS - -! ************************************************************************************************** -!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. -!> \param xkp_a first k-point -!> \param xkp_b second k-point -!> \return true if the k-points are equivalent -! ************************************************************************************************** - LOGICAL FUNCTION kpoint_same_periodic(xkp_a, xkp_b) RESULT(same) - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b - - REAL(KIND=dp), DIMENSION(3) :: diff - - diff(1:3) = xkp_a(1:3) - xkp_b(1:3) - diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) - same = SUM(ABS(diff(1:3))) < 1.0e-8_dp - - END FUNCTION kpoint_same_periodic - -! ************************************************************************************************** -!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. -!> \param src_real real part of source MO coefficients -!> \param src_imag imaginary part of source MO coefficients -!> \param dst_real real part of transformed MO coefficients -!> \param dst_imag imaginary part of transformed MO coefficients -!> \param qs_kpoint SCF k-point object containing symmetry operations -!> \param ikred representative k-point index -!> \param isym symmetry operation index; 0 direct copy, -1 time reversal -!> \param para_env global parallel environment -!> \param success true if the transformation was performed -!> \param reason diagnostic message -! ************************************************************************************************** - SUBROUTINE kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & - isym, para_env, success, reason) - TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: ikred, isym - TYPE(mp_para_env_type), POINTER :: para_env - LOGICAL, INTENT(OUT) :: success - CHARACTER(LEN=*), INTENT(OUT) :: reason - - INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & - nmo, rot_slot, source_atom, source_dim, target_atom, target_dim - INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start - LOGICAL :: reverse_phase, time_reversal - REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & - phase_imag, phase_real, sinkl - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r - REAL(KIND=dp), DIMENSION(3) :: xkp_phase - REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat - TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot - TYPE(kpoint_sym_type), POINTER :: kpsym - - success = .FALSE. - reason = "" - IF (isym == 0) THEN - CALL cp_fm_copy_general(src_real, dst_real, para_env) - CALL cp_fm_copy_general(src_imag, dst_imag, para_env) - success = .TRUE. - RETURN - END IF - - CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) - ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) - CALL cp_fm_get_submatrix(src_real, src_r) - CALL cp_fm_get_submatrix(src_imag, src_i) - dst_r(:, :) = 0.0_dp - dst_i(:, :) = 0.0_dp - - IF (isym == -1) THEN - dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) - dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i) - success = .TRUE. - RETURN - END IF - - IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN - reason = "SCF symmetry operation data are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym - IF (.NOT. ASSOCIATED(kpsym)) THEN - reason = "SCF k-point symmetry operation is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (isym > kpsym%nwred) THEN - reason = "SCF k-point symmetry operation index is out of range" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN - reason = "SCF atom mappings or basis rotation matrices are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - - rot_slot = find_kpoint_rotation_slot(qs_kpoint, kpsym%rotp(isym)) - IF (rot_slot == 0) THEN - reason = "could not match the SCF symmetry operation to a basis rotation" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) - natom = SIZE(qs_kpoint%atype) - ALLOCATE (ao_start(natom), ao_size(natom)) - irow = 1 - DO iatom = 1, natom - ikind = qs_kpoint%atype(iatom) - IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN - reason = "a required basis rotation matrix is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - ao_start(iatom) = irow - ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) - irow = irow + ao_size(iatom) - END DO - IF (irow - 1 /= nao) THEN - reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - - time_reversal = kpsym%rotp(isym) < 0 - reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) - IF (ASSOCIATED(kpsym%phase_mode)) THEN - IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 - END IF - xkp_phase(1:3) = kpsym%xkp(1:3, isym) - DO iatom = 1, natom - source_atom = iatom - target_atom = kpsym%f0(iatom, isym) - ikind = qs_kpoint%atype(source_atom) - rotmat => kind_rot(ikind)%rmat - source_dim = ao_size(source_atom) - target_dim = ao_size(target_atom) - IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN - reason = "basis rotation dimensions do not match the atom/AO symmetry transform" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & - REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & - REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) - IF (ASSOCIATED(kpsym%kgphase)) THEN - arg = arg + kpsym%kgphase(source_atom, isym) - END IF - IF (reverse_phase) arg = -arg - coskl = COS(twopi*arg) - sinkl = SIN(twopi*arg) - DO imo = 1, nmo - DO irow_work = 1, source_dim - irow_source = ao_start(source_atom) + irow_work - 1 - coeff_real = src_r(irow_source, imo) - coeff_imag = src_i(irow_source, imo) - IF (time_reversal) coeff_imag = -coeff_imag - phase_real = coskl*coeff_real - sinkl*coeff_imag - phase_imag = sinkl*coeff_real + coskl*coeff_imag - DO iao = 1, target_dim - irow_target = ao_start(target_atom) + iao - 1 - dst_r(irow_target, imo) = dst_r(irow_target, imo) + & - rotmat(iao, irow_work)*phase_real - dst_i(irow_target, imo) = dst_i(irow_target, imo) + & - rotmat(iao, irow_work)*phase_imag - END DO - END DO - END DO - END DO - - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - success = .TRUE. - - END SUBROUTINE kpoint_transform_scf_mo - -! ************************************************************************************************** -!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. -!> \param qs_kpoint SCF k-point object -!> \param rotp signed operation identifier -!> \return rotation slot, or zero when no slot matches -! ************************************************************************************************** - INTEGER FUNCTION find_kpoint_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: rotp - - INTEGER :: irot, rot_abs - - rot_slot = 0 - rot_abs = ABS(rotp) - IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN - DO irot = 1, SIZE(qs_kpoint%ibrot) - IF (rot_abs == qs_kpoint%ibrot(irot)) THEN - rot_slot = irot - RETURN - END IF - END DO - - END FUNCTION find_kpoint_rotation_slot - -END MODULE kpoint_mo_symmetry_methods diff --git a/src/kpoint_transitional.F b/src/kpoint_transitional.F index 3a0ca3aa07..fba771ac76 100644 --- a/src/kpoint_transitional.F +++ b/src/kpoint_transitional.F @@ -47,9 +47,8 @@ CONTAINS TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: res IF (ASSOCIATED(this%ptr_1d)) THEN - IF (SIZE(this%ptr_2d, 2) /= 1) THEN + IF (SIZE(this%ptr_2d, 2) /= 1) & CPABORT("Method not implemented for k-points") - END IF END IF res => this%ptr_1d diff --git a/src/kpoint_types.F b/src/kpoint_types.F index 10a0dd0c05..2f949201c3 100644 --- a/src/kpoint_types.F +++ b/src/kpoint_types.F @@ -566,9 +566,8 @@ CONTAINS IF (PRESENT(full_grid)) full_grid = kpoint%full_grid IF (PRESENT(inversion_symmetry_only)) inversion_symmetry_only = kpoint%inversion_symmetry_only IF (PRESENT(symmetry_backend)) symmetry_backend = kpoint%symmetry_backend - IF (PRESENT(symmetry_reduction_method)) THEN + IF (PRESENT(symmetry_reduction_method)) & symmetry_reduction_method = kpoint%symmetry_reduction_method - END IF IF (PRESENT(use_real_wfn)) use_real_wfn = kpoint%use_real_wfn IF (PRESENT(eps_geo)) eps_geo = kpoint%eps_geo IF (PRESENT(parallel_group_size)) parallel_group_size = kpoint%parallel_group_size @@ -682,9 +681,8 @@ CONTAINS IF (PRESENT(full_grid)) kpoint%full_grid = full_grid IF (PRESENT(inversion_symmetry_only)) kpoint%inversion_symmetry_only = inversion_symmetry_only IF (PRESENT(symmetry_backend)) kpoint%symmetry_backend = symmetry_backend - IF (PRESENT(symmetry_reduction_method)) THEN + IF (PRESENT(symmetry_reduction_method)) & kpoint%symmetry_reduction_method = symmetry_reduction_method - END IF IF (PRESENT(use_real_wfn)) kpoint%use_real_wfn = use_real_wfn IF (PRESENT(eps_geo)) kpoint%eps_geo = eps_geo IF (PRESENT(parallel_group_size)) kpoint%parallel_group_size = parallel_group_size diff --git a/src/kpsym.F b/src/kpsym.F index 4342c92f8b..170c44e613 100644 --- a/src/kpsym.F +++ b/src/kpsym.F @@ -188,12 +188,10 @@ CONTAINS a02(i) = a2(i)/alat a03(i) = a3(i)/alat END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| NUMBER OF ATOMS (STRUCT):",I6)') nat - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",10X,"K TYPE",14X,"X(K)")') - END IF itype = 0 DO i = 1, nat ! Assign an atomic type (for internal purposes) @@ -208,22 +206,19 @@ CONTAINS END IF itype = itype + 1 IF (itype > nsp) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I4,")")') & - ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & - nsp - END IF - IF (iout > 0) THEN + ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & + nsp + IF (iout > 0) & WRITE (iout, '(" KPSYM| THE ARRAY TY IS:",/,9(1X,10I7,/))') & - (ty(j), j=1, nat) - END IF + (ty(j), j=1, nat) CALL stopgm('K290', 'FATAL ERROR') END IF 178 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",6X,I5,I6,3F10.5)') & - i, ty(i), (xkapa(j, i), j=1, 3) - END IF + i, ty(i), (xkapa(j, i), j=1, 3) END DO ! ==--------------------------------------------------------------== ! IS THE STRAIN SIGNIFICANT ? @@ -269,12 +264,11 @@ CONTAINS ! ==--------------------------------------------------------------== invadd = 0 IF (li == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,A,/,A)') & - ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & - ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & - ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' - END IF + ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & + ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & + ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' invadd = 1 END IF ! ==--------------------------------------------------------------== @@ -289,125 +283,101 @@ CONTAINS ! ==--------------------------------------------------------------== ! == GROUP-THEORETICAL INFORMATION == ! ==--------------------------------------------------------------== - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM| GROUP-THEORETICAL INFORMATION:")') - END IF ! IHG .... Point group of the primitive lattice, holohedral - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(" KPSYM| POINT GROUP OF THE PRIMITIVE LATTICE: ",A," SYSTEM")') & - icst(ihg) - END IF + icst(ihg) ! IHC .... Code distinguishing between hexagonal and cubic groups ! ISY .... Code indicating whether the space group is symmorphic IF (isy == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP")') - END IF - ELSE IF (isy == 1) THEN - IF (iout > 0) THEN + ELSEIF (isy == 1) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP")') - END IF - ELSE IF (isy == -1) THEN - IF (iout > 0) THEN + ELSEIF (isy == -1) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP WITH NON-STANDARD ORIGIN")') - END IF - ELSE IF (isy == -2) THEN - IF (iout > 0) THEN + ELSEIF (isy == -2) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP???")') - END IF END IF ! LI ..... Inversions symmetry IF (li == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NO INVERSION SYMMETRY")') - END IF - ELSE IF (li > 0) THEN - IF (iout > 0) THEN + ELSEIF (li > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"INVERSION SYMMETRY")') - END IF END IF ! NC ..... Total number of elements in the point group - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(" KPSYM|",4X,"TOTAL NUMBER OF ELEMENTS IN THE POINT GROUP:",I3)') nc - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"TO SUM UP: (",I1,5I3,")")') & - ihg, ihc, isy, li, nc, indpg - END IF + ihg, ihc, isy, li, nc, indpg ! IB ..... List of the rotations constituting the point group - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE ROTATIONS:")') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(7X,12I4)') (ib(i), i=1, nc) - END IF ! V ...... Nonprimitive translations (for nonsymmorphic groups) IF (isy <= 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"NONPRIMITIVE TRANSLATIONS:")') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A)') & - ' ROT V IN THE BASIS A1, A2, A3 ', & - 'V IN CARTESIAN COORDINATES' - END IF + ' ROT V IN THE BASIS A1, A2, A3 ', & + 'V IN CARTESIAN COORDINATES' ! Cartesian components of nonprimitive translation. DO i = 1, nc DO j = 1, 3 vv0(j) = v(1, i)*a1(j) + v(2, i)*a2(j) + v(3, i)*a3(j) END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(1X,I3,3F10.5,3X,3F10.5)') & - ib(i), (v(j, i), j=1, 3), vv0 - END IF + ib(i), (v(j, i), j=1, 3), vv0 END DO END IF ! F0 ..... The function defined in Maradudin, Ipatova by ! eq. (3.2.12): atom transformation table. - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(/," KPSYM|",4X,"ATOM TRANSFORMATION TABLE (MARADUDIN,VOSKO):")') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(5(4X,"R AT->AT"))') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(I5," [Identity]")') 1 - END IF DO k = 2, nc DO j = 1, nat - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(I5,2I4)', advance="no") ib(k), j, f0(k, j) - END IF - IF ((MOD(j, 5) == 0) .AND. iout > 0) THEN + IF ((MOD(j, 5) == 0) .AND. iout > 0) & WRITE (iout, *) - END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & WRITE (iout, *) - END IF END DO ! R ...... List of the 3 x 3 rotation matrices - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE 3 X 3 ROTATION MATRICES:")') - END IF IF (ihc == 0) THEN DO k = 1, nc - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(4X,I3," (",I2,": ",A11,")",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) - END IF + k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) END DO ELSE DO k = 1, nc - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(4X,I3," (",I2,": ",A10,") ",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) - END IF + k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) END DO END IF ! ==--------------------------------------------------------------== @@ -421,42 +391,34 @@ CONTAINS ! (cubic/hexagonal) will apply to the crystal as well as the Bravais ! lattice. ! ==--------------------------------------------------------------== - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/,1X,19("*"),A,25("*"))') & - ' GENERATION OF SPECIAL POINTS ' - END IF + ' GENERATION OF SPECIAL POINTS ' ! Parameter Q of Monkhorst and Pack, generalized for 3 axes B1,2,3 - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,1X,3I5)') & - ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & - iq1, iq2, iq3 - END IF + ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & + iq1, iq2, iq3 ! WVK0 is the shift of the whole mesh (see Macdonald) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,1X,3F10.5)') & - ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 - END IF - IF (ABS(iq1) + ABS(iq2) + ABS(iq3) == 0) GOTO 710 + ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 + IF (iabs(iq1) + iabs(iq2) + iabs(iq3) == 0) GOTO 710 IF (ABS(istriz) /= 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz - END IF CALL stopgm('K290', 'ISTRIZ WRONG ARGUMENT') END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| SYMMETRIZATION SWITCH: ",I3)', advance="no") istriz - END IF IF (istriz == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" (SYMMETRIZATION OF MONKHORST-PACK MESH)")') - END IF ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" (NO SYMMETRIZATION OF MONKHORST-PACK MESH)")') - END IF END IF ! Set to 0. DO i = 1, nkpoint @@ -471,15 +433,12 @@ CONTAINS ! rotations than Bravais lattice. ! We use only the rotations for Bravais lattices IF (ntvec == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR BRAVAIS LATTICE', nc0 - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR CRYSTAL LATTICE', nc - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) ' KPSYM| NO DUPLICATION FOUND' - END IF CALL stopgm('ERROR', & 'SOMETHING IS WRONG IN GROUP DETERMINATION') END IF @@ -487,24 +446,19 @@ CONTAINS DO i = 1, nc0 ib(i) = ib0(i) END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/,1X,20("! "),"WARNING",20("!"))') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' - END IF - IF (iout > 0) THEN + ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' - END IF - IF (iout > 0) THEN + ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' - END IF - IF (iout > 0) THEN + ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' + IF (iout > 0) & WRITE (iout, '(1X,20("! "),"WARNING",20("!"),/)') - END IF END IF CALL sppt2(iout, iq1, iq2, iq3, wvk0, nkpoint, & a01, a02, a03, b01, b02, b03, & @@ -513,18 +467,16 @@ CONTAINS ! ==--------------------------------------------------------------== ! == Check on error signals == ! ==--------------------------------------------------------------== - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",1X,I5," SPECIAL POINTS GENERATED")') ntot - END IF IF (ntot == 0) THEN GOTO 710 ELSE IF (ntot < 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I5,/,A,/,A)') ' KPSYM| DIMENSION NKPOINT =', nkpoint, & - ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & - ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' - END IF - ntot = ABS(ntot) + ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & + ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' + ntot = iabs(ntot) END IF ! Before using the list WVKL as wave vectors, they have to be ! multiplied by 2*Pi @@ -533,10 +485,9 @@ CONTAINS DO i = 1, ntot iswght = iswght + lwght(i) END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(8X,A,T33,A,4X,A)') & - 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' - END IF + 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' ! Set near-zeroes equal to zero: DO l = 1, ntot DO i = 1, 3 @@ -557,20 +508,17 @@ CONTAINS END DO END IF lmax = lwght(l) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, fmt='(1X,I5,3F8.4,I8,T42,12I3)') & - l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) - END IF + l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) DO j = 13, lmax, 12 - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, fmt='(T42,12I3)') & - (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) - END IF + (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) END DO END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(24X,"TOTAL:",I8)') iswght - END IF ! ==--------------------------------------------------------------== 710 CONTINUE ! ==--------------------------------------------------------------== @@ -775,14 +723,12 @@ CONTAINS IF (iout > 0) THEN IF (li > 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(1X,A)') & - 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' - END IF + 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) - END IF END IF END SUBROUTINE group1s @@ -1354,139 +1300,138 @@ CONTAINS ! (Thierry Deutsch - 1998 [Maybe not complete!!]) IF (ihg < 6) THEN IF (nc == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC - END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSE IF (nc == 1) THEN + ELSEIF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSE IF (nc == 2 .AND. ib(2) == 25) THEN + ELSEIF (nc == 2 .AND. ib(2) == 25) THEN ! IB=125 indpg = 2 ! <1>(ci) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 4 .OR. & ! 2[001] - ib(2) == 2 .OR. & ! 2[100] - ib(2) == 3)) THEN ! 2[010] + ELSEIF (nc == 2 .AND. ( & + ib(2) == 4 .OR. & ! 2[001] + ib(2) == 2 .OR. & ! 2[100] + ib(2) == 3)) THEN ! 2[010] ! Monoclinic system ! IB=14 (z-axis) OR ! IB=12 (x-axis) OR ! IB=13 (y-axis) indpg = 3 ! 2 (c2) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 28 .OR. & - ib(2) == 26 .OR. & - ib(2) == 27)) THEN + ELSEIF (nc == 2 .AND. ( & + ib(2) == 28 .OR. & + ib(2) == 26 .OR. & + ib(2) == 27)) THEN ! IB=128 (z-axis) OR ! IB=126 (x-axis) OR ! IB=127 (y-axis) indpg = 4 ! m (c1h) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 28 .OR. & ! 2[001] - ib(4) == 27 .OR. & ! 2[010] - ib(4) == 26 .OR. & ! 2[100] - ib(4) == 37 .OR. & ! -2[-110] - ib(4) == 40)) THEN ! 2[110] + ELSEIF (nc == 4 .AND. ( & + ib(4) == 28 .OR. & ! 2[001] + ib(4) == 27 .OR. & ! 2[010] + ib(4) == 26 .OR. & ! 2[100] + ib(4) == 37 .OR. & ! -2[-110] + ib(4) == 40)) THEN ! 2[110] ! IB=1 425 28 (z-axis) OR ! IB=1 225 26 (x-axis) OR ! IB=1 325 27 (y-axis) OR ! IB=113 2537 (-xy-axis)OR ! IB=116 2540 (xy-axis) indpg = 5 ! 2/m(c2h) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 15 .OR. & - ib(4) == 20 .OR. & - ib(4) == 24)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 15 .OR. & + ib(4) == 20 .OR. & + ib(4) == 24)) THEN ! Tetragonal system ! IB=14 1415 (z-axis) OR ! IB=12 1920 (x-axis) OR ! IB=13 2224 (y-axis) indpg = 11 ! 4 (c4) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 39 .OR. & - ib(4) == 44 .OR. & - ib(4) == 48)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 39 .OR. & + ib(4) == 44 .OR. & + ib(4) == 48)) THEN ! IB=14 3839 (z-axis) OR ! IB=12 4344 (x-axis) OR ! IB=13 4648 (y-axis) indpg = 12 ! <4>(s4) - ELSE IF (nc == 8 .AND. ( & - (ib(3) == 14 .AND. ib(8) == 39) .OR. & - (ib(3) == 19 .AND. ib(8) == 44) .OR. & - (ib(3) == 22 .AND. ib(8) == 48))) THEN + ELSEIF (nc == 8 .AND. ( & + (ib(3) == 14 .AND. ib(8) == 39) .OR. & + (ib(3) == 19 .AND. ib(8) == 44) .OR. & + (ib(3) == 22 .AND. ib(8) == 48))) THEN ! IB=14 1415 2825 3839 (z-axis) OR ! IB=12 1920 2625 4344 (x-axis) OR ! IB=13 2224 2725 4648 (y-axis) indpg = 13 ! 422(d4) - ELSE IF (nc == 8 .AND. ib(4) == 4 .AND. ( & - ib(8) == 16 .OR. & - ib(8) == 20 .OR. & - ib(8) == 24)) THEN + ELSEIF (nc == 8 .AND. ib(4) == 4 .AND. ( & + ib(8) == 16 .OR. & + ib(8) == 20 .OR. & + ib(8) == 24)) THEN ! IB=12 3 413 1415 16 (z-axis) OR ! IB=12 3 417 1920 18 (x-axis) OR ! IB=12 3 421 2224 23 (y-axis) indpg = 14 ! 4/m(c4h) - ELSE IF (nc == 8 .AND. ( & - ib(8) == 40 .OR. & - ib(8) == 42 .OR. & - ib(8) == 47)) THEN + ELSEIF (nc == 8 .AND. ( & + ib(8) == 40 .OR. & + ib(8) == 42 .OR. & + ib(8) == 47)) THEN ! IB=14 1415 2627 3740 (z-axis) OR ! IB=12 1920 2827 4142 (x-axis) OR ! IB=13 2224 2628 4547 (y-axis) indpg = 15 ! 4mm(c4v) - ELSE IF (nc == 8 .AND. ( & - (ib(3) == 13 .AND. ib(8) == 39) .OR. & - (ib(3) == 17 .AND. ib(8) == 44) .OR. & - (ib(3) == 21 .AND. ib(8) == 48))) THEN + ELSEIF (nc == 8 .AND. ( & + (ib(3) == 13 .AND. ib(8) == 39) .OR. & + (ib(3) == 17 .AND. ib(8) == 44) .OR. & + (ib(3) == 21 .AND. ib(8) == 48))) THEN ! IB=14 1316 2627 3839 (z-axis) OR ! IB=12 1718 2827 4344 (x-axis) OR ! IB=13 2123 2628 4648 (y-axis) indpg = 16 ! <4>2m(d2d) - ELSE IF (nc == 16 .AND. ( & - ib(16) == 40 .OR. & - ib(16) == 44 .OR. & - ib(16) == 48)) THEN + ELSEIF (nc == 16 .AND. ( & + ib(16) == 40 .OR. & + ib(16) == 44 .OR. & + ib(16) == 48)) THEN ! IB=12 3 413 1415 1625 2627 2837 3839 40 (z-axis) OR ! IB=12 3 417 1920 1825 2627 2841 4344 42 (x-axis) OR ! IB=12 3 421 2224 2325 2627 2845 4648 47 (y-axis) indpg = 17 ! 4/mmm(d4h) - ELSE IF (nc == 4 .AND. (ib(4) == 4)) THEN + ELSEIF (nc == 4 .AND. (ib(4) == 4)) THEN ! Orthorhombic system ! IB=12 3 4 indpg = 25 ! 222(d2) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 27 .OR. & - ib(4) == 28)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 27 .OR. & + ib(4) == 28)) THEN ! IB=13 2627 (z-axis) OR ! IB=12 2728 (x-axis) OR ! IB=14 2628 (y-axis) OR indpg = 26 ! mm2(c2v) - ELSE IF (nc == 8) THEN + ELSEIF (nc == 8) THEN ! IB=12 3 425 2627 28 indpg = 27 ! mmm(d2h) - ELSE IF (nc == 12 .AND. ( & - ib(12) == 12 .OR. & - ib(12) == 47 .OR. & - ib(12) == 45)) THEN + ELSEIF (nc == 12 .AND. ( & + ib(12) == 12 .OR. & + ib(12) == 47 .OR. & + ib(12) == 45)) THEN ! Cubic system ! IB=12 3 4 5 6 7 8 910 1112 OR ! IB=15 1113 1823 2530 3537 4247 OR ! IB=18 1016 1821 2532 3440 4245 indpg = 28 ! 23 (t) - ELSE IF (nc == 24 .AND. ib(24) == 36) THEN + ELSEIF (nc == 24 .AND. ib(24) == 36) THEN ! IB= 1 2 3 4 5 6 7 8 910 1112 ! 2526 2728 2930 3132 3334 3536 indpg = 29 ! m3 (th) - ELSE IF (nc == 24 .AND. ib(24) == 24) THEN + ELSEIF (nc == 24 .AND. ib(24) == 24) THEN ! IB=12 3 45 6 78 9 1011 12 ! 1314 1516 1718 1920 2122 2324 indpg = 30 ! 432 (o) - ELSE IF (nc == 24 .AND. ib(24) == 48) THEN + ELSEIF (nc == 24 .AND. ib(24) == 48) THEN ! IB=12 3 45 6 78 9 1011 12 ! 3738 3940 4142 4345 4647 48 indpg = 31 ! <4>3m(td) - ELSE IF (nc == 48) THEN + ELSEIF (nc == 48) THEN ! IB=1..48 indpg = 32 ! m3m(oh) ELSE @@ -1496,70 +1441,69 @@ CONTAINS ! Probably a sub-group of 32 indpg = -32 END IF - ELSE IF (ihg >= 6) THEN + ELSEIF (ihg >= 6) THEN IF (nc == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC - END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSE IF (nc == 1) THEN + ELSEIF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSE IF (nc == 2 .AND. ib(2) == 13) THEN + ELSEIF (nc == 2 .AND. ib(2) == 13) THEN ! IB=113 indpg = 2 ! <1>(ci) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 4)) THEN ! 2[001] + ELSEIF (nc == 2 .AND. ( & + ib(2) == 4)) THEN ! 2[001] ! Monoclinic system ! IB=1 4 indpg = 3 ! 2 (c2) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 16)) THEN + ELSEIF (nc == 2 .AND. ( & + ib(2) == 16)) THEN ! IB=116 indpg = 4 ! m (c1h) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 24 .OR. & - ib(4) == 20)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 24 .OR. & + ib(4) == 20)) THEN ! IB=112 1324 OR ! IB=1 813 20 indpg = 5 ! 2/m(c2h) - ELSE IF (nc == 3 .AND. ib(3) == 5) THEN + ELSEIF (nc == 3 .AND. ib(3) == 5) THEN ! Trigonal system ! IB=13 5 indpg = 6 ! 3 (c3) - ELSE IF (nc == 6 .AND. ib(6) == 17) THEN + ELSEIF (nc == 6 .AND. ib(6) == 17) THEN ! IB=113 1517 35 indpg = 7 ! <3>(c3i) - ELSE IF (nc == 6 .AND. ib(6) == 11) THEN + ELSEIF (nc == 6 .AND. ib(6) == 11) THEN ! IB=17 9 1135 indpg = 8 ! 32 (d3) - ELSE IF (nc == 6 .AND. ib(6) == 23) THEN + ELSEIF (nc == 6 .AND. ib(6) == 23) THEN ! IB=13 5 1921 23 indpg = 9 ! 3m (c3v) - ELSE IF (nc == 12 .AND. ib(12) == 23) THEN + ELSEIF (nc == 12 .AND. ib(12) == 23) THEN ! IB=13 5 79 1113 1517 1921 23 indpg = 10 ! <3>m(d3d) - ELSE IF (nc == 6 .AND. ib(6) == 6) THEN + ELSEIF (nc == 6 .AND. ib(6) == 6) THEN ! Hexagonal system ! IB=12 3 45 6 indpg = 18 ! 6 (c6) - ELSE IF (nc == 6 .AND. ib(6) == 18) THEN + ELSEIF (nc == 6 .AND. ib(6) == 18) THEN ! IB=13 5 1416 18 indpg = 19 ! <6>(c3h) - ELSE IF (nc == 12 .AND. ib(12) == 18) THEN + ELSEIF (nc == 12 .AND. ib(12) == 18) THEN ! IB=12 3 45 6 1314 1516 1718 indpg = 20 ! 6/m(c6h) - ELSE IF (nc == 12 .AND. ib(12) == 12) THEN + ELSEIF (nc == 12 .AND. ib(12) == 12) THEN ! IB=12 3 45 6 78 9 1011 12 indpg = 21 ! 622(d6) - ELSE IF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN + ELSEIF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN ! IB=12 3 45 6 1920 2122 2324 indpg = 22 ! 6mm(c6v) - ELSE IF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN + ELSEIF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN ! IB=13 5 79 1114 1618 2022 24 indpg = 23 ! <6>m2(d3h) - ELSE IF (nc == 24) THEN + ELSEIF (nc == 24) THEN ! IB=1..24 indpg = 24 ! 6/mmm(d6h) ELSE @@ -1596,7 +1540,7 @@ CONTAINS xb(i) = a(i, 1)*origin(1) + a(i, 2)*origin(2) + a(i, 3)*origin(3) END DO isy = -1 - ELSE IF (info == 0) THEN + ELSEIF (info == 0) THEN isy = 0 ELSE isy = -2 @@ -1610,98 +1554,83 @@ CONTAINS ! == Output == ! ==--------------------------------------------------------------== IF (iout > 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) - END IF CALL xstring(icst(ihg), i, j) IF ((ihg == 7 .AND. nc == 24) .OR. & (ihg == 5 .AND. nc == 48)) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A,A)') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & - icst(ihg) (i:j), & - ' GROUP' - END IF + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & + icst(ihg) (i:j), & + ' GROUP' ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A,A,I2,A)') & - ' KPSYM| THE CRYSTAL SYSTEM IS ', & - icst(ihg) (i:j), & - ' WITH ', nc, ' OPERATIONS:' - END IF + ' KPSYM| THE CRYSTAL SYSTEM IS ', & + icst(ihg) (i:j), & + ' WITH ', nc, ' OPERATIONS:' IF (ihc == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '( 5(5(A13),/))') (rname_hexai(ib(i)), i=1, nc) - END IF ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(10(5(A13),/))') (rname_cubic(ib(i)), i=1, nc) - END IF END IF END IF ! ==------------------------------------------------------------== IF (isy == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - END IF - ELSE IF (isy == -1) THEN - IF (iout > 0) THEN + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + ELSEIF (isy == -1) THEN + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - END IF - IF (iout > 0) THEN + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + IF (iout > 0) & WRITE (iout, '(A,A,/,T3,3F10.6,3X,3F10.6)') & - ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & - '[CARTESIAN] [CRYSTAL]', xb, origin - END IF - ELSE IF (isy == 0) THEN - IF (iout > 0) THEN + ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & + '[CARTESIAN] [CRYSTAL]', xb, origin + ELSEIF (isy == 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' (SUM OF TRANSLATION VECTORS=', vs, ')' - END IF - ELSE IF (isy == -2) THEN - IF (iout > 0) THEN + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' (SUM OF TRANSLATION VECTORS=', vs, ')' + ELSEIF (isy == -2) THEN + IF (iout > 0) & WRITE (iout, '(A,A)') & - ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & - ' SYMMORPHIC OR NOT' - END IF - IF (iout > 0) THEN + ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & + ' SYMMORPHIC OR NOT' + IF (iout > 0) & WRITE (iout, '(A,/,A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & - ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' - END IF + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & + ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' END IF IF (indpg > 0) THEN CALL xstring(pgrp(indpg), i, j) CALL xstring(pgrd(indpg), k, l) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & - pgrd(indpg) (k:l), indpg - END IF + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & + pgrd(indpg) (k:l), indpg ELSE CALL xstring(pgrp(-indpg), i, j) CALL xstring(pgrd(-indpg), k, l) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I2,A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & - ' SUBGROUP OF ', pgrp(-indpg) (i:j), & - pgrd(-indpg) (k:l), -indpg - END IF + ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & + ' SUBGROUP OF ', pgrp(-indpg) (i:j), & + pgrd(-indpg) (k:l), -indpg END IF IF (ntvec == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec - END IF + ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec - END IF + ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec END IF END IF @@ -2474,12 +2403,11 @@ CONTAINS 280 CONTINUE END DO END DO - IF (iremov > 0 .AND. iout > 0) THEN + IF (iremov > 0 .AND. iout > 0) & WRITE (iout, '(A,A,/,A,1X,I6,A,/)') & - ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & - 'TRANSLATION VECTORS', & - ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' - END IF + ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & + 'TRANSLATION VECTORS', & + ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' END IF ! ==--------------------------------------------------------------== ! == IN THE MESH OF WAVEVECTORS, NOW SEARCH FOR EQUIVALENT POINTS:== @@ -2572,72 +2500,59 @@ CONTAINS ! == THE LIST OF WEIGHTS LWGHT IS NOT NORMALIZED == ! ==--------------------------------------------------------------== IF (ntot > nkpoint) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) 'IN SPPT2 NUMBER OF SPECIAL POINTS = ', ntot - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) 'BUT NKPOINT = ', nkpoint - END IF ntot = -1 END IF IF (iout > 0) THEN ! Write the index table relating k points in the mesh ! with special k points - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/,A,4X,A)') & - ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' - END IF - IF (iout > 0) THEN + ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' + IF (iout > 0) & WRITE (iout, '(5(4X,"IK -> SK"))') - END IF DO i = 1, imesh iplace = includ(i)/2 - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(1X,I5,1X,I5)', advance="no") i, iplace - END IF - IF ((MOD(i, 5) == 0) .AND. iout > 0) THEN + IF ((MOD(i, 5) == 0) .AND. iout > 0) & WRITE (iout, *) - END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & WRITE (iout, *) - END IF END IF RETURN ! ==--------------------------------------------------------------== ! == ERROR MESSAGES == ! ==--------------------------------------------------------------== 450 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' - END IF + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' CALL stopgm('SPPT2', 'VECTOR OUTSIDE THE 1BZ') ! ==--------------------------------------------------------------== 470 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) 'MESH SIZE EXCEEDS NKPOINT=', nkpoint - END IF CALL stopgm('SPPT2', 'MESH SIZE EXCEEDED') ! ==--------------------------------------------------------------== 490 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' - END IF + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' CALL stopgm('SPPT2', 'VECTOR NOT IN THE LIST') ! ==--------------------------------------------------------------== RETURN @@ -2700,7 +2615,7 @@ CONTAINS igarbg = 0 RETURN ! ==--------------------------------------------------------------== - ELSE IF ((iplace > -2) .AND. (iplace <= 0)) THEN + ELSEIF ((iplace > -2) .AND. (iplace <= 0)) THEN ! The particular HASH function used in this case: rhash = 0.7890_dp*wvk(1) & + 0.6810_dp*wvk(2) & @@ -2724,11 +2639,10 @@ CONTAINS ipoint = list(ihash) END DO ! List too long - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(2A,/,A)') & - ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & - ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' - END IF + ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & + ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' CALL stopgm('MESH', 'WARNING') ! WVK was not found 130 CONTINUE @@ -2740,14 +2654,12 @@ CONTAINS ! IPLACE=0: add WVK to the list list(ihash) = istore IF (istore > nmesh) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I10,A,/,A,3F10.5)') & - ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & - ' WVK = ', wvk - END IF + ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & + ' WVK = ', wvk CALL stopgm('MESH', 'WARNING') END IF list(istore) = nil @@ -2779,12 +2691,11 @@ CONTAINS ! == Error - beyond list == ! ==--------------------------------------------------------------== 190 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,A,I5,A,/)') & - ' SUBROUTINE MESH *** WARNING ***', & - ' IPLACE = ', iplace, & - ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' - END IF + ' SUBROUTINE MESH *** WARNING ***', & + ' IPLACE = ', iplace, & + ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' DO i = 1, 3 wvk(i) = 1.0e38_dp END DO diff --git a/src/libint_2c_3c.F b/src/libint_2c_3c.F index 1fa20a7fd6..e7698ae20d 100644 --- a/src/libint_2c_3c.F +++ b/src/libint_2c_3c.F @@ -147,7 +147,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op == do_potential_coulomb) THEN + ELSEIF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -515,7 +515,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op == do_potential_coulomb) THEN + ELSEIF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -885,7 +885,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF @@ -1135,7 +1135,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF diff --git a/src/libint_wrapper.F b/src/libint_wrapper.F index 93e9f7b84c..edebee3a87 100644 --- a/src/libint_wrapper.F +++ b/src/libint_wrapper.F @@ -120,10 +120,9 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) THEN + IF (${m_max}$ <= m_max) & libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & - = F(${m_max}$+1) - END IF + = F(${m_max}$+1) #endif #:endfor @@ -216,10 +215,9 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) THEN + IF (${m_max}$ <= m_max) & libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) - END IF + = F(${m_max}$+1) #endif #:endfor @@ -289,10 +287,9 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) THEN + IF (${m_max}$ <= m_max) & libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) - END IF + = F(${m_max}$+1) #endif #:endfor diff --git a/src/library_tests.F b/src/library_tests.F index 0c64f82e17..b1f2cbd5b5 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -287,7 +287,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env INTEGER :: iw - INTEGER :: i, j, len, ntim, siz + INTEGER :: i, ierr, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ca, cb @@ -298,8 +298,10 @@ CONTAINS DO i = 6, 24 len = 2**i IF (8.0_dp*REAL(len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ca(len)) - ALLOCATE (cb(len)) + ALLOCATE (ca(len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (cb(len), STAT=ierr) + IF (ierr /= 0) EXIT CALL RANDOM_NUMBER(ca) ntim = NINT(1.e7_dp/REAL(len, KIND=dp)) @@ -346,7 +348,7 @@ CONTAINS LOGICAL :: test_matmul, test_dgemm INTEGER :: iw - INTEGER :: i, j, len, ntim, siz + INTEGER :: i, ierr, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart, xdum REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: ma, mb, mc @@ -358,9 +360,12 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len)) - ALLOCATE (mb(len, len)) - ALLOCATE (mc(len, len)) + ALLOCATE (ma(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mb(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mc(len, len), STAT=ierr) + IF (ierr /= 0) EXIT mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -449,9 +454,12 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len)) - ALLOCATE (mb(len, len)) - ALLOCATE (mc(len, len)) + ALLOCATE (ma(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mb(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mc(len, len), STAT=ierr) + IF (ierr /= 0) EXIT mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -558,8 +566,8 @@ CONTAINS INTEGER, PARAMETER :: ndate(3) = [12, 48, 96] - INTEGER :: iall, it, j, len, n(3), ntim, radix_in, & - radix_out, siz, stat + INTEGER :: iall, ierr, it, j, len, n(3), ntim, & + radix_in, radix_out, siz, stat COMPLEX(KIND=dp), DIMENSION(4, 4, 4) :: zz COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: ca, cb, cc CHARACTER(LEN=7) :: method @@ -597,8 +605,8 @@ CONTAINS len = radix_out n = len IF (16.0_dp*REAL(len*len*len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ra(len, len, len)) - ALLOCATE (ca(len, len, len)) + ALLOCATE (ra(len, len, len), STAT=ierr) + ALLOCATE (ca(len, len, len), STAT=ierr) CALL RANDOM_NUMBER(ra) ca(:, :, :) = ra CALL RANDOM_NUMBER(ra) @@ -644,29 +652,25 @@ CONTAINS CALL fft3d(FWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is changed in out-of-place FFT !" - END IF + " Input array is changed in out-of-place FFT !" ELSE - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is not changed in out-of-place FFT !" - END IF + " Input array is not changed in out-of-place FFT !" END IF ca(:, :, :) = cc CALL fft3d(BWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is changed in out-of-place FFT !" - END IF + " Input array is changed in out-of-place FFT !" ELSE - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is not changed in out-of-place FFT !" - END IF + " Input array is not changed in out-of-place FFT !" END IF IF (para_env%is_source()) WRITE (iw, *) diff --git a/src/linesearch.F b/src/linesearch.F index 8948e11682..3d9977d78f 100644 --- a/src/linesearch.F +++ b/src/linesearch.F @@ -610,9 +610,8 @@ CONTAINS is_done = .FALSE. - IF (this%gave_up) THEN + IF (this%gave_up) & CPABORT("had to give up, should not be called again") - END IF IF (.NOT. this%have_left) THEN this%left_x = 0.0_dp @@ -686,9 +685,8 @@ CONTAINS IF (this%have_left .AND. this%have_middle .AND. this%have_right) THEN a = this%middle_x - this%left_x b = this%right_x - this%middle_x - IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) THEN + IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) & CPABORT("golden-ratio gone") - END IF IF (a < b) THEN step_size = this%middle_x + a/phi diff --git a/src/local_gemm_api.F b/src/local_gemm_api.F index e45895578f..7812c45cc1 100644 --- a/src/local_gemm_api.F +++ b/src/local_gemm_api.F @@ -8,7 +8,6 @@ MODULE local_gemm_api USE ISO_C_BINDING, ONLY: C_NULL_PTR, & C_PTR - USE kinds, ONLY: dp #if defined(__SPLA) && defined(__OFFLOAD_GEMM) USE input_constants, ONLY: do_dgemm_spla USE ISO_C_BINDING, ONLY: C_ASSOCIATED, & @@ -84,25 +83,25 @@ CONTAINS INTEGER, INTENT(in) :: m INTEGER, INTENT(in) :: n INTEGER, INTENT(in) :: k - REAL(KIND=dp), INTENT(in) :: alpha + REAL(8), INTENT(in) :: alpha #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: A + REAL(8), DIMENSION(*), INTENT(in), TARGET :: A #else - REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: A + REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: A #endif INTEGER, INTENT(in) :: lda #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: B + REAL(8), DIMENSION(*), INTENT(in), TARGET :: B #else - REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: B + REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: B #endif INTEGER, INTENT(in) :: ldb - REAL(KIND=dp), INTENT(in) :: beta + REAL(8), INTENT(in) :: beta #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(KIND=dp), DIMENSION(*), INTENT(inout), TARGET ::C + REAL(8), DIMENSION(*), INTENT(inout), TARGET ::C #else - REAL(KIND=dp), DIMENSION(:, :), INTENT(inout), TARGET :: C + REAL(8), DIMENSION(:, :), INTENT(inout), TARGET :: C #endif INTEGER, INTENT(in) :: ldc CLASS(local_gemm_ctxt_type), INTENT(inout) :: ctx diff --git a/src/localization_tb.F b/src/localization_tb.F index 866e1d491f..417e0fa0f7 100644 --- a/src/localization_tb.F +++ b/src/localization_tb.F @@ -147,7 +147,7 @@ CONTAINS IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSE IF (dft_control%restricted) THEN + ELSEIF (dft_control%restricted) THEN IF (iounit > 0) WRITE (iounit, *) & " Unclear how we define MOs / localization in the restricted case ... skipping" ELSE diff --git a/src/localized_moments.F b/src/localized_moments.F index 6a82b95e68..7f6782fb0e 100644 --- a/src/localized_moments.F +++ b/src/localized_moments.F @@ -737,10 +737,9 @@ CONTAINS DO idir = 1, 3 CALL dbcsr_get_readonly_block_p(moments_der(i, idir)%matrix, & iatom, jatom, oblock, found) - IF (found) THEN + IF (found) & qupole_der((i - 1)*3 + idir) = & - qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) - END IF + qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) END DO END DO END IF diff --git a/src/lri_optimize_ri_basis_types.F b/src/lri_optimize_ri_basis_types.F index 4a79d3914a..41bf462a06 100644 --- a/src/lri_optimize_ri_basis_types.F +++ b/src/lri_optimize_ri_basis_types.F @@ -227,7 +227,8 @@ CONTAINS END DO DO ishell = 1, gto_basis_set%nshell(iset) - gcc(:, ishell, iset) = gcc(:, ishell, iset)/NORM2(gcc(:, ishell, iset)) + gcc(:, ishell, iset) = gcc(:, ishell, iset)/ & + SQRT(DOT_PRODUCT(gcc(:, ishell, iset), gcc(:, ishell, iset))) END DO END DO diff --git a/src/manybody_eam.F b/src/manybody_eam.F index 38cc5ba35b..0819359be8 100644 --- a/src/manybody_eam.F +++ b/src/manybody_eam.F @@ -186,7 +186,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) @@ -196,7 +196,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -233,7 +233,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -247,7 +247,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) diff --git a/src/manybody_gal.F b/src/manybody_gal.F index cb57bcddd6..8c72d24322 100644 --- a/src/manybody_gal.F +++ b/src/manybody_gal.F @@ -81,8 +81,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair - !Vector in pbc from j to i - rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) + rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) !Vector in pbc from j to i IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only ALLOCATE (gal%n_vectors(3, SIZE(particle_set))) @@ -99,8 +98,7 @@ CONTAINS Vang = 0.0_dp IF (gcn_weight2 /= 0.0) THEN - ! Calculation of the normal vector centered on the Me atom of the pair, only the first time - ! that an interaction with the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -108,14 +106,13 @@ CONTAINS particle_set, cell) END IF - !Else, retrive it, should not have moved sinc metal is supposed to be frozen - nvec(:) = gal%n_vectors(:, jparticle) + nvec(:) = gal%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-NORM2(rji)/gal%r1) + weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = angular(gal, r_last_update_pbc, iparticle, cell, particle_set, nvec, & @@ -226,13 +223,12 @@ CONTAINS IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) drjk2 = DOT_PRODUCT(rjk, rjk) - !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair - IF (drjk2 > gal%rcutsq) CYCLE + IF (drjk2 > gal%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair normale(:) = normale(:) - rjk(:) !Build the normal, vector by vector END DO ! Normalisation of the vector - normale(:) = normale(:)/NORM2(normale) + normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) END FUNCTION normale @@ -268,11 +264,9 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal%rcutsq) CYCLE - !Build the sum of the exponential weights - IF (element_symbol_k == gal%met1) somme = somme + EXP(-NORM2(rki)/gal%r1) - IF (element_symbol_k == gal%met2) somme = somme + EXP(-NORM2(rki)/gal%r2) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (element_symbol_k == gal%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r1) !Build the sum of the exponential weights + IF (element_symbol_k == gal%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r2) !Build the sum of the exponential weights END DO END FUNCTION somme @@ -323,11 +317,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -341,7 +335,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -396,7 +390,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only @@ -413,8 +407,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IF (gcn_weight2 /= 0.0) THEN - ! Calculation of the normal vector centered on the Me atom of the pair, only the first time - ! that an interaction with the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -531,7 +524,7 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-NORM2(rji)/gal%r1) + weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system @@ -539,13 +532,11 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal%rcutsq) CYCLE - drki = NORM2(rki) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + drki = SQRT(DOT_PRODUCT(rki, rki)) rki_hat(:) = rki(:)/drki - !Build the sum of derivativs - IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) + IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) !Build the sum of derivativs IF (element_symbol_k == gal%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r2)*EXP(-drki/gal%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -596,11 +587,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -612,15 +603,14 @@ CONTAINS END IF rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector - ! Theta is the angle between the normal to the surface and the dipole - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) + rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -628,7 +618,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*gal%a1*SIN(theta) - gal%a2*2.0_dp*SIN(2.0_dp*theta) - & gal%a3*3.0_dp*SIN(3.0_dp*theta) - gal%a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term diff --git a/src/manybody_gal21.F b/src/manybody_gal21.F index 7604fe379c..c31ac17f5c 100644 --- a/src/manybody_gal21.F +++ b/src/manybody_gal21.F @@ -105,8 +105,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Vang = 0.0_dp - ! Calculation of the normal vector centered on the Me atom of the pair, - ! only the first time that an interaction with the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -114,14 +113,13 @@ CONTAINS particle_set, cell) END IF - ! Else, retrive it, should not have moved sinc metal is supposed to be frozen - nvec(:) = gal21%n_vectors(:, jparticle) + nvec(:) = gal21%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal21, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-NORM2(rji)/gal21%r1) + weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = 0.0_dp @@ -231,18 +229,15 @@ CONTAINS IF (kparticle == jparticle) CYCLE !Avoid the principal Me atom (j) in the counting CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - !Keep only metals - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) - drjk = NORM2(rjk) - !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair - IF (drjk > gal21%rcutsq) CYCLE - !Build the normal, vector by vector - normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) + drjk = SQRT(DOT_PRODUCT(rjk, rjk)) + IF (drjk > gal21%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) !Build the normal, vector by vector END DO ! Normalisation of the vector - normale(:) = normale(:)/NORM2(normale) + normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) END FUNCTION normale @@ -274,14 +269,11 @@ CONTAINS DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - !Keep only metals - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal21%rcutsq) CYCLE - !Build the sum of the exponential weights - IF (element_symbol_k == gal21%met1) somme = somme + EXP(-NORM2(rki)/gal21%r1) - IF (element_symbol_k == gal21%met2) somme = somme + EXP(-NORM2(rki)/gal21%r2) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (element_symbol_k == gal21%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r1) !Build the sum of the exponential weights + IF (element_symbol_k == gal21%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r2) !Build the sum of the exponential weights END DO END FUNCTION somme @@ -333,11 +325,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -356,7 +348,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -367,7 +359,8 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) - VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*NORM2(rjh1)) + EXP(-BH*NORM2(rjh2))) + VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & + EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) ! For fit purpose IF (gal21%express .AND. energy) THEN @@ -377,8 +370,9 @@ CONTAINS IF (index_outfile > 0) WRITE (index_outfile, *) "Fourier", costheta, COS(2.0_dp*theta), COS(3.0_dp*theta), & COS(4.0_dp*theta) !, theta - IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*NORM2(rjh1)) + & - EXP(-BH*NORM2(rjh2)) + IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & + EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2))) + !IF (index_outfile > 0) WRITE (index_outfile, *) "H_r6", -1/DOT_PRODUCT(rjh1,rjh1)**3 -1/DOT_PRODUCT(rjh2,rjh2)**3 CALL cp_print_key_finished_output(index_outfile, logger, mm_section, & "PRINT%PROGRAM_RUN_INFO") @@ -421,7 +415,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal21%n_vectors)) THEN !First calling of the forcefield only @@ -436,8 +430,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with - ! the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -573,22 +566,19 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-NORM2(rji)/gal21%r1) + weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - !Keep only metals - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal21%rcutsq) CYCLE - drki = NORM2(rki) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + drki = SQRT(DOT_PRODUCT(rki, rki)) rki_hat(:) = rki(:)/drki - !Build the sum of derivativs - IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) + IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) !Build the sum of derivativs IF (element_symbol_k == gal21%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r2)*EXP(-drki/gal21%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -651,11 +641,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -672,14 +662,14 @@ CONTAINS a4 = gal21%a41 + gal21%a42*gal21%gcn(jparticle) + gal21%a43*gal21%gcn(jparticle)*gal21%gcn(jparticle) rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) ! Theta is the angle between the normal to the surface and the dipole + rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -687,7 +677,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*a1*SIN(theta) - a2*2.0_dp*SIN(2.0_dp*theta) - & a3*3.0_dp*SIN(3.0_dp*theta) - a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term @@ -705,35 +695,35 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) f_nonbond(1:3, index_h1) = f_nonbond(1:3, index_h1) + (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))*rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))*rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh1(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))) & - *rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & + *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh1(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))) & - *rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & + *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh1(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))) & - *rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & + *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) END IF rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) f_nonbond(1:3, index_h2) = f_nonbond(1:3, index_h2) + ((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh2(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh2(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh2(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) END IF END SUBROUTINE angular_d diff --git a/src/manybody_e3nn.F b/src/manybody_nequip.F similarity index 94% rename from src/manybody_e3nn.F rename to src/manybody_nequip.F index 58e5dc64c6..adff300a10 100644 --- a/src/manybody_e3nn.F +++ b/src/manybody_nequip.F @@ -6,16 +6,13 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** -!> \brief Shared TorchScript evaluation path for e3nn-based equivariant message-passing -!> potentials (NequIP, Allegro and MACE). !> \par History !> Implementation of NequIP and Allegro potentials - [gtocci] 2022 !> Index mapping of atoms from .xyz to Allegro config.yaml file - [mbilichenko] 2024 !> Refactoring and update to NequIP version >= v0.7.0 - [gtocci] 2026 -!> Renamed manybody_nequip -> manybody_e3nn as it now also serves MACE - [xysun] 2026 !> \author Gabriele Tocci ! ************************************************************************************************** -MODULE manybody_e3nn +MODULE manybody_nequip USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type @@ -31,8 +28,7 @@ MODULE manybody_e3nn dp,& int_8 USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: mace_type,& - nequip_pot_type,& + USE pair_potential_types, ONLY: nequip_pot_type,& nequip_type,& pair_potential_pp_type,& pair_potential_single_type @@ -47,10 +43,10 @@ MODULE manybody_e3nn IMPLICIT NONE PRIVATE - PUBLIC :: e3nn_energy_store_force_virial, & - e3nn_add_force_virial + PUBLIC :: nequip_energy_store_force_virial, & + nequip_add_force_virial - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_e3nn' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_nequip' TYPE, PRIVATE :: nequip_work_type INTEGER :: target_pot_type @@ -93,10 +89,10 @@ CONTAINS !> Refactoring and unifying NequIP and Allegro - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_total, fist_nonbond_env, para_env, use_virial, & - target_pot_type) + SUBROUTINE nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_total, fist_nonbond_env, para_env, use_virial, & + target_pot_type) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), POINTER :: particle_set(:) @@ -111,7 +107,7 @@ CONTAINS LOGICAL, INTENT(IN) :: use_virial INTEGER, INTENT(IN) :: target_pot_type - CHARACTER(LEN=*), PARAMETER :: routineN = 'e3nn_energy_store_force_virial' + CHARACTER(LEN=*), PARAMETER :: routineN = 'nequip_energy_store_force_virial' INTEGER :: handle TYPE(nequip_data_type), POINTER :: neq_data @@ -136,8 +132,7 @@ CONTAINS CALL setup_neq_data(fist_nonbond_env, neq_data, neq_pot, nequip_work) - IF (nequip_work%target_pot_type == nequip_type .OR. & - nequip_work%target_pot_type == mace_type) THEN + IF (nequip_work%target_pot_type == nequip_type) THEN CALL prepare_edges_shifts_nequip(nequip_work) ELSE CALL prepare_edges_shifts_allegro(nequip_work) @@ -151,7 +146,7 @@ CONTAINS CALL release_nequip_work(nequip_work) CALL timestop(handle) - END SUBROUTINE e3nn_energy_store_force_virial + END SUBROUTINE nequip_energy_store_force_virial ! ************************************************************************************************** !> \brief ... @@ -473,9 +468,8 @@ CONTAINS END IF IF (ASSOCIATED(neq_data%force)) THEN - IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) THEN + IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) & DEALLOCATE (neq_data%force, neq_data%use_indices) - END IF END IF IF (.NOT. ASSOCIATED(neq_data%force)) THEN @@ -569,8 +563,7 @@ CONTAINS n_atoms = SIZE(nequip_work%particle_set) ! for allegro ensure ghost atoms are included in the evaluation - IF (nequip_work%target_pot_type /= nequip_type .AND. & - nequip_work%target_pot_type /= mace_type) THEN + IF (nequip_work%target_pot_type /= nequip_type) THEN ! label atoms in the local edges DO i = 1, SIZE(nequip_work%local_edges, 2) atom_a = INT(nequip_work%local_edges(1, i)) @@ -714,8 +707,7 @@ CONTAINS DO iat_use = 1, SIZE(neq_data%use_indices) iat = neq_data%use_indices(iat_use) ! Only apply the local mask for Allegro models - IF (nequip_work%target_pot_type /= nequip_type .AND. & - nequip_work%target_pot_type /= mace_type) THEN + IF (nequip_work%target_pot_type /= nequip_type) THEN IF (.NOT. nequip_work%sum_energy(iat)) CYCLE END IF @@ -724,8 +716,7 @@ CONTAINS CALL torch_tensor_release(t_energy) pot_total = pot_total*pot%unit_energy_val - IF (nequip_work%target_pot_type == nequip_type .OR. & - nequip_work%target_pot_type == mace_type) THEN + IF (nequip_work%target_pot_type == nequip_type) THEN neq_data%force = neq_data%force/REAL(nequip_work%para_env%num_pe, dp) pot_total = pot_total/REAL(nequip_work%para_env%num_pe, dp) END IF @@ -736,8 +727,7 @@ CONTAINS neq_data%virial(:, :) = RESHAPE(v_ptr, [3, 3])*pot%unit_energy_val CALL torch_tensor_release(t_virial) - IF (nequip_work%target_pot_type == nequip_type .OR. & - nequip_work%target_pot_type == mace_type) THEN + IF (nequip_work%target_pot_type == nequip_type) THEN neq_data%virial = neq_data%virial/REAL(nequip_work%para_env%num_pe, dp) END IF END IF @@ -754,7 +744,7 @@ CONTAINS !> Sum forces, virial to nonbond - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + SUBROUTINE nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: f_nonbond, pv_nonbond LOGICAL, INTENT(IN) :: use_virial @@ -773,6 +763,6 @@ CONTAINS f_nonbond(1:3, iat) = f_nonbond(1:3, iat) + neq_data%force(1:3, iat_use) END DO - END SUBROUTINE e3nn_add_force_virial + END SUBROUTINE nequip_add_force_virial -END MODULE manybody_e3nn +END MODULE manybody_nequip diff --git a/src/manybody_potential.F b/src/manybody_potential.F index a3a706a7f1..16b5faec93 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -30,8 +30,6 @@ MODULE manybody_potential ace_energy_store_force_virial USE manybody_deepmd, ONLY: deepmd_add_force_virial,& deepmd_energy_store_force_virial - USE manybody_e3nn, ONLY: e3nn_add_force_virial,& - e3nn_energy_store_force_virial USE manybody_eam, ONLY: get_force_eam USE manybody_gal, ONLY: destroy_gal_arrays,& gal_energy,& @@ -41,6 +39,8 @@ MODULE manybody_potential gal21_energy,& gal21_forces,& setup_gal21_arrays + USE manybody_nequip, ONLY: nequip_add_force_virial,& + nequip_energy_store_force_virial USE manybody_siepmann, ONLY: destroy_siepmann_arrays,& print_nr_ions_siepmann,& setup_siepmann_arrays,& @@ -54,9 +54,8 @@ MODULE manybody_potential USE message_passing, ONLY: mp_para_env_type USE pair_potential_types, ONLY: & ace_type, allegro_type, deepmd_type, ea_type, eam_pot_type, gal21_pot_type, gal21_type, & - gal_pot_type, gal_type, mace_type, nequip_type, pair_potential_pp_type, & - pair_potential_single_type, siepmann_pot_type, siepmann_type, tersoff_pot_type, & - tersoff_type + gal_pot_type, gal_type, nequip_type, pair_potential_pp_type, pair_potential_single_type, & + siepmann_pot_type, siepmann_type, tersoff_pot_type, tersoff_type USE particle_types, ONLY: particle_type USE util, ONLY: sort #include "./base/base_uses.f90" @@ -106,11 +105,11 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_mace, & - any_nequip, any_siepmann, any_tersoff + any_gal, any_gal21, any_nequip, & + any_siepmann, any_tersoff REAL(KIND=dp) :: drij, embed, pot_ace, pot_allegro, & - pot_deepmd, pot_loc, pot_mace, & - pot_nequip, qr, rab2_max, rij(3) + pot_deepmd, pot_loc, pot_nequip, qr, & + rab2_max, rij(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v REAL(KIND=dp), POINTER :: fembed(:) @@ -133,7 +132,6 @@ CONTAINS any_gal21 = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. - any_mace = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. CALL timeset(routineN, handle) @@ -179,7 +177,6 @@ CONTAINS pot => potparm%pot(ikind, jkind)%pot any_tersoff = any_tersoff .OR. ANY(pot%type == tersoff_type) any_nequip = any_nequip .OR. ANY(pot%type == nequip_type) - any_mace = any_mace .OR. ANY(pot%type == mace_type) any_ace = any_ace .OR. ANY(pot%type == ace_type) any_allegro = any_allegro .OR. ANY(pot%type == allegro_type) any_deepmd = any_deepmd .OR. ANY(pot%type == deepmd_type) @@ -192,30 +189,21 @@ CONTAINS ! NEQUIP IF (any_nequip) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_nequip, fist_nonbond_env, & - para_env, use_virial, nequip_type) + CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_nequip, fist_nonbond_env, & + para_env, use_virial, nequip_type) pot_manybody = pot_manybody + pot_nequip END IF ! ALLEGRO IF (any_allegro) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_allegro, fist_nonbond_env, & - para_env, use_virial, allegro_type) + CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_allegro, fist_nonbond_env, & + para_env, use_virial, allegro_type) pot_manybody = pot_manybody + pot_allegro END IF - ! MACE (reuses the NequIP message-passing evaluation path) - IF (any_mace) THEN - NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_mace, fist_nonbond_env, & - para_env, use_virial, mace_type) - pot_manybody = pot_manybody + pot_mace - END IF ! ACE IF (any_ace) THEN CALL ace_energy_store_force_virial(particle_set, cell, atomic_kind_set, potparm, & @@ -590,8 +578,8 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_mace, & - any_nequip, any_siepmann, any_tersoff + any_gal, any_gal21, any_nequip, & + any_siepmann, any_tersoff REAL(KIND=dp) :: f_eam, fac, fr(3), ptens11, ptens12, ptens13, ptens21, ptens22, ptens23, & ptens31, ptens32, ptens33, rab(3), rab2, rab2_max, rtmp(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi @@ -611,7 +599,6 @@ CONTAINS any_tersoff = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. - any_mace = .FALSE. any_siepmann = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. @@ -652,9 +639,8 @@ CONTAINS END DO END DO ! ACE - IF (any_ace) THEN + IF (any_ace) & CALL ace_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) - END IF DO ikind = 1, nkinds DO jkind = ikind, nkinds @@ -662,9 +648,8 @@ CONTAINS END DO END DO ! DEEPMD - IF (any_deepmd) THEN + IF (any_deepmd) & CALL deepmd_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) - END IF ! NEQUIP DO ikind = 1, nkinds @@ -673,7 +658,7 @@ CONTAINS END DO END DO IF (any_nequip) THEN - CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! ALLEGRO @@ -683,17 +668,7 @@ CONTAINS END DO END DO IF (any_allegro) THEN - CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) - END IF - - ! MACE (reuses the NequIP force/virial accumulation) - DO ikind = 1, nkinds - DO jkind = ikind, nkinds - any_mace = any_mace .OR. ANY(potparm%pot(ikind, jkind)%pot%type == mace_type) - END DO - END DO - IF (any_mace) THEN - CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! starting the force loop diff --git a/src/manybody_siepmann.F b/src/manybody_siepmann.F index 09e29c1ef7..42c619b843 100644 --- a/src/manybody_siepmann.F +++ b/src/manybody_siepmann.F @@ -185,7 +185,7 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) IF (kparticle == jparticle) CYCLE @@ -243,7 +243,7 @@ CONTAINS F = siepmann%F rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji nparticle = SIZE(r_last_update_pbc) @@ -339,19 +339,19 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) DO iatom = 1, natom CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = NORM2(rih) + drih = SQRT(DOT_PRODUCT(rih, rih)) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -363,21 +363,21 @@ CONTAINS ELSE CPABORT("No H atoms for O found") END IF - ELSE IF (count_h == 1) THEN + ELSEIF (count_h == 1) THEN IF (siepmann%allow_oh_formation) THEN IF (PRESENT(nr_oh)) nr_oh = nr_oh + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Only one H atom of O atom found") END IF - ELSE IF (count_h == 3) THEN + ELSEIF (count_h == 3) THEN IF (siepmann%allow_h3o_formation) THEN IF (PRESENT(nr_h3o)) nr_h3o = nr_h3o + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Three H atoms for O atom found") END IF - ELSE IF (count_h > 3) THEN + ELSEIF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -386,7 +386,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = NORM2(rix) + drix = SQRT(DOT_PRODUCT(rix, rix)) cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp IF (cosphi > +1.0_dp) cosphi = +1.0_dp @@ -441,7 +441,7 @@ CONTAINS cell_v, cell, rcutsq, & particle_set) rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji DO iatom = 1, natom @@ -449,23 +449,23 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = NORM2(rih) + drih = SQRT(DOT_PRODUCT(rih, rih)) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO IF (count_h == 0 .AND. .NOT. siepmann%allow_o_formation) THEN CPABORT("No H atoms for O found") - ELSE IF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN + ELSEIF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN CPABORT("Only one H atom for O atom found") - ELSE IF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN + ELSEIF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN CPABORT("Three H atoms for O atom found") - ELSE IF (count_h > 3) THEN + ELSEIF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -474,7 +474,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = NORM2(rix) + drix = SQRT(DOT_PRODUCT(rix, rix)) rix_hat(:) = rix(:)/drix cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp @@ -561,7 +561,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji fac = -1.0_dp !gradient to force @@ -646,7 +646,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) fac = -1.0_dp Phi_ij = siep_Phi_ij(siepmann, r_last_update_pbc, iparticle, jparticle, & diff --git a/src/manybody_tersoff.F b/src/manybody_tersoff.F index 719e662a37..9f86baecab 100644 --- a/src/manybody_tersoff.F +++ b/src/manybody_tersoff.F @@ -346,7 +346,7 @@ CONTAINS lambda3 = tersoff%lambda3 rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = NORM2(rij) + drij = SQRT(DOT_PRODUCT(rij, rij)) ter_zeta_ij = 0.0_dp DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) @@ -413,7 +413,7 @@ CONTAINS rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = NORM2(rij) + drij = SQRT(DOT_PRODUCT(rij, rij)) rij_hat(:) = rij(:)/drij nparticle = SIZE(r_last_update_pbc) @@ -576,7 +576,7 @@ CONTAINS CALL timeset(routineN, handle) rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = NORM2(rij) + drij = SQRT(DOT_PRODUCT(rij, rij)) rij_hat(:) = rij(:)/drij fac = -0.5_dp diff --git a/src/mao_basis.F b/src/mao_basis.F index 6234629519..ed28ab101b 100644 --- a/src/mao_basis.F +++ b/src/mao_basis.F @@ -261,9 +261,8 @@ CONTAINS ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) THEN + IF (col_blk_sizes(iab) < 0) & CPABORT("Minimum number of MAOs has to be specified in KIND section for all elements") - END IF END DO DO ispin = 1, nspin ! coefficients diff --git a/src/mao_io.F b/src/mao_io.F index 1b300ea47e..53728ce974 100644 --- a/src/mao_io.F +++ b/src/mao_io.F @@ -122,10 +122,8 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) THEN - ! catch corner-case + IF (SIZE(local_block) > 0) & ! catch corner-case mpi_buffer(:, :) = local_block(:, :) - END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/mao_wfn_analysis.F b/src/mao_wfn_analysis.F index d0d7132444..ba7f41bdc2 100644 --- a/src/mao_wfn_analysis.F +++ b/src/mao_wfn_analysis.F @@ -243,9 +243,8 @@ CONTAINS CALL get_particle_set(particle_set, qs_kind_set, nmao=col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) THEN + IF (col_blk_sizes(iab) < 0) & CPABORT("Number of MAOs has to be specified in KIND section for all elements") - END IF END DO DO ispin = 1, nspin ! coeficients diff --git a/src/metadyn_tools/graph.F b/src/metadyn_tools/graph.F index 62eb7713ea..92444bd6da 100644 --- a/src/metadyn_tools/graph.F +++ b/src/metadyn_tools/graph.F @@ -200,9 +200,8 @@ PROGRAM graph END IF END DO - IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) THEN + IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) & CPABORT("Error! You've to specify either ORAC, CP2K or CPMD!") - END IF ! For CPMD move filename to colvar_mtd IF (l_cpmd) THEN @@ -359,10 +358,9 @@ PROGRAM graph END IF END DO - IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) THEN + IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) & CALL cp_abort(__LOCATION__, & "-find-path requires the specification of -point-a and -point-b !") - END IF ELSE ALLOCATE (mep_input_data%minima(0, 0)) END IF @@ -649,7 +647,7 @@ PROGRAM graph IF (.NOT. lstride .AND. MOD(it, nwr) == 0) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" - ELSE IF (.NOT. lstride .AND. it == nt) THEN + ELSEIF (.NOT. lstride .AND. it == nt) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" END IF END DO Hills @@ -665,7 +663,7 @@ PROGRAM graph IF (ncount < 10) THEN WRITE (out3_stride, '(A,i1)') TRIM(out3), ncount - ELSE IF (ncount < 100) THEN + ELSEIF (ncount < 100) THEN WRITE (out3_stride, '(A,i2)') TRIM(out3), ncount ELSE WRITE (out3_stride, '(A,i3)') TRIM(out3), ncount diff --git a/src/metadyn_tools/graph_methods.F b/src/metadyn_tools/graph_methods.F index 8ec364e70e..739fd093e7 100644 --- a/src/metadyn_tools/graph_methods.F +++ b/src/metadyn_tools/graph_methods.F @@ -323,7 +323,7 @@ CONTAINS fes_old = fes_now !WRITE(10+j,'(10f20.10)')(xx(id),id=ndim,1,-1),-fes(pnt) - norm_dx = NORM2(dx) + norm_dx = SQRT(DOT_PRODUCT(dx, dx)) IF (norm_dx == 0.0_dp) EXIT ! It is in a really flat region xx = xx - MIN(0.1_dp, norm_dx)*dx/norm_dx ! Re-evaluating pos @@ -448,7 +448,7 @@ CONTAINS ! compute average length (distance 1) DO irep = 2, nreplica xx = pos(:, irep) - pos(:, irep - 1) - avg1 = avg1 + NORM2(xx) + avg1 = avg1 + SQRT(DOT_PRODUCT(xx, xx)) END DO avg1 = avg1/REAL(nreplica - 1, KIND=dp) @@ -456,7 +456,7 @@ CONTAINS ! compute average length (distance 2) DO irep = 3, nreplica xx = pos(:, irep) - pos(:, irep - 2) - avg2 = avg2 + NORM2(xx) + avg2 = avg2 + SQRT(DOT_PRODUCT(xx, xx)) END DO avg2 = avg2/REAL(nreplica - 2, KIND=dp) @@ -478,7 +478,7 @@ CONTAINS davg2 = 0.0_dp IF (irep < nf - 1) THEN xx = pos(:, irep) - pos(:, irep + 2) - xx0 = NORM2(xx) + xx0 = SQRT(DOT_PRODUCT(xx, xx)) dxx = 1.0_dp/xx0*xx ene = ene + 0.25_dp*mep_input_data%kb*(xx0 - avg2)**2 davg2 = davg2 + dxx @@ -486,7 +486,7 @@ CONTAINS IF (irep > ns + 1) THEN xx = pos(:, irep) - pos(:, irep - 2) - yy0 = NORM2(xx) + yy0 = SQRT(DOT_PRODUCT(xx, xx)) dyy = 1.0_dp/yy0*xx davg2 = davg2 + dyy END IF @@ -503,11 +503,11 @@ CONTAINS ! Evaluation of the elastic term ! ------------------------------------------------------------- xx = pos(:, irep) - pos(:, irep + 1) - yy0 = NORM2(xx) + yy0 = SQRT(DOT_PRODUCT(xx, xx)) dyy = 1.0_dp/yy0*xx xx = pos(:, irep) - pos(:, irep - 1) - xx0 = NORM2(xx) + xx0 = SQRT(DOT_PRODUCT(xx, xx)) dxx = 1.0_dp/xx0*xx davg1 = (dxx + dyy)/REAL(nreplica - 1, KIND=dp) @@ -517,11 +517,11 @@ CONTAINS ! Evaluate the tangent xx = pos(:, irep + 1) - pos(:, irep) - xx = xx/NORM2(xx) + xx = xx/SQRT(DOT_PRODUCT(xx, xx)) yy = pos(:, irep) - pos(:, irep - 1) - yy = yy/NORM2(yy) + yy = yy/SQRT(DOT_PRODUCT(yy, yy)) tang = xx + yy - tang = tang/NORM2(tang) + tang = tang/SQRT(DOT_PRODUCT(tang, tang)) xx = derivative(fes, ipos, iperd, ndim, ngrid, dp_grid) dx(:, irep) = DOT_PRODUCT(dx(:, irep), tang)*tang + & @@ -536,7 +536,7 @@ CONTAINS ene = ene + fes_rep(irep) IF ((irep == 1) .OR. (irep == nreplica)) CYCLE - norm_dx = NORM2(dx(:, irep)) + norm_dx = SQRT(DOT_PRODUCT(dx(:, irep), dx(:, irep))) IF (norm_dx /= 0.0_dp) THEN pos(:, irep) = pos(:, irep) - MIN(0.1_dp, norm_dx)*dx(:, irep)/norm_dx END IF diff --git a/src/metadynamics_types.F b/src/metadynamics_types.F index 985188607a..a299e450b9 100644 --- a/src/metadynamics_types.F +++ b/src/metadynamics_types.F @@ -272,9 +272,8 @@ CONTAINS END IF ! Langevin on COLVARS - IF (meta_env%langevin) THEN + IF (meta_env%langevin) & DEALLOCATE (meta_env%rng) - END IF NULLIFY (meta_env%time) NULLIFY (meta_env%metadyn_section) diff --git a/src/metadynamics_utils.F b/src/metadynamics_utils.F index 72834021df..91b33ff467 100644 --- a/src/metadynamics_utils.F +++ b/src/metadynamics_utils.F @@ -157,10 +157,9 @@ CONTAINS "Overriding input specification!") END IF check = meta_env%hills_env%nt_hills >= meta_env%hills_env%min_nt_hills - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "MIN_NT_HILLS must have a value smaller or equal to NT_HILLS! "// & "Cross check with the input reference!") - END IF !RG Adaptive hills CALL section_vals_val_get(metadyn_section, "MIN_DISP", r_val=meta_env%hills_env%min_disp) CALL section_vals_val_get(metadyn_section, "OLD_HILL_NUMBER", i_val=meta_env%hills_env%old_hill_number) @@ -190,18 +189,15 @@ CONTAINS IF (meta_env%well_tempered) THEN meta_env%hills_env%wtcontrol = meta_env%hills_env%wtcontrol .OR. check check = meta_env%hills_env%wtcontrol - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "When using Well-Tempered metadynamics, "// & "DELTA_T (or WTGAMMA) should be explicitly specified.") - END IF - IF (meta_env%extended_lagrange) THEN + IF (meta_env%extended_lagrange) & CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with extended-lagrangian formulation.") - END IF - IF (meta_env%hills_env%min_disp > 0.0_dp) THEN + IF (meta_env%hills_env%min_disp > 0.0_dp) & CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with Adaptive hills.") - END IF END IF CALL section_vals_val_get(metadyn_section, "COLVAR_AVG_TEMPERATURE_RESTART", & @@ -211,13 +207,12 @@ CONTAINS CALL metavar_read(meta_env%metavar(i), meta_env%extended_lagrange, & meta_env%langevin, i, metavar_section) check = (meta_env%metavar(i)%icolvar <= number_allocated_colvars) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "An error occurred in the specification of COLVAR for METAVAR. "// & "Specified COLVAR #("//TRIM(ADJUSTL(cp_to_string(meta_env%metavar(i)%icolvar)))//") "// & "is larger than the maximum number of COLVARS defined in the SUBSYS ("// & TRIM(ADJUSTL(cp_to_string(number_allocated_colvars)))//") !") - END IF END DO ! Parsing the Multiple Walkers Info @@ -240,13 +235,12 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(walkers_section, "WALKERS_STATUS", i_vals=walkers_status) check = (SIZE(walkers_status) == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "size of the WALKERS_STATUS. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") - END IF meta_env%multiple_walkers%walkers_status = walkers_status ELSE meta_env%multiple_walkers%walkers_status = 0 @@ -257,13 +251,12 @@ CONTAINS CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & n_rep_val=n_rep) check = (n_rep == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "number of Walkers File names provided. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") - END IF DO i = 1, n_rep CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & i_rep_val=i, c_val=walkers_file_name) diff --git a/src/minbas_methods.F b/src/minbas_methods.F index 96f1c421df..57411747cf 100644 --- a/src/minbas_methods.F +++ b/src/minbas_methods.F @@ -138,9 +138,8 @@ CONTAINS nmao = SUM(col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) THEN + IF (col_blk_sizes(iab) < 0) & CPABORT("Number of MAOs has to be specified in KIND section for all elements") - END IF END DO CALL get_mo_set(mo_set=mos(1), nao=nao, nmo=nmo) @@ -168,7 +167,7 @@ CONTAINS WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' END IF do_minbas = .FALSE. - ELSE IF (nmo /= nmx) THEN + ELSEIF (nmo /= nmx) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A)') 'Different Number of Alpha and Beta MOs' WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' diff --git a/src/minbas_wfn_analysis.F b/src/minbas_wfn_analysis.F index 3c501d3076..bd4c617ca7 100644 --- a/src/minbas_wfn_analysis.F +++ b/src/minbas_wfn_analysis.F @@ -424,9 +424,9 @@ CONTAINS wij = ABS(SUM(qblock*sblock))/REAL(n, KIND=dp) IF (wij > 0.1_dp) THEN ecount(jatom, 1) = ecount(jatom, 1) + 1 - ELSE IF (wij > 0.01_dp) THEN + ELSEIF (wij > 0.01_dp) THEN ecount(jatom, 2) = ecount(jatom, 2) + 1 - ELSE IF (wij > 0.001_dp) THEN + ELSEIF (wij > 0.001_dp) THEN ecount(jatom, 3) = ecount(jatom, 3) + 1 END IF END IF diff --git a/src/minimax/minimax_exp.F b/src/minimax/minimax_exp.F index 2d9554e462..af4d922b38 100644 --- a/src/minimax/minimax_exp.F +++ b/src/minimax/minimax_exp.F @@ -142,7 +142,7 @@ CONTAINS CALL get_minimax_coeff_k15(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k15 END IF - ELSE IF (k <= 53) THEN + ELSEIF (k <= 53) THEN CALL get_minimax_coeff_k53(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k53 ELSE diff --git a/src/minimax/minimax_rpa.F b/src/minimax/minimax_rpa.F index 9d89e943ed..869a85a9e8 100644 --- a/src/minimax/minimax_rpa.F +++ b/src/minimax/minimax_rpa.F @@ -155,7 +155,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 2) :: fit_coef - REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = [8.4569134345088148E-01_dp, & + REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = (/8.4569134345088148E-01_dp, & -2.3864746901255809E-01_dp, -1.1361819501552294E-01_dp, 6.7690505100738471E-02_dp, & 5.3985186361341728E-03_dp, -1.9612317325166117E-02_dp, 7.3513074383591715E-03_dp, & 1.9996243815975012E-03_dp, -3.1205386442664557E-03_dp, 6.2573451848435199E-04_dp, & @@ -172,8 +172,8 @@ CONTAINS -3.6844989012010113E-06_dp, -7.8361514387479545E+00_dp, -3.6112788486477720E+00_dp, & 9.5851351388967405E+00_dp, 7.2698001012821694E+00_dp, -1.1403856909523945E+01_dp, & -1.7651082087203267E+01_dp, 3.2669706643838275E+01_dp, -5.4176678145626020E+00_dp, & - -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp] - REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE([c01], [13, 2, 2]) + -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp/) + REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 2, 2/)) INTEGER :: irange @@ -205,7 +205,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 4) :: fit_coef - REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = [4.9649110596357299E-01_dp, & + REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = (/4.9649110596357299E-01_dp, & -1.8397680763708085E-01_dp, -2.6764777836094898E-02_dp, 1.4685597048762128E-02_dp, & 3.8551475599549168E-03_dp, -6.6371384965829621E-04_dp, -8.2857349546675376E-04_dp, & 3.7111617653054724E-05_dp, 1.2814660801267966E-04_dp, 6.1538340479780230E-06_dp, & @@ -257,8 +257,8 @@ CONTAINS -4.9301857791232557E+01_dp, 3.1465928358831281E+00_dp, 7.7404606802819202E+01_dp, & -3.3013072565887242E+01_dp, -1.2019494685884978E+02_dp, 1.5486223363142261E+02_dp, & 3.2337501402758228E+01_dp, -1.8488455295931200E+02_dp, 5.0234562973130487E+01_dp, & - 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp] - REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 4, 3]) + 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp/) + REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 4, 3/)) INTEGER :: irange @@ -295,7 +295,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 6) :: fit_coef - REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = [4.7223379816403283E-01_dp, & + REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = (/4.7223379816403283E-01_dp, & -2.2042504935487547E-01_dp, -1.0700855642800766E-01_dp, 2.9282041797865813E-02_dp, & 3.3026836310057026E-02_dp, 1.1386996102844459E-02_dp, -1.2818345627763791E-02_dp, & -4.0229827105483680E-03_dp, 5.2714678853526230E-03_dp, -5.7896018199156346E-03_dp, & @@ -373,8 +373,8 @@ CONTAINS -1.7804086701584447E+02_dp, 5.3879411878296139E+01_dp, 2.5019726837316304E+02_dp, & -2.4632876610675547E+02_dp, -2.3728096521661567E+02_dp, 7.2832435058031899E+02_dp, & -6.3406381009820018E+02_dp, 7.2166814993792187E+01_dp, 2.2865645970566064E+02_dp, & - -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp] - REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 6, 3]) + -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp/) + REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 6, 3/)) INTEGER :: irange @@ -411,7 +411,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 8) :: fit_coef - REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = [4.0437679455062153E-01_dp, & + REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = (/4.0437679455062153E-01_dp, & -1.9968645981826424E-01_dp, -9.6669556285432015E-02_dp, 2.6839132012201752E-02_dp, & 3.6190132805626725E-02_dp, 4.1166010414531336E-03_dp, -1.0769456290470580E-02_dp, & -8.7529874160434775E-05_dp, 5.7309585756926467E-03_dp, -1.0860752534826048E-02_dp, & @@ -515,8 +515,8 @@ CONTAINS -6.8223088256704716E+02_dp, 3.4708903230411840E+02_dp, 1.0990846081358511E+03_dp, & -1.7164437218305100E+03_dp, -5.1026413431245879E+02_dp, 4.8843366036040652E+03_dp, & -7.6063698448775094E+03_dp, 5.5268501397810141E+03_dp, -6.4043799549226162E+02_dp, & - -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp] - REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 8, 3]) + -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp/) + REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 8, 3/)) INTEGER :: irange @@ -553,7 +553,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 10) :: fit_coef - REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = [-4.8858613834160547E-01_dp, & + REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = (/-4.8858613834160547E-01_dp, & 3.4033685149450971E-01_dp, -1.0142642654121627E-01_dp, 1.8656576613307461E+00_dp, & -2.2611249862234847E-07_dp, -4.2139600757794465E-01_dp, 2.7923611356976985E-01_dp, & 4.7524652113269663E-03_dp, -5.0664309914469052E-01_dp, 9.4151166751519222E-01_dp, & @@ -593,8 +593,8 @@ CONTAINS -2.0215919999407249E+03_dp, 1.3397278899112848E+03_dp, 3.2785602402023524E+03_dp, & -6.7015638377241066E+03_dp, 8.2607523725594240E+02_dp, 1.7011468237133256E+04_dp, & -3.7898634628790373E+04_dp, 4.6113041763967398E+04_dp, -3.4882603781213867E+04_dp, & - 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6550926316288959E-01_dp, & + 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6550926316288959E-01_dp, & -1.4194808279243129E-01_dp, -1.8340243943233556E-02_dp, 1.5594859644926301E-02_dp, & 6.5213609288545414E-03_dp, -7.2580394496045918E-04_dp, -1.4367869259991610E-03_dp, & -5.1441935266499043E-04_dp, 1.1018516863846910E-04_dp, 1.3857094404802231E-04_dp, & @@ -727,8 +727,9 @@ CONTAINS -9.5025460048391619E+02_dp, 1.8084927413816368E+02_dp, 4.5372254459206868E-01_dp, & -3.2706671239427972E-08_dp, -6.0956447616697843E-02_dp, 4.0392497654627497E-02_dp, & -5.9611390145588245E-03_dp, -6.4482812112108656E-02_dp, 1.3285507045769324E-01_dp, & - -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp] - REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 10, 4]) + -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp/) + REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: & + coefdata = RESHAPE((/c01, c02/), (/13, 10, 4/)) INTEGER :: irange @@ -770,7 +771,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 12) :: fit_coef - REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = [-2.1886099081761100E-02_dp, & + REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = (/-2.1886099081761100E-02_dp, & 1.6493591518278907E-03_dp, 1.1789604920345118E-03_dp, 6.4862232853117350E+00_dp, & -1.7754848782963699E+00_dp, -1.3982954414549702E+00_dp, 8.0870739791892121E-01_dp, & -3.2912209721480506E-01_dp, 6.6541689936850468E-01_dp, -7.1706760669376735E-01_dp, & @@ -845,8 +846,8 @@ CONTAINS 4.8176388108956071E+03_dp, 1.0175276953355078E+04_dp, -2.6714845272387549E+04_dp, & 1.3141868511851815E+04_dp, 5.7600064337445598E+04_dp, -1.7044732018512717E+05_dp, & 2.5361567867653081E+05_dp, -2.3362423558935185E+05_dp, 1.2691185251979054E+05_dp, & - -3.1278542676771558E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.3880318322659616E-01_dp, & + -3.1278542676771558E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.3880318322659616E-01_dp, & -1.3504254699048457E-01_dp, -1.8598173825632135E-02_dp, 1.5951626606880761E-02_dp, & 7.2684956676590529E-03_dp, -5.7141087071240480E-04_dp, -1.5395949213734461E-03_dp, & -7.1572363929054415E-04_dp, 3.6877254806601694E-05_dp, 5.4320682223059976E-06_dp, & @@ -979,8 +980,9 @@ CONTAINS -1.0634490523999061E+02_dp, 2.1350371455168180E+01_dp, 3.4511581153937105E+00_dp, & -4.6074986504725718E-01_dp, -4.1793306232973060E-01_dp, 1.1447565909224683E-01_dp, & -9.1392964448968397E-02_dp, 1.8219557370192899E-01_dp, -1.6634354182093192E-01_dp, & - 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp] - REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 12, 4]) + 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp/) + REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: & + coefdata = RESHAPE((/c01, c02/), (/13, 12, 4/)) INTEGER :: irange @@ -1022,7 +1024,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 14) :: fit_coef - REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = [-4.1754731782680632E-02_dp, & + REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = (/-4.1754731782680632E-02_dp, & 6.9637423606893978E-03_dp, 9.8317123038661812E-04_dp, 9.3141247748056060E+00_dp, & -3.3034187378384154E+00_dp, -2.3099777024265484E+00_dp, 1.9795050912537626E+00_dp, & -8.5251482053787397E-01_dp, 1.2153039011546896E+00_dp, -1.4541564892554977E+00_dp, & @@ -1131,8 +1133,8 @@ CONTAINS -6.0796509451681840E-03_dp, -1.2729055327721569E+04_dp, 1.1355442435730931E+04_dp, & 1.9420434975201191E+04_dp, -5.7157101053784776E+04_dp, 4.1961441009360387E+04_dp, & 8.2301170473632315E+04_dp, -2.9848869860082364E+05_dp, 4.7636758440468600E+05_dp, & - -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6444089699692058E-01_dp, & + -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6444089699692058E-01_dp, & -1.5470504999202458E-01_dp, -4.6856578935403119E-02_dp, 2.5042624726789489E-02_dp, & 1.9131665599864848E-02_dp, -2.9696778036559586E-03_dp, -3.7556543742271655E-03_dp, & 1.6266657874186815E-04_dp, 4.6360340975112090E-03_dp, -7.8332396642386976E-03_dp, & @@ -1265,8 +1267,9 @@ CONTAINS 1.3457500127744759E-03_dp, 3.1573603989801897E-04_dp, 3.6037055399201039E+00_dp, & -8.0542869559173069E-01_dp, -6.3866068626924610E-01_dp, 3.6581611775536099E-01_dp, & -1.8032325305523136E-01_dp, 3.1726528871551424E-01_dp, -3.4024223010999666E-01_dp, & - 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp] - REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 14, 4]) + 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp/) + REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: & + coefdata = RESHAPE((/c01, c02/), (/13, 14, 4/)) INTEGER :: irange @@ -1308,7 +1311,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 16) :: fit_coef - REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = [-8.9013840273255062E+02_dp, & + REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = (/-8.9013840273255062E+02_dp, & 4.4450456221108550E+02_dp, 5.3174323393059228E+02_dp, -1.2592882857295644E+03_dp, & 1.0557554278716216E+03_dp, -3.5046238641220043E+02_dp, 1.2930757301899466E+03_dp, & 1.1516939780618657E-03_dp, -1.6608759395740256E+03_dp, 1.4462154462223984E+03_dp, & @@ -1319,8 +1322,8 @@ CONTAINS 1.9619149559132464E+04_dp, 2.5759373028729122E+04_dp, -7.7020575840804217E+04_dp, & 6.3201727988014049E+04_dp, 6.8163632238120859E+04_dp, -2.9053341169350612E+05_dp, & 4.7359098571404989E+05_dp, -4.6694609866564447E+05_dp, 2.7229709401159501E+05_dp, & - -7.2557173401722219E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7310961221813451E-01_dp, & + -7.2557173401722219E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7310961221813451E-01_dp, & -9.5711109831144323E-02_dp, -2.5960297888544426E-02_dp, 7.7258590328211849E-03_dp, & 5.1368496261163018E-03_dp, -1.1234374052788891E-03_dp, -1.0608869644587510E-03_dp, & 4.0213920388401469E-04_dp, 3.0775150301006290E-04_dp, -5.8915574825377335E-05_dp, & @@ -1453,8 +1456,8 @@ CONTAINS -1.6811781491598083E+01_dp, 4.2614301447710945E+00_dp, 4.2182283329260298E+02_dp, & -9.0232374730691106E+02_dp, 7.1913307941971050E+02_dp, 6.5788926678577425E+01_dp, & -5.6847305624230580E+02_dp, 3.2522974861279704E+02_dp, 1.3143394779042333E+02_dp, & - -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.8863592203480596E+02_dp, & + -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.8863592203480596E+02_dp, & 1.0528430973221714E+02_dp, -1.5857007223981109E+01_dp, 1.8276946029107571E+03_dp, & -4.8112032981737193E+03_dp, 6.1258592600600687E+03_dp, -4.0381542724034271E+03_dp, & 3.2440486268768652E+01_dp, 2.9756759864086989E+03_dp, -3.5826087401832801E+03_dp, & @@ -1587,9 +1590,9 @@ CONTAINS 1.4478597281785360E+02_dp, 1.1301880394535623E+01_dp, -1.5313609799645960E+02_dp, & 1.5075591149117258E+02_dp, -5.3325987923237058E+01_dp, 2.9560124699329253E+02_dp, & 1.7113342586626282E-04_dp, -2.4662390250801528E+02_dp, 2.1474962274139023E+02_dp, & - -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp] + -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp/) REAL(KIND=dp), DIMENSION(13, 16, 4), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03], [13, 16, 4]) + coefdata = RESHAPE((/c01, c02, c03/), (/13, 16, 4/)) INTEGER :: irange @@ -1631,7 +1634,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 18) :: fit_coef - REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = [-8.4609670938814907E+02_dp, & + REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = (/-8.4609670938814907E+02_dp, & 5.2521889455815938E+02_dp, -1.8158803681882837E+01_dp, -1.9195843056246903E+02_dp, & 4.7038182235191250E+01_dp, 4.4962618821808661E+01_dp, 2.3952550076762327E+03_dp, & 7.3919658606953450E-04_dp, -3.3678854403725500E+03_dp, 2.7630103823335253E+03_dp, & @@ -1676,8 +1679,8 @@ CONTAINS 7.9756724721310873E-03_dp, -3.6633955682749525E+04_dp, 3.0054168139170702E+04_dp, & 3.0244619250697619E+04_dp, -8.9553753522321902E+04_dp, 7.9875735584514681E+04_dp, & 1.7524458945017868E+04_dp, -1.3188240705569120E+05_dp, 1.3592402872600380E+05_dp, & - -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7491556688515650E-01_dp, & + -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7491556688515650E-01_dp, & -1.0138397977284885E-01_dp, -3.9049726894672010E-02_dp, 1.2625689412991524E-02_dp, & 1.2491380414983764E-02_dp, -3.7765616302317911E-03_dp, -5.1175283467075521E-03_dp, & 1.4632298825565039E-03_dp, 3.6642955364173022E-03_dp, -2.0156097072982762E-03_dp, & @@ -1810,8 +1813,8 @@ CONTAINS 2.9781052441439151E-02_dp, -1.4527696704126849E-02_dp, 1.7339641636383043E+01_dp, & -1.1465395481325789E+01_dp, -2.7302697069655961E+00_dp, 4.4629359221611402E+00_dp, & 7.1614646223286882E-01_dp, -1.4605259953560206E+00_dp, -1.0335490616197762E+00_dp, & - 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [8.6574572823904627E-01_dp, & + 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/8.6574572823904627E-01_dp, & -1.6889080712338411E-01_dp, -3.8729713566779244E-03_dp, 4.1076303571384891E+01_dp, & -3.6684994925539350E+01_dp, -3.4268355391161074E+00_dp, 1.6994010089726881E+01_dp, & -1.2988970233372894E+00_dp, -6.3669393876591824E+00_dp, -1.4789915209996456E+00_dp, & @@ -1944,9 +1947,9 @@ CONTAINS 1.3132457381744328E+02_dp, -3.8713782602971918E+01_dp, -3.5040157951924371E+01_dp, & 3.7792017841024283E+01_dp, -1.0016991740016113E+01_dp, 4.5777593919577163E+02_dp, & 8.1637641969554641E-05_dp, -3.6580205008674420E+02_dp, 3.0011032726156765E+02_dp, & - -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp] + -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp/) REAL(KIND=dp), DIMENSION(13, 18, 4), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03], [13, 18, 4]) + coefdata = RESHAPE((/c01, c02, c03/), (/13, 18, 4/)) INTEGER :: irange @@ -1988,7 +1991,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 20) :: fit_coef - REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = [-6.3360994610628929E-01_dp, & + REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = (/-6.3360994610628929E-01_dp, & 9.7649518951989356E-01_dp, -1.0559988395317237E+00_dp, 7.8078414899977844E-01_dp, & -3.5500159005989329E-01_dp, 7.4673135592582374E-02_dp, 2.6285615412587124E+00_dp, & 1.5860173767897436E-07_dp, -3.6913389708324101E-01_dp, 3.7465972064134995E-01_dp, & @@ -2068,8 +2071,8 @@ CONTAINS -1.0102666755386532E+05_dp, 1.0253508247597031E+05_dp, 1.0602636418265585E+05_dp, & -4.0728952867028292E+05_dp, 4.6976444940836332E+05_dp, 5.8500781101532266E+04_dp, & -1.2055500949944141E+06_dp, 2.3598896259778733E+06_dp, -2.5585975849316372E+06_dp, & - 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.5561005851553148E-01_dp, & + 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.5561005851553148E-01_dp, & -9.8727639373792656E-02_dp, -3.5824853081321391E-02_dp, 1.3639809429163310E-02_dp, & 1.2140312218587666E-02_dp, -4.6051578600266093E-03_dp, -5.2440292404026837E-03_dp, & 1.6141788048728977E-03_dp, 4.9068438183985687E-03_dp, -3.8643109440260576E-03_dp, & @@ -2202,8 +2205,8 @@ CONTAINS 1.4996446737543528E+02_dp, -3.0374236420884017E+01_dp, 2.5318787052609042E+00_dp, & -4.5232522380132079E-01_dp, -2.4894203765998704E-01_dp, 3.7844517569960621E-02_dp, & 6.7481113092261444E-02_dp, -1.8350883302710324E-03_dp, -3.7893183999051401E-02_dp, & - 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.4867222607997398E-03_dp, & + 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.4867222607997398E-03_dp, & 7.4160230219779905E-03_dp, -1.8338341118192985E-03_dp, 3.6656246502838239E+00_dp, & -1.0862821007061922E+00_dp, -4.7299838594788851E-01_dp, 2.1791529395255307E-01_dp, & 1.6235258776392880E-01_dp, -5.9164629917823931E-02_dp, -1.0182204867540855E-01_dp, & @@ -2336,9 +2339,9 @@ CONTAINS 2.0849621635227758E-01_dp, -2.2855126470711301E-01_dp, 1.7151231132777350E-01_dp, & -7.9338970506037887E-02_dp, 1.7034794798258115E-02_dp, 1.1561315825459209E+00_dp, & 4.6876842564306299E-08_dp, -1.0903099661435091E-01_dp, 1.1066333209885304E-01_dp, & - -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp] + -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp/) REAL(KIND=dp), DIMENSION(13, 20, 4), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03], [13, 20, 4]) + coefdata = RESHAPE((/c01, c02, c03/), (/13, 20, 4/)) INTEGER :: irange @@ -2380,7 +2383,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 22) :: fit_coef - REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = [-2.5319035989384675E+00_dp, & + REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = (/-2.5319035989384675E+00_dp, & -3.1868909327109335E-01_dp, 7.3902114944100665E+00_dp, -1.8431274144078589E+01_dp, & 2.9378426424405447E+01_dp, -3.3161724592145767E+01_dp, 2.5816413812770147E+01_dp, & -1.2469330304705172E+01_dp, 2.8128079338690761E+00_dp, 2.4584353206019742E+01_dp, & @@ -2457,8 +2460,8 @@ CONTAINS 2.1221227425035721E+05_dp, 1.9513181165124831E+05_dp, -8.3228931356148690E+05_dp, & 1.0686042433396007E+06_dp, -1.6890882361242565E+05_dp, -2.0275393275062682E+06_dp, & 4.3886071943292571E+06_dp, -4.9464312502375301E+06_dp, 3.1275647455199584E+06_dp, & - -8.7618952854779735E+05_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.9140383852290629E-01_dp, & + -8.7618952854779735E+05_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.9140383852290629E-01_dp, & -6.8714312208041611E-02_dp, -9.1979524758077930E-03_dp, 4.0542016308222793E-03_dp, & 1.3043896673939879E-03_dp, -3.3077626826676678E-04_dp, -1.1713733973944338E-04_dp, & 7.6096932007647678E-05_dp, 1.6862094749663900E-05_dp, -1.8859482112709049E-05_dp, & @@ -2591,8 +2594,8 @@ CONTAINS -3.8649136037865522E-01_dp, 2.2567746326676860E-01_dp, 7.4213954026122252E+01_dp, & -1.4804950267684572E+02_dp, 1.2495507784125873E+02_dp, -2.4776264817547396E+01_dp, & -4.2930419560902017E+01_dp, 2.9472395507465627E+01_dp, 1.0097402469676231E+01_dp, & - -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.4561539999459816E+01_dp, & + -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.4561539999459816E+01_dp, & 4.8544787554718685E+00_dp, -6.3387746031848102E-01_dp, 1.5731981998839461E+02_dp, & -3.7106120150889751E+02_dp, 4.0538316285381757E+02_dp, -1.9862435563464234E+02_dp, & -4.2159595434504858E+01_dp, 1.1123116084380190E+02_dp, -3.2616679588589356E+01_dp, & @@ -2725,8 +2728,8 @@ CONTAINS 2.4122252521897924E+00_dp, -9.7999682646599489E+00_dp, 7.9639626818274714E+00_dp, & -2.9529703827741800E+00_dp, 4.3437020501980872E-01_dp, 1.3418598639315178E+02_dp, & -1.4639064170062176E+02_dp, 7.9688822975923612E+00_dp, 6.9963146941480773E+01_dp, & - -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2105999150585166E+01_dp, & + -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2105999150585166E+01_dp, & -2.2551854693657698E+00_dp, -3.0252257829864192E+01_dp, 3.2690274416605568E+01_dp, & -1.5006475584487145E+01_dp, 2.7494470603903425E+00_dp, 3.4045498207568971E+02_dp, & -4.7133760448357106E+02_dp, 1.1327780050673924E+02_dp, 2.2523014020490135E+02_dp, & @@ -2859,9 +2862,9 @@ CONTAINS -1.1263108188627524E-02_dp, 2.3148160729056904E+00_dp, -5.9940875579716151E+00_dp, & 9.7525037514957766E+00_dp, -1.1202621964616382E+01_dp, 8.8723971586232349E+00_dp, & -4.3615551235670349E+00_dp, 1.0019327026030862E+00_dp, 1.0890417035686898E+01_dp, & - -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp] + -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp/) REAL(KIND=dp), DIMENSION(13, 22, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04], [13, 22, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 22, 5/)) INTEGER :: irange @@ -2908,7 +2911,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 24) :: fit_coef - REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = [-3.4185637511153556E+02_dp, & + REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = (/-3.4185637511153556E+02_dp, & 3.0668182445881496E+02_dp, -4.1209664021967029E+02_dp, 3.7330789502174974E+02_dp, & -2.3245333897278655E+02_dp, 1.3019687281058577E+02_dp, -7.4166370900253412E+01_dp, & 3.1434861912054572E+01_dp, -6.1992398402862987E+00_dp, 3.3062345634073872E+03_dp, & @@ -3028,8 +3031,8 @@ CONTAINS -3.7306629896332178E+05_dp, 4.1394566251683736E+05_dp, 3.3744969046701316E+05_dp, & -1.5791948214027057E+06_dp, 2.1917044569001873E+06_dp, -7.9115467427151953E+05_dp, & -3.0601023356753197E+06_dp, 7.4427363873937679E+06_dp, -8.7248223821029570E+06_dp, & - 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8031277973538481E-01_dp, & + 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8031277973538481E-01_dp, & -6.7333985536224536E-02_dp, -8.9222590966419636E-03_dp, 4.3313443199331000E-03_dp, & 1.3612994231258369E-03_dp, -4.2134528860866431E-04_dp, -1.3958926498276367E-04_dp, & 1.0459985085575114E-04_dp, 2.4321788489287324E-05_dp, -2.5628407616984446E-05_dp, & @@ -3162,8 +3165,8 @@ CONTAINS -3.8414425007098330E-01_dp, 7.5502828561301874E-02_dp, 1.5429572442140103E+01_dp, & -1.9205543991334537E+01_dp, 7.1837956925844102E+00_dp, 4.1527008022568523E+00_dp, & -3.9604373888031548E+00_dp, -1.2184620720634423E+00_dp, 2.1268242758491254E+00_dp, & - 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [1.1553671463453488E+00_dp, & + 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/1.1553671463453488E+00_dp, & -7.6780781804979914E-01_dp, 1.7390307652239254E-01_dp, 2.8165264234356147E+01_dp, & -4.2781018965163859E+01_dp, 2.3179056548048951E+01_dp, 5.2439089413556950E+00_dp, & -1.1643001503346785E+01_dp, 4.5770373921564939E-01_dp, 5.5851597940226441E+00_dp, & @@ -3296,8 +3299,8 @@ CONTAINS 1.9287416985295423E-02_dp, -9.7735471490287135E-03_dp, -5.4153420961059818E-03_dp, & 6.2996178645704911E-03_dp, -1.6741808988248179E-03_dp, 3.2323307090443092E+00_dp, & -7.5868899537917556E-01_dp, -3.6403112314198777E-01_dp, 1.3638032105863709E-01_dp, & - 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.5411208403973456E-02_dp, & + 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.5411208403973456E-02_dp, & 5.7808629859203861E-02_dp, -5.0196351778645114E-02_dp, 5.2149034144752344E-03_dp, & 9.5271530622531974E-03_dp, -3.3982153227889275E-03_dp, 5.4948218832066447E+00_dp, & -1.9768544283573861E+00_dp, -7.8540931963005123E-01_dp, 5.1224166160961682E-01_dp, & @@ -3430,9 +3433,9 @@ CONTAINS 8.6197068058446064E+01_dp, -1.1457176948523994E+02_dp, 1.0089516510941472E+02_dp, & -7.0493679332727382E+01_dp, 4.8625058388200841E+01_dp, -2.9732088584351676E+01_dp, & 1.1947228503152537E+01_dp, -2.1840920197937304E+00_dp, 1.0166774272757106E+03_dp, & - -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp] + -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp/) REAL(KIND=dp), DIMENSION(13, 24, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04], [13, 24, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 24, 5/)) INTEGER :: irange @@ -3479,7 +3482,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 26) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8838771004380783E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8838771004380783E-01_dp, & -7.8098504554216852E-02_dp, -1.5170263296839995E-02_dp, 8.2399169935392508E-03_dp, & 3.5286892847422469E-03_dp, -1.8215194066877041E-03_dp, -9.0884305814463765E-04_dp, & 6.8756727909990219E-04_dp, 3.7413977081317160E-04_dp, -2.6705465221031334E-04_dp, & @@ -3612,8 +3615,8 @@ CONTAINS -3.7209893008122726E-02_dp, 4.6211560443511707E-03_dp, 4.9425542029764467E+00_dp, & -3.3299793049425701E+00_dp, -1.5240471603939173E-02_dp, 9.6617116551502813E-01_dp, & -5.4487412666999822E-02_dp, -4.4981543663568441E-01_dp, 5.4235895382646740E-02_dp, & - 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [3.5632823078643500E-01_dp, & + 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/3.5632823078643500E-01_dp, & -1.4001776162509430E-01_dp, 2.2286666712875530E-02_dp, 8.7125285885676789E+00_dp, & -7.4679426200738366E+00_dp, 8.3805209926335500E-01_dp, 2.2477163058559704E+00_dp, & -6.0060735276290700E-01_dp, -1.0331040612400506E+00_dp, 3.9698448728282515E-01_dp, & @@ -3746,8 +3749,8 @@ CONTAINS -1.5690448976060742E+00_dp, -1.4469520844727743E+01_dp, 1.5229016181347497E+01_dp, & -6.7413191274813640E+00_dp, 1.1871712862612187E+00_dp, 2.8292219949744720E+02_dp, & -3.3466585644002333E+02_dp, 6.5399374381441106E+01_dp, 1.3547954808764075E+02_dp, & - -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.1951406154569082E+01_dp, & + -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.1951406154569082E+01_dp, & -2.7863833003973856E+01_dp, -2.4615790099798474E+01_dp, 4.4154903132889864E+01_dp, & -2.4321043128719936E+01_dp, 5.0336537486842516E+00_dp, 7.0657858026784504E+02_dp, & -1.0528573743078830E+03_dp, 4.1625512279061735E+02_dp, 3.6427444425345516E+02_dp, & @@ -3880,8 +3883,8 @@ CONTAINS 5.9384272779209310E-02_dp, -6.6034549944533560E-02_dp, 6.3165197301667780E-02_dp, & -5.8533667022985264E-02_dp, 4.7080124186021241E-02_dp, -2.8040678094242519E-02_dp, & 1.0590404330460124E-02_dp, -1.8887168866975497E-03_dp, 3.2950022547352660E+00_dp, & - -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-7.8836509708512373E-02_dp, & + -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-7.8836509708512373E-02_dp, & 1.3178061660818258E-01_dp, -1.4891101086305505E-01_dp, 1.4038052557472530E-01_dp, & -1.2827505792189706E-01_dp, 1.0306674552536969E-01_dp, -6.1520533848826123E-02_dp, & 2.3216931723502306E-02_dp, -4.1222161991565217E-03_dp, 5.6592328962619902E+00_dp, & @@ -4014,8 +4017,8 @@ CONTAINS -1.7064535222921169E+01_dp, 1.9476350353952395E+01_dp, -1.8590436540559089E+01_dp, & 3.1925275522724674E+00_dp, 4.1158324783342913E+01_dp, -1.1921515605115852E+02_dp, & 2.0979218330367425E+02_dp, -2.5985281813994447E+02_dp, 2.2199832068654112E+02_dp, & - -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp] - REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = [-2.7907357414271074E-05_dp, & + -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp/) + REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = (/-2.7907357414271074E-05_dp, & -4.8826106427338516E+01_dp, 5.5726828156877396E+01_dp, -5.0511477178292488E+01_dp, & 2.9783692652581260E+00_dp, 1.2761594545085276E+02_dp, -3.5194583503612256E+02_dp, & 6.0567238480576850E+02_dp, -7.3810346857458831E+02_dp, 6.2201716742048916E+02_dp, & @@ -4045,9 +4048,9 @@ CONTAINS -6.7753046300068102E+05_dp, 7.7323771401862660E+05_dp, 5.5823523395335092E+05_dp, & -2.8474678682125942E+06_dp, 4.1915016169727501E+06_dp, -2.1435582467267131E+06_dp, & -4.2583193954617819E+06_dp, 1.1939190162504816E+07_dp, -1.4588866431316955E+07_dp, & - 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp] + 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp/) REAL(KIND=dp), DIMENSION(13, 26, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 26, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 26, 5/)) INTEGER :: irange @@ -4094,7 +4097,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 28) :: fit_coef - REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = [-4.9474578762585689E-04_dp, & + REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = (/-4.9474578762585689E-04_dp, & -2.5939403957639643E+03_dp, 3.0352874416549189E+03_dp, -1.9742442806612846E+03_dp, & -1.5969761709828460E+03_dp, 9.5497831811419619E+03_dp, -2.1791219784053799E+04_dp, & 3.4007167063977518E+04_dp, -3.8426789298450683E+04_dp, 3.0290020612758195E+04_dp, & @@ -4167,8 +4170,8 @@ CONTAINS -2.4363178639415667E-01_dp, -1.2048752475226286E+06_dp, 1.4098050382019044E+06_dp, & 9.0383108002498816E+05_dp, -5.0245780711403918E+06_dp, 7.7751430360333202E+06_dp, & -4.9183263330898508E+06_dp, -5.5122178990547452E+06_dp, 1.8712359903900910E+07_dp, & - -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8855631887642382E-01_dp, & + -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8855631887642382E-01_dp, & -8.1829231046632769E-02_dp, -1.8950903102790816E-02_dp, 1.1349898287774197E-02_dp, & 5.7338935886024562E-03_dp, -3.6475885523936957E-03_dp, -2.1458998142384776E-03_dp, & 1.4787405505064602E-03_dp, 1.8498537181843471E-03_dp, -1.9614757255708645E-03_dp, & @@ -4301,8 +4304,8 @@ CONTAINS 1.1382083100254657E-03_dp, -3.9779179490065093E-04_dp, 1.4924251913695632E+00_dp, & -5.1831019334185813E-01_dp, -1.0671352469554986E-01_dp, 9.3839903685068102E-02_dp, & 3.2490232771881414E-02_dp, -3.4916436688308940E-02_dp, -1.3379509563995902E-02_dp, & - 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [7.7725039723149673E-03_dp, & + 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/7.7725039723149673E-03_dp, & 1.1145706792479703E-04_dp, -5.6097890673260616E-04_dp, 2.6197138414537928E+00_dp, & -1.1878855591113402E+00_dp, -1.3669541461047707E-01_dp, 2.5880924857422194E-01_dp, & 3.9410663226141771E-02_dp, -1.0161291074659663E-01_dp, -1.4845376770825033E-02_dp, & @@ -4435,8 +4438,8 @@ CONTAINS 1.8202124035828973E-01_dp, -2.3777194345333863E-01_dp, 9.8820369139971026E-02_dp, & -6.2744671316908003E-03_dp, -4.3699523495120468E-03_dp, 1.1856221271082283E+01_dp, & -5.2568207235502564E+00_dp, -1.5969164750173954E+00_dp, 1.6461069205315015E+00_dp, & - 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.7852818456494469E-01_dp, & + 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.7852818456494469E-01_dp, & 4.8067555347683755E-01_dp, -7.7452581263261322E-01_dp, 4.1934407249887440E-01_dp, & -8.9234614648328783E-02_dp, 1.6775465007990663E-03_dp, 2.2972132228999541E+01_dp, & -1.2898901071815617E+01_dp, -2.9797860863789967E+00_dp, 4.6560435611069622E+00_dp, & @@ -4569,8 +4572,8 @@ CONTAINS 8.7770738779350062E+00_dp, -1.1095172356986756E+01_dp, 1.0314862293028543E+01_dp, & -8.8233143705921826E+00_dp, 7.0699089843034164E+00_dp, -4.4024286308950149E+00_dp, & 1.7350313146222107E+00_dp, -3.1699935067362639E-01_dp, 1.3246229877703036E+02_dp, & - -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-1.7228109793468004E+01_dp, & + -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-1.7228109793468004E+01_dp, & 2.4108285826088757E+01_dp, -3.1362122687167119E+01_dp, 2.9105748579791722E+01_dp, & -2.4011018345543842E+01_dp, 1.8874442598138845E+01_dp, -1.1844908362658735E+01_dp, & 4.7389221341553531E+00_dp, -8.7620232886140437E-01_dp, 3.1319177678658934E+02_dp, & @@ -4703,9 +4706,9 @@ CONTAINS -6.6016663782193780E+02_dp, 7.7249587755502171E+02_dp, -6.0564642881603584E+02_dp, & -1.6334533603788654E+02_dp, 2.0809169575290675E+03_dp, -5.2520819705711947E+03_dp, & 8.7142803953445527E+03_dp, -1.0381449011333283E+04_dp, 8.6066748064158692E+03_dp, & - -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp] + -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp/) REAL(KIND=dp), DIMENSION(13, 28, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 28, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 28, 5/)) INTEGER :: irange @@ -4752,7 +4755,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 30) :: fit_coef - REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = [-3.0692468631051978E-08_dp, & + REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = (/-3.0692468631051978E-08_dp, & -3.9609383383921665E-01_dp, 4.7587580740675417E-01_dp, -5.5706375318965173E-01_dp, & 3.4546263714113901E-01_dp, 5.4776062905207357E-01_dp, -2.4141552540426781E+00_dp, & 4.9577847041515470E+00_dp, -6.8295343742172383E+00_dp, 6.3573367557181761E+00_dp, & @@ -4869,8 +4872,8 @@ CONTAINS 2.5461696440140237E+06_dp, 1.4577959403430095E+06_dp, -8.8776723555507679E+06_dp, & 1.4429270679797074E+07_dp, -1.0764718275979346E+07_dp, -6.0081024069717359E+06_dp, & 2.8423455083762139E+07_dp, -3.8351286309245549E+07_dp, 2.6572649225598279E+07_dp, & - -7.9000536567775914E+06_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8728308171438685E-01_dp, & + -7.9000536567775914E+06_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8728308171438685E-01_dp, & -7.4958225804522882E-02_dp, -1.7654418697317781E-02_dp, 1.0337296188123402E-02_dp, & 5.3074367941912289E-03_dp, -3.4737735619981940E-03_dp, -2.0980081422520588E-03_dp, & 1.3332352270175691E-03_dp, 1.8928638178553657E-03_dp, -2.0371064972525598E-03_dp, & @@ -5003,8 +5006,8 @@ CONTAINS 3.0587066325522777E+01_dp, -9.7246696807779784E+00_dp, 2.3046596783109666E-01_dp, & -5.0266863054748409E-02_dp, -1.7179737588739360E-02_dp, 5.4654515693096711E-03_dp, & 4.7852361622912525E-03_dp, -1.7421101769864551E-03_dp, -1.9440310548800761E-03_dp, & - 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.3785652584517211E-04_dp, & + 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.3785652584517211E-04_dp, & 4.0415260781371566E-04_dp, -1.1566827381466792E-04_dp, 7.4614843698202982E-01_dp, & -1.8831297390879426E-01_dp, -5.5307781300718430E-02_dp, 2.5755321163507486E-02_dp, & 1.6130804272204945E-02_dp, -8.8949071784985307E-03_dp, -6.6594057854666763E-03_dp, & @@ -5137,8 +5140,8 @@ CONTAINS 1.6273475095842586E-03_dp, -8.9025885910407965E-04_dp, -3.6671922956720823E-04_dp, & 4.8507440460371750E-04_dp, -1.3211072877791544E-04_dp, 8.5654480285554591E-01_dp, & -1.1200920153309295E-01_dp, -6.0375651330303620E-02_dp, 1.2480943363126322E-02_dp, & - 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2061351968797813E-03_dp, & + 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2061351968797813E-03_dp, & 7.2651800654771788E-03_dp, -4.9666091131882828E-03_dp, -6.0509045722459322E-04_dp, & 1.7074706793122701E-03_dp, -5.0886032182887841E-04_dp, 1.7258143200373688E+00_dp, & -2.9884323352649256E-01_dp, -1.4775030321223576E-01_dp, 4.7248271588260116E-02_dp, & @@ -5271,8 +5274,8 @@ CONTAINS 2.2562073529423785E-02_dp, -2.5951410486921640E-02_dp, 2.5567379426983138E-02_dp, & -2.4333781051323347E-02_dp, 2.0151995146635144E-02_dp, -1.2400482709093779E-02_dp, & 4.8452373650168124E-03_dp, -8.9294844328912499E-04_dp, 1.8352119311378547E+00_dp, & - -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-3.6931298185134437E-02_dp, & + -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-3.6931298185134437E-02_dp, & 6.2239013775737956E-02_dp, -7.2288174936489244E-02_dp, 7.0693666064322772E-02_dp, & -6.6776211112181863E-02_dp, 5.5274684972707100E-02_dp, -3.4069532004586962E-02_dp, & 1.3318163740503416E-02_dp, -2.4516852040202333E-03_dp, 3.4526910112953169E+00_dp, & @@ -5405,9 +5408,9 @@ CONTAINS -1.5296272228579366E-01_dp, 1.8377288757765206E-01_dp, -2.1880198683428151E-01_dp, & 1.4228504563245828E-01_dp, 1.9523650997654252E-01_dp, -9.0945729598550951E-01_dp, & 1.8916140218456958E+00_dp, -2.6232469600311217E+00_dp, 2.4527671312473118E+00_dp, & - -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp] + -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp/) REAL(KIND=dp), DIMENSION(13, 30, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 30, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 30, 5/)) INTEGER :: irange @@ -5454,7 +5457,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 32) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8440983439459679E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8440983439459679E-01_dp, & -7.0479249003300562E-02_dp, -1.6832381157590469E-02_dp, 9.9837323526780937E-03_dp, & 5.1989041899428937E-03_dp, -3.5423416042951205E-03_dp, -2.1543663571483209E-03_dp, & 1.3096125508292179E-03_dp, 2.2049401312140603E-03_dp, -2.5023058617921153E-03_dp, & @@ -5587,8 +5590,8 @@ CONTAINS 9.8497860011119158E+00_dp, -3.3639190612129344E+00_dp, 5.9487274112930379E+02_dp, & -1.7978611801015538E+03_dp, 2.7622843520701335E+03_dp, -2.5880461605405826E+03_dp, & 1.4022414211295804E+03_dp, -2.0359258628022113E+02_dp, -2.6091417556034258E+02_dp, & - 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [2.9539145031653501E+01_dp, & + 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/2.9539145031653501E+01_dp, & 4.7715049407002184E+00_dp, -3.2712144543127324E+00_dp, 2.2264348078485641E+03_dp, & -6.6288008445597088E+03_dp, 1.0084012629385183E+04_dp, -9.4383385665132246E+03_dp, & 5.2647790264708256E+03_dp, -1.0875754774918837E+03_dp, -5.8837187049175338E+02_dp, & @@ -5721,8 +5724,8 @@ CONTAINS -1.7628434198318345E+01_dp, 3.9655688909902926E+02_dp, -3.7408946589251713E+02_dp, & 1.5787812785698458E+02_dp, -2.7089362134634474E+01_dp, 2.0614418378112468E+03_dp, & -5.6578757894510300E+03_dp, 7.1620850676558530E+03_dp, -4.4041308675995369E+03_dp, & - -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.5703600920047631E+02_dp, & + -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.5703600920047631E+02_dp, & 6.8515562434659739E+02_dp, 1.8173876061092901E+02_dp, -5.6990417291447488E+02_dp, & 3.3635689037567329E+02_dp, -7.1542971828322536E+01_dp, 4.8609029109261082E+03_dp, & -1.4519102949367327E+04_dp, 2.1140422991455973E+04_dp, -1.7456530345889521E+04_dp, & @@ -5855,8 +5858,8 @@ CONTAINS -6.5694865280062390E+02_dp, 5.9368339749825054E+02_dp, 7.7692645932202890E+02_dp, & -1.0697937873179803E+03_dp, 3.8548984201540087E+01_dp, 6.7608544747530505E+02_dp, & -4.8167622236142665E+02_dp, 1.1263022376557032E+02_dp, 4.9024755081192952E+03_dp, & - -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-4.7874743699806668E+03_dp, & + -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-4.7874743699806668E+03_dp, & -8.5329386064550408E+02_dp, 2.7526945075798449E+03_dp, 1.9553980517436300E+03_dp, & -5.9289564226732664E+03_dp, 4.4771348003328458E+03_dp, -1.0901273950898408E+03_dp, & -3.0130386512273043E+02_dp, 1.6238769196873562E+02_dp, 1.3563319365162426E+04_dp, & @@ -5989,8 +5992,8 @@ CONTAINS -3.7066724475406403E+02_dp, 4.4339421427221095E+02_dp, -2.5185768559746347E+02_dp, & 3.0387188886435422E+02_dp, -4.1221355071839258E+02_dp, 3.9500349025307065E+02_dp, & -3.1942180687176204E+02_dp, 2.4606495659517455E+02_dp, -1.5690263401286234E+02_dp, & - 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.8663851312283325E+03_dp, & + 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.8663851312283325E+03_dp, & -1.0423380612707174E+03_dp, 1.5483806206375675E+03_dp, -9.0806872083263704E+02_dp, & 9.4017350130709883E+02_dp, -1.2957349086372242E+03_dp, 1.2616460034642841E+03_dp, & -9.6943667338306091E+02_dp, 7.0087846283955878E+02_dp, -4.4162263728305550E+02_dp, & @@ -6123,8 +6126,8 @@ CONTAINS 2.6878483032699012E+02_dp, 5.8309882443897629E+02_dp, 6.7807520171925752E-05_dp, & -3.0064117576976992E+02_dp, 3.6682509804999006E+02_dp, -3.7040717157728307E+02_dp, & 1.3406424149107912E+02_dp, 6.4428398410363116E+02_dp, -2.1519786183493156E+03_dp, & - 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp] - REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = [-2.7780629763055545E+03_dp, & + 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp/) + REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = (/-2.7780629763055545E+03_dp, & 7.2394748688135314E+02_dp, 1.4141872703259592E+03_dp, 1.9924393057961005E-04_dp, & -8.8514298674834572E+02_dp, 1.0799982553752052E+03_dp, -1.0299886964497700E+03_dp, & 2.4613962885626509E+02_dp, 2.1496502911088132E+03_dp, -6.6513723885247055E+03_dp, & @@ -6151,9 +6154,9 @@ CONTAINS 4.3939694879051335E+06_dp, 2.2270474259830317E+06_dp, -1.4748142024036435E+07_dp, & 2.4772021603756029E+07_dp, -2.0427694973111704E+07_dp, -5.1425641553283399E+06_dp, & 4.1035528362137891E+07_dp, -5.8536317653180525E+07_dp, 4.1604269769282125E+07_dp, & - -1.2580153353393231E+07_dp] + -1.2580153353393231E+07_dp/) REAL(KIND=dp), DIMENSION(13, 32, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 32, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 32, 5/)) INTEGER :: irange @@ -6200,7 +6203,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 34) :: fit_coef - REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = [1.8370815219029825E+05_dp, & + REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = (/1.8370815219029825E+05_dp, & -2.2571407833669311E+05_dp, 1.9425009817913763E+05_dp, -1.0472915274294355E+05_dp, & 2.6504347685948280E+04_dp, 4.7817002324082285E+04_dp, 2.5450661362359097E-02_dp, & -6.6225824542394374E+04_dp, 8.1048394804074065E+04_dp, -4.3435260565217926E+04_dp, & @@ -6284,8 +6287,8 @@ CONTAINS -5.8978754757524757E+06_dp, 7.2176798918735152E+06_dp, 3.1998615207433747E+06_dp, & -2.2851538821395889E+07_dp, 3.8978847055747673E+07_dp, -3.3766691905692071E+07_dp, & -3.6817494449235639E+06_dp, 5.8417659409558006E+07_dp, -8.7460434017794341E+07_dp, & - 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.3076079314075767E-01_dp, & + 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.3076079314075767E-01_dp, & -3.1204465976027999E-02_dp, -1.7122144125202067E-03_dp, 7.1244719472004776E-04_dp, & 9.7914036643084913E-05_dp, -1.6905608998459976E-05_dp, -7.4913349592830019E-05_dp, & 3.9524844540922514E-04_dp, -1.3207548101866621E-03_dp, 2.4893343556511901E-03_dp, & @@ -6418,8 +6421,8 @@ CONTAINS -7.2938082345320598E-01_dp, 1.1849370069427336E+00_dp, 3.0981138444088945E+01_dp, & -3.2826924199015650E+01_dp, 1.8061271201881183E+01_dp, -5.9402359654032049E+00_dp, & 1.0560336370860732E+00_dp, -1.3076665170325774E-03_dp, -9.1952845171647243E-02_dp, & - 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.2901998665259486E+00_dp, & + 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.2901998665259486E+00_dp, & -1.1234438324718303E+00_dp, 1.8249388295785653E+00_dp, 5.3052663877251987E+01_dp, & -5.6300287553126552E+01_dp, 3.1510803678504963E+01_dp, -1.0839542135686512E+01_dp, & 2.1894315183922908E+00_dp, -1.2602122478496375E-01_dp, -1.3889457312206924E-01_dp, & @@ -6552,8 +6555,8 @@ CONTAINS -2.5103650595979259E+00_dp, 4.0981205243496870E+00_dp, -1.9744886540859123E+00_dp, & 2.7900551212540414E-01_dp, 3.9609099066905094E-02_dp, 4.9480572244963817E+01_dp, & -1.0554295952164991E+02_dp, 9.7784802913758284E+01_dp, -3.3609900633466118E+01_dp, & - -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.8292295875978279E+00_dp, & + -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.8292295875978279E+00_dp, & -2.5859581635928466E+00_dp, 8.2643295812249669E+00_dp, -5.7320634779870945E+00_dp, & 1.7650956249120218E+00_dp, -1.9567508222089966E-01_dp, 7.7834138139689216E+01_dp, & -1.8267266020330240E+02_dp, 1.9349073152056008E+02_dp, -9.1481588588459843E+01_dp, & @@ -6686,8 +6689,8 @@ CONTAINS -2.8967923413102912E+00_dp, 1.3681886836307373E+00_dp, 1.3955776856915574E+00_dp, & -1.5897239290899864E-01_dp, -2.5212216600023445E+00_dp, 2.8219668706971945E+00_dp, & -1.3307700093912902E+00_dp, 2.4913514170866757E-01_dp, 3.6963550418790938E+01_dp, & - -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-6.7963494820353745E+00_dp, & + -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-6.7963494820353745E+00_dp, & -5.2037548606327730E+00_dp, 4.1015955423288375E+00_dp, 2.6719939603737344E+00_dp, & -2.0314435192987417E+00_dp, -3.5279015440942261E+00_dp, 5.3011832033957269E+00_dp, & -2.8122613024625087E+00_dp, 5.6915484145040629E-01_dp, 6.4926664043803811E+01_dp, & @@ -6820,8 +6823,8 @@ CONTAINS -8.6651521700026635E-01_dp, 4.9374292598778025E-01_dp, 3.4952603809371302E-01_dp, & -1.7396151407323862E-01_dp, -2.5934913691469813E-01_dp, 9.2007238929733004E-02_dp, & 3.3903391371774966E-01_dp, -4.2381412446029582E-01_dp, 2.1088118199107522E-01_dp, & - -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.2539604263036663E+00_dp, & + -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.2539604263036663E+00_dp, & -1.7332279212896191E+00_dp, 1.2863899425408518E+00_dp, 7.2978346101421798E-01_dp, & -5.0542068060802536E-01_dp, -5.6453129220842824E-01_dp, 2.6844891959416117E-01_dp, & 8.2065620557106000E-01_dp, -1.1421990003730462E+00_dp, 6.4148861901481036E-01_dp, & @@ -6954,8 +6957,8 @@ CONTAINS 1.8297112165331673E+04_dp, 2.0796368651156318E+00_dp, -7.1211773323306998E-02_dp, & -6.5222594833814318E-02_dp, 2.4758880150403027E-02_dp, -2.6172471480240402E-02_dp, & 4.2607134478414486E-02_dp, -4.9952200375915141E-02_dp, 5.1244059328384543E-02_dp, & - -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [1.0378429926308540E-02_dp, & + -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/1.0378429926308540E-02_dp, & -1.9521878957809889E-03_dp, 2.6944073713370376E+00_dp, -1.3634250253884062E-01_dp, & -1.2248962009310110E-01_dp, 5.1739894797576326E-02_dp, -4.9861795300424228E-02_dp, & 8.1764747263490686E-02_dp, -9.6628896510658951E-02_dp, 9.8409054684497427E-02_dp, & @@ -7088,9 +7091,9 @@ CONTAINS -6.0517025375512349E+04_dp, 5.4074356432769353E+04_dp, -3.0109150792826324E+04_dp, & 7.8344472467430223E+03_dp, 1.3254579477277694E+04_dp, 5.1532479271565908E-03_dp, & -1.3351228791461199E+04_dp, 1.6339623735533780E+04_dp, -1.2301930953556473E+04_dp, & - -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp] + -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp/) REAL(KIND=dp), DIMENSION(13, 34, 6), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07], [13, 34, 6]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07/), (/13, 34, 6/)) INTEGER :: irange @@ -7142,7 +7145,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 36) :: fit_coef - REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = [-4.2209902072425757E+02_dp, & + REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = (/-4.2209902072425757E+02_dp, & 1.1367036683435998E+02_dp, 2.4004100563047302E+02_dp, 2.6442809338541683E-05_dp, & -9.2920139462935452E+01_dp, 1.1857226657184384E+02_dp, -1.3712334751086243E+02_dp, & 8.9614212066663356E+01_dp, 1.2954531399327851E+02_dp, -6.1204117014894439E+02_dp, & @@ -7255,8 +7258,8 @@ CONTAINS 2.7482124839381648E+00_dp, -1.0319720350104814E+07_dp, 1.3167559540232308E+07_dp, & 5.3141307787938649E+06_dp, -4.2806172437992170E+07_dp, 7.7700737994820118E+07_dp, & -7.6880123309893116E+07_dp, 1.7343391064140473E+07_dp, 7.7860350009209916E+07_dp, & - -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8104907156518354E-01_dp, & + -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8104907156518354E-01_dp, & -6.1817005353024562E-02_dp, -1.5365071642354823E-02_dp, 9.1489217818269322E-03_dp, & 4.9967787273344161E-03_dp, -3.5367914652488903E-03_dp, -2.2075007488833458E-03_dp, & 1.2029276142200300E-03_dp, 2.8328851353903797E-03_dp, -3.4438772536686739E-03_dp, & @@ -7389,8 +7392,8 @@ CONTAINS 1.0488104966880156E+01_dp, -1.6444555466331974E+00_dp, 1.2763045722861104E+02_dp, & -3.2766564765272250E+02_dp, 3.7973217630740623E+02_dp, -1.9781100978811261E+02_dp, & -3.0157621574998899E+01_dp, 9.3237621383503154E+01_dp, -1.4664555123007290E+01_dp, & - -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-5.0683586321199940E+01_dp, & + -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-5.0683586321199940E+01_dp, & 2.2685614985361322E+01_dp, -4.0911306259362732E+00_dp, 2.0692715444769155E+02_dp, & -5.7784708851700361E+02_dp, 7.5313473849594516E+02_dp, -4.9591356082585395E+02_dp, & 4.6934746915158954E+01_dp, 1.7278593891248715E+02_dp, -7.9461883488471031E+01_dp, & @@ -7523,8 +7526,8 @@ CONTAINS 1.7192575597177209E-01_dp, -1.9796532433429683E+00_dp, 1.9593380309152029E+00_dp, & -8.5836023264597161E-01_dp, 1.5125817632192159E-01_dp, 3.3681131542986975E+01_dp, & -3.4585438137019239E+01_dp, 6.9509291872553263E+00_dp, 9.6987345107099117E+00_dp, & - -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.0123022827718544E+00_dp, & + -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.0123022827718544E+00_dp, & -5.8064769221536761E-01_dp, -3.3561931133425400E+00_dp, 3.9944119179735149E+00_dp, & -1.9296809249289084E+00_dp, 3.6684710023030970E-01_dp, 5.8314392583364203E+01_dp, & -6.9071915064420764E+01_dp, 2.0273316780786242E+01_dp, 1.8091276263426014E+01_dp, & @@ -7657,8 +7660,8 @@ CONTAINS -1.2172815962913154E-02_dp, -4.0308427219634048E-02_dp, 7.7287143244938123E-03_dp, & 4.0019771312533585E-02_dp, -3.7854821497454338E-02_dp, 1.0769335283667015E-02_dp, & 1.9476127553671263E-03_dp, -1.2801087884499606E-03_dp, 3.6694426304025538E+00_dp, & - -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [1.3124621600522313E-01_dp, & + -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/1.3124621600522313E-01_dp, & -4.3574928379419176E-02_dp, -8.9899230702256708E-02_dp, 2.4290637640954200E-02_dp, & 9.8569915866746516E-02_dp, -1.0636170473106374E-01_dp, 4.0918764154109298E-02_dp, & -1.9272580657675622E-03_dp, -1.9052149763963443E-03_dp, 5.9890800326505680E+00_dp, & @@ -7791,8 +7794,8 @@ CONTAINS -1.9257015318780568E+03_dp, 3.2472036360073544E+03_dp, -1.9642544031850207E+03_dp, & 1.8422466462758632E+03_dp, -2.5561629910519391E+03_dp, 2.5895289445906710E+03_dp, & -2.0116564542023402E+03_dp, 1.4283611462124322E+03_dp, -8.9489172870925711E+02_dp, & - 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.4073380941871266E+04_dp, & + 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.4073380941871266E+04_dp, & -5.4884212128021491E+03_dp, 1.3338114839397269E+04_dp, -9.1704389994968824E+03_dp, & 6.9234192947715492E+03_dp, -8.9848495511906458E+03_dp, 9.4904838722939803E+03_dp, & -7.0131996973248588E+03_dp, 4.2053129160131894E+03_dp, -2.2892321189981762E+03_dp, & @@ -7925,9 +7928,9 @@ CONTAINS 4.8018190809835360E+01_dp, 1.1735957000719010E+02_dp, 1.0796734300526574E-05_dp, & -3.7912420090540877E+01_dp, 4.8378813528148328E+01_dp, -5.7435863659353501E+01_dp, & 4.0377808851989506E+01_dp, 4.5658311276489918E+01_dp, -2.3911739347016501E+02_dp, & - 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp] + 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp/) REAL(KIND=dp), DIMENSION(13, 36, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 36, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 36, 5/)) INTEGER :: irange @@ -7974,7 +7977,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 38) :: fit_coef - REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = [1.0499223216920694E+01_dp, & + REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = (/1.0499223216920694E+01_dp, & 4.4951728164305678E+00_dp, -4.0844623976889828E+01_dp, 9.6469089733765301E+01_dp, & -1.4457308237433509E+02_dp, 1.4358591897299843E+02_dp, -8.6337055270254567E+01_dp, & 2.3772804326078404E+01_dp, 6.6359118115924133E+01_dp, -2.8591296818375736E-06_dp, & @@ -8029,8 +8032,8 @@ CONTAINS 2.1377543596431356E+07_dp, 7.5558560062402077E+06_dp, -6.6595246625963897E+07_dp, & 1.2300183044218574E+08_dp, -1.2663664724774376E+08_dp, 4.1031313200280927E+07_dp, & 1.0283971430652012E+08_dp, -1.9310895904024291E+08_dp, 1.5058167673706385E+08_dp, & - -4.7897275226966202E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4159553890012480E-01_dp, & + -4.7897275226966202E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4159553890012480E-01_dp, & -3.2212259532342614E-02_dp, -2.5211569112270739E-03_dp, 1.0259263161798598E-03_dp, & 1.7009451604343799E-04_dp, -7.4233588848268952E-05_dp, -1.4091849072407304E-05_dp, & 8.9792205912272354E-06_dp, -6.1068721080120308E-07_dp, 2.3673956901460579E-06_dp, & @@ -8163,8 +8166,8 @@ CONTAINS -9.8650715039269197E-04_dp, 8.4812423349403076E-04_dp, 1.9235334619586016E+01_dp, & -2.1430578544580889E+01_dp, 1.0935348023770239E+01_dp, -2.5703290931021043E+00_dp, & -9.3684439339661404E-02_dp, 1.9608483863631485E-01_dp, -1.2873315513389102E-02_dp, & - -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.1899012855183456E-04_dp, & + -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.1899012855183456E-04_dp, & -1.3697632531141069E-03_dp, 1.2268039489488590E-03_dp, 2.6982367118180953E+01_dp, & -3.2203467268313922E+01_dp, 1.8094671738936693E+01_dp, -5.1291575498824864E+00_dp, & 2.2721945369117036E-01_dp, 3.0848319451415068E-01_dp, -5.4944705448018556E-02_dp, & @@ -8297,8 +8300,8 @@ CONTAINS 3.2103644959620231E-02_dp, -1.4486824002301485E-01_dp, 1.2355203927413878E-01_dp, & -4.8092052541477776E-02_dp, 7.5259001655546970E-03_dp, 4.4383894095260246E+00_dp, & -3.5679718788094252E+00_dp, 5.1476908985660208E-01_dp, 8.0172648142794001E-01_dp, & - -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4079316176694362E-01_dp, & + -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4079316176694362E-01_dp, & 1.0204817722398823E-02_dp, -2.5165636141352937E-01_dp, 2.5091425850523480E-01_dp, & -1.0907652615992168E-01_dp, 1.8995561214566335E-02_dp, 6.6017064494743369E+00_dp, & -6.3396206574849705E+00_dp, 1.4645915581906761E+00_dp, 1.3567138102239846E+00_dp, & @@ -8431,8 +8434,8 @@ CONTAINS 4.7301818737714882E+02_dp, 1.3863635256023798E+02_dp, -2.1631236718932931E+02_dp, & -9.4803921196274686E+01_dp, 2.5426811844807858E+02_dp, -1.6576110763951490E+02_dp, & 4.7407189814529652E+01_dp, -4.5099294020295337E+00_dp, 2.9586882462973167E+03_dp, & - -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-9.1855299569510419E+02_dp, & + -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-9.1855299569510419E+02_dp, & 1.5086598025400613E+03_dp, -1.6982251398122094E+02_dp, -5.5006675710728985E+02_dp, & 8.6766882152744344E+01_dp, 4.7256010495026828E+02_dp, -4.6889366551390941E+02_dp, & 1.9581559031410015E+02_dp, -3.2716661828879559E+01_dp, 6.2548032409521911E+03_dp, & @@ -8565,8 +8568,8 @@ CONTAINS -5.9070868285783193E+00_dp, 7.0462234223485760E+00_dp, 2.3163307108458544E+00_dp, & -3.1353286429629565E+00_dp, -1.8613396596490337E+00_dp, 1.7553943424387961E+00_dp, & 3.1455571650317942E+00_dp, -5.5222826187397756E+00_dp, 3.6478129213769028E+00_dp, & - -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.3207068963149325E+01_dp, & + -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.3207068963149325E+01_dp, & -1.0554104925448858E+01_dp, 1.6886407464491334E+01_dp, 3.8180534827516577E+00_dp, & -7.9351781128404237E+00_dp, -3.3784899123822600E+00_dp, 4.6319521704833901E+00_dp, & 6.7239240450100590E+00_dp, -1.3642372104076109E+01_dp, 9.8589344031369794E+00_dp, & @@ -8699,8 +8702,8 @@ CONTAINS -2.0360724244160395E-04_dp, 7.8600093766184087E-01_dp, -2.7552722482330382E-02_dp, & -2.4320818015224920E-02_dp, 9.3274629486534248E-03_dp, -9.2079352354389778E-03_dp, & 1.5452692636155842E-02_dp, -1.8450575101340298E-02_dp, 1.9063757888167280E-02_dp, & - -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [4.0992188628857576E-03_dp, & + -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/4.0992188628857576E-03_dp, & -7.7827564716362676E-04_dp, 1.5427835617899610E+00_dp, -6.9505394993586406E-02_dp, & -6.0594885888198051E-02_dp, 2.4860739271249380E-02_dp, -2.3168221093078572E-02_dp, & 3.9027511015698728E-02_dp, -4.6867833756562442E-02_dp, 4.8230445510777237E-02_dp, & @@ -8833,8 +8836,8 @@ CONTAINS 5.4224742270029606E+02_dp, -3.5283793388597093E+02_dp, 1.4803941533425319E+02_dp, & -2.8871200173717554E+01_dp, 5.6772385530114016E+03_dp, -2.9062895360890998E+03_dp, & -1.7148517487548181E+03_dp, 2.2947989851698503E+03_dp, -1.3525758366401831E+03_dp, & - 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-1.8635835707916260E+03_dp, & + 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-1.8635835707916260E+03_dp, & 1.4615094004676805E+03_dp, -9.4860776301801513E+02_dp, 4.0324630910185732E+02_dp, & -7.9802696400978931E+01_dp, 1.4580340019039370E+04_dp, -8.9648221759975659E+03_dp, & -4.7160531127075310E+03_dp, 7.7970756952852253E+03_dp, -4.7953125668139064E+03_dp, & @@ -8967,9 +8970,9 @@ CONTAINS 1.6548760224475922E+00_dp, -1.7934154017551453E+01_dp, 4.3051248399276048E+01_dp, & -6.4961623842017133E+01_dp, 6.4774151275958900E+01_dp, -3.9049982184732009E+01_dp, & 1.0772159604979572E+01_dp, 3.5239797671962883E+01_dp, -1.2791831843911305E-06_dp, & - -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp] + -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp/) REAL(KIND=dp), DIMENSION(13, 38, 6), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 38, 6]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 38, 6/)) INTEGER :: irange @@ -9021,7 +9024,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 40) :: fit_coef - REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = [3.4482542694423209E+03_dp, & + REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = (/3.4482542694423209E+03_dp, & 9.3380638606834109E+03_dp, -3.6141948437832449E+04_dp, 7.3811576243227406E+04_dp, & -1.0360614380245237E+05_dp, 9.9273882530972987E+04_dp, -5.8503038150581720E+04_dp, & 1.5941507970166829E+04_dp, 1.9245609411100908E+04_dp, 1.5758311389454111E-03_dp, & @@ -9128,8 +9131,8 @@ CONTAINS 3.4369174208174527E+07_dp, 1.0603207649981629E+07_dp, -1.0297545596222048E+08_dp, & 1.9337680822524059E+08_dp, -2.0606965563558266E+08_dp, 8.3351497204227954E+07_dp, & 1.3400532965008634E+08_dp, -2.7949474181137478E+08_dp, 2.2551932538988832E+08_dp, & - -7.3358489823807165E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4818427186393188E-01_dp, & + -7.3358489823807165E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4818427186393188E-01_dp, & -3.9684125490741781E-02_dp, -4.5544691512272280E-03_dp, 2.2868531356116861E-03_dp, & 5.4988095348367525E-04_dp, -3.2090841260734175E-04_dp, -9.2010045248866118E-05_dp, & 6.1214638366653809E-05_dp, 2.2665438652455234E-05_dp, -1.8900573386763588E-05_dp, & @@ -9262,8 +9265,8 @@ CONTAINS -5.9740661993351847E-03_dp, 1.4691884865455198E-03_dp, 1.7073926981017319E+01_dp, & -2.1963630226832553E+01_dp, 1.2134829552891802E+01_dp, -2.2528424944623944E+00_dp, & -9.3240764730384440E-01_dp, 4.6660358949448766E-01_dp, 1.0216844176487623E-01_dp, & - -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [5.9915911031709962E-03_dp, & + -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/5.9915911031709962E-03_dp, & -8.6423694074923528E-03_dp, 2.4291300518560965E-03_dp, 2.4071366084770816E+01_dp, & -3.3716515170389293E+01_dp, 2.0906788438349480E+01_dp, -5.2492585742829574E+00_dp, & -1.0597221453010373E+00_dp, 9.1826115756590143E-01_dp, 5.3116568030487622E-02_dp, & @@ -9396,8 +9399,8 @@ CONTAINS 1.2466570600707088E-02_dp, -1.3874197741980808E-02_dp, 4.1907856070478042E-03_dp, & 7.5271368574731106E-04_dp, -5.1647877466666774E-04_dp, 1.7444005611942730E+00_dp, & -5.6824316669549102E-01_dp, -9.5567270387908632E-02_dp, 9.5953975937291464E-02_dp, & - 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4012464467116794E-02_dp, & + 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4012464467116794E-02_dp, & 1.7870937744543961E-02_dp, -2.8284778305657239E-02_dp, 1.4614940139686226E-02_dp, & -2.7014027690474133E-03_dp, -7.8952988099918739E-05_dp, 2.2522270551584125E+00_dp, & -9.9237513069804251E-01_dp, -7.1665511461607434E-02_dp, 1.9968203248776958E-01_dp, & @@ -9530,8 +9533,8 @@ CONTAINS -1.7263628579210469E+01_dp, 1.2547672408466081E+01_dp, 8.4591865266308197E+00_dp, & -5.6249151706448863E+00_dp, -1.1592672327907211E+01_dp, 1.6508808139297699E+01_dp, & -8.5771693846067460E+00_dp, 1.7125060439946929E+00_dp, 2.3966601282404417E+02_dp, & - -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-5.7499561390798192E+01_dp, & + -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-5.7499561390798192E+01_dp, & -2.8667295698939792E+01_dp, 3.3623712254987076E+01_dp, 1.4613232172192909E+01_dp, & -2.2425748408516260E+01_dp, -1.0625183610714041E+01_dp, 2.7811282349984850E+01_dp, & -1.6721270864181005E+01_dp, 3.6190172602275243E+00_dp, 4.3864077011236401E+02_dp, & @@ -9664,8 +9667,8 @@ CONTAINS -7.3049415971812165E-02_dp, 1.6928103093679515E-02_dp, 1.8417725387954376E-02_dp, & -1.9453592218161570E-03_dp, -1.1634328023640639E-02_dp, 3.4714019819061617E-03_dp, & 5.3490931351907831E-03_dp, -3.1907950343243647E-03_dp, -1.4616713023815479E-03_dp, & - 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-3.2389785098025670E-01_dp, & + 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-3.2389785098025670E-01_dp, & -1.5588421416935677E-01_dp, 4.6469218783312088E-02_dp, 4.1557942308222309E-02_dp, & -7.5142092188104671E-03_dp, -2.6806031107589168E-02_dp, 9.2275566818059377E-03_dp, & 1.3149892067901462E-02_dp, -9.4462212865469193E-03_dp, -1.9880182010796601E-03_dp, & @@ -9798,8 +9801,8 @@ CONTAINS 1.1110268324191310E+01_dp, 2.6853251507125306E+03_dp, -2.6690269182691513E+03_dp, & 7.2463711925762794E+01_dp, 1.2014230806845137E+03_dp, -2.9322356189139873E+02_dp, & -4.8871486180307096E+02_dp, 8.0189444854946785E+01_dp, 3.5253998447998373E+02_dp, & - -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [-2.2712994716763473E+02_dp, & + -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/-2.2712994716763473E+02_dp, & 4.0385181038065113E+01_dp, 6.0197819306524152E+03_dp, -6.9664015206915119E+03_dp, & 8.8000828312450119E+02_dp, 3.2181044508507798E+03_dp, -1.3451011011345620E+03_dp, & -1.2427951210535916E+03_dp, 5.4994829125785282E+02_dp, 9.7855377199584927E+02_dp, & @@ -9932,8 +9935,8 @@ CONTAINS 1.6768202331832444E-01_dp, -1.0515504828494937E-01_dp, 4.2563447502959498E-02_dp, & -8.2219895159869709E-03_dp, 9.5923398264069970E+00_dp, -9.1351432511338171E-01_dp, & -7.2002060302993121E-01_dp, 3.4478262562537942E-01_dp, -2.6236445928893765E-01_dp, & - 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-4.3224032563729953E-01_dp, & + 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-4.3224032563729953E-01_dp, & 3.5758483946236974E-01_dp, -2.2431923396808751E-01_dp, 9.0777959192790053E-02_dp, & -1.7518061809443625E-02_dp, 1.6725498665042689E+01_dp, -1.9435939058523524E+00_dp, & -1.5082483802542699E+00_dp, 7.7123067496772879E-01_dp, -5.6050187357065773E-01_dp, & @@ -10066,9 +10069,9 @@ CONTAINS 2.5970516090366850E+03_dp, -1.1583854023864891E+04_dp, 2.4553873694398699E+04_dp, & -3.5160886963347439E+04_dp, 3.4138635891960170E+04_dp, -2.0309554368209294E+04_dp, & 5.5733463618645619E+03_dp, 7.3092031064017010E+03_dp, 4.9005183646288716E-04_dp, & - -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp] + -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp/) REAL(KIND=dp), DIMENSION(13, 40, 6), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 40, 6]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 40, 6/)) INTEGER :: irange @@ -10163,7 +10166,7 @@ CONTAINS E_ratio = 1.0_dp END IF aw(:) = aw(:)/E_ratio - END SUBROUTINE rescale_grid + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -10181,7 +10184,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 799.0_dp) THEN E_ratio = 799.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13642311899920728_dp, & 0.4200545572769177_dp, & 0.7370807753440111_dp, & @@ -10233,9 +10236,9 @@ CONTAINS 175.19453971323657_dp, & 301.19411259128674_dp, & 645.6383267719649_dp, & - 2472.504957810595_dp] + 2472.504957810595_dp/) ELSE IF (E_range < 995.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13925292153649474_dp, & 0.4292451559612877_dp, & 0.7548554587233549_dp, & @@ -10287,9 +10290,9 @@ CONTAINS 211.68822580031673_dp, & 364.5832859080767_dp, & 780.7919711700442_dp, & - 2983.4784258039044_dp] + 2983.4784258039044_dp/) ELSE IF (E_range < 1293.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14255313239112444_dp, & 0.44000221057671707_dp, & 0.7757923584694003_dp, & @@ -10341,9 +10344,9 @@ CONTAINS 265.33605383413214_dp, & 458.1910477032067_dp, & 980.4158381921823_dp, & - 3736.258588894085_dp] + 3736.258588894085_dp/) ELSE IF (E_range < 1738.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1461752355773306_dp, & 0.45185762356828396_dp, & 0.7990360544025357_dp, & @@ -10395,9 +10398,9 @@ CONTAINS 342.31559687568875_dp, & 593.3221880856304_dp, & 1268.7961696472178_dp, & - 4820.528614472729_dp] + 4820.528614472729_dp/) ELSE IF (E_range < 2238.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1491837006061548_dp, & 0.46174475862674996_dp, & 0.8185592742668346_dp, & @@ -10449,9 +10452,9 @@ CONTAINS 425.4335136047249_dp, & 740.2128400786926_dp, & 1582.657563073928_dp, & - 5997.255668095278_dp] + 5997.255668095278_dp/) ELSE IF (E_range < 3009.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15260234927102537_dp, & 0.47302539641929003_dp, & 0.840991102837249_dp, & @@ -10503,9 +10506,9 @@ CONTAINS 548.3643432689413_dp, & 959.1555990081102_dp, & 2051.35284281865_dp, & - 7749.544195896773_dp] + 7749.544195896773_dp/) ELSE IF (E_range < 4377.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15677016271388225_dp, & 0.4868453590049744_dp, & 0.8687054372436632_dp, & @@ -10557,9 +10560,9 @@ CONTAINS 755.1838770980437_dp, & 1331.5355795873638_dp, & 2851.124163900499_dp, & - 10729.678598478598_dp] + 10729.678598478598_dp/) ELSE IF (E_range < 6256.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16057542542593983_dp, & 0.49952962028824754_dp, & 0.8943731123892699_dp, & @@ -10611,9 +10614,9 @@ CONTAINS 1022.6891506041642_dp, & 1819.6861630933722_dp, & 3904.600906393468_dp, & - 14642.034530501202_dp] + 14642.034530501202_dp/) ELSE IF (E_range < 9034.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16432089011213946_dp, & 0.5120783448939726_dp, & 0.9199886972681118_dp, & @@ -10665,9 +10668,9 @@ CONTAINS 1393.996082618058_dp, & 2507.6502273684464_dp, & 5398.730047404666_dp, & - 20174.243482162154_dp] + 20174.243482162154_dp/) ELSE IF (E_range < 15564.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16955168876185606_dp, & 0.5297128492681893_dp, & 0.9563682595025127_dp, & @@ -10719,9 +10722,9 @@ CONTAINS 2193.7537015644107_dp, & 4023.287609783773_dp, & 8726.293698066565_dp, & - 32456.229019326278_dp] + 32456.229019326278_dp/) ELSE IF (E_range < 19500.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17161078656390408_dp, & 0.5366905364814994_dp, & 0.97088881076514_dp, & @@ -10773,9 +10776,9 @@ CONTAINS 2641.8070030495096_dp, & 4889.503800534578_dp, & 10648.322208945656_dp, & - 39537.49857015622_dp] + 39537.49857015622_dp/) ELSE IF (E_range < 22300.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1728061198835349_dp, & 0.5407506981101403_dp, & 0.9793714038026303_dp, & @@ -10827,9 +10830,9 @@ CONTAINS 2948.8741403686568_dp, & 5489.390378606207_dp, & 11987.379922744534_dp, & - 44468.08958434164_dp] + 44468.08958434164_dp/) ELSE IF (E_range < 24783.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1737308948597355_dp, & 0.5438966877521114_dp, & 0.9859610380912929_dp, & @@ -10881,9 +10884,9 @@ CONTAINS 3214.1964330189876_dp, & 6011.5393853613305_dp, & 13158.00196550311_dp, & - 48777.36298097777_dp] + 48777.36298097777_dp/) ELSE IF (E_range < 41198.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17799130240706984_dp, & 0.558445410809649_dp, & 1.0166297309491044_dp, & @@ -10935,9 +10938,9 @@ CONTAINS 4842.950527196566_dp, & 9285.588160319077_dp, & 20597.325965171356_dp, & - 76161.8596274348_dp] + 76161.8596274348_dp/) ELSE IF (E_range < 94407.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18427327646299554_dp, & 0.5800678142111884_dp, & 1.062813174396542_dp, & @@ -10989,9 +10992,9 @@ CONTAINS 9266.732583950343_dp, & 18647.213606093355_dp, & 42656.46566405554_dp, & - 157660.6216097217_dp] + 157660.6216097217_dp/) ELSE IF (E_range < 189080.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1889166187549335_dp, & 0.5961850834729495_dp, & 1.097718788260886_dp, & @@ -11043,9 +11046,9 @@ CONTAINS 15593.849284273198_dp, & 32917.0364973997_dp, & 78051.06376348506_dp, & - 289942.76429117593_dp] + 289942.76429117593_dp/) ELSE IF (E_range < 457444.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.194043824675455_dp, & 0.6141201650984125_dp, & 1.137056339966442_dp, & @@ -11097,9 +11100,9 @@ CONTAINS 29125.998944110084_dp, & 65928.95446339808_dp, & 166172.86831676983_dp, & - 628359.6031461136_dp] + 628359.6031461136_dp/) ELSE IF (E_range < 2101965.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.20097761439605452_dp, & 0.6386142361636943_dp, & 1.1916436123207983_dp, & @@ -11151,9 +11154,9 @@ CONTAINS 75639.29476513214_dp, & 196582.0757874882_dp, & 575257.5915715584_dp, & - 2362446.5347060743_dp] + 2362446.5347060743_dp/) ELSE IF (E_range < 14140999.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.20658002404396444_dp, & 0.6586140986839257_dp, & 1.2369737792708104_dp, & @@ -11205,9 +11208,9 @@ CONTAINS 186203.45469776812_dp, & 576894.7309753906_dp, & 2152261.8479348915_dp, & - 11566361.80487531_dp] + 11566361.80487531_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.20878089337233605_dp, & 0.6665236543193817_dp, & 1.2550931614146674_dp, & @@ -11259,9 +11262,9 @@ CONTAINS 277390.3096379278_dp, & 946568.3924295901_dp, & 4140822.150621181_dp, & - 30376446.323901277_dp] + 30376446.323901277_dp/) END IF - END SUBROUTINE get_coeff_26 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -11279,7 +11282,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 1545.0_dp) THEN E_ratio = 1545.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13575757270404953_dp, & 0.4178973639556045_dp, & 0.7329236428021971_dp, & @@ -11335,9 +11338,9 @@ CONTAINS 333.52874619054023_dp, & 573.9031161499247_dp, & 1229.5973040920514_dp, & - 4703.444164101694_dp] + 4703.444164101694_dp/) ELSE IF (E_range < 2002.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13875490228933057_dp, & 0.4276255171652803_dp, & 0.7517156037290086_dp, & @@ -11393,9 +11396,9 @@ CONTAINS 417.7474719630637_dp, & 720.4456660885186_dp, & 1542.1360738637661_dp, & - 5884.200372654236_dp] + 5884.200372654236_dp/) ELSE IF (E_range < 2600.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14170133198228974_dp, & 0.4372217263238123_dp, & 0.7703667410153948_dp, & @@ -11451,9 +11454,9 @@ CONTAINS 524.1575321727823_dp, & 906.5045080905089_dp, & 1939.0883159241562_dp, & - 7379.912745615771_dp] + 7379.912745615771_dp/) ELSE IF (E_range < 3300.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1443213439813841_dp, & 0.4457831750819166_dp, & 0.7871040955754438_dp, & @@ -11509,9 +11512,9 @@ CONTAINS 644.5187891323013_dp, & 1118.0760747835973_dp, & 2390.794104288915_dp, & - 9077.664025334678_dp] + 9077.664025334678_dp/) ELSE IF (E_range < 4000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14638817647917096_dp, & 0.4525562304919969_dp, & 0.8004113661058508_dp, & @@ -11567,9 +11570,9 @@ CONTAINS 761.3056079394062_dp, & 1324.411398249371_dp, & 2831.738972704671_dp, & - 10731.431828374814_dp] + 10731.431828374814_dp/) ELSE IF (E_range < 5000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14873276811274175_dp, & 0.4602604435552678_dp, & 0.8156202251610892_dp, & @@ -11625,9 +11628,9 @@ CONTAINS 923.1971063861915_dp, & 1612.0060664213056_dp, & 3447.1144071775916_dp, & - 13034.665823606138_dp] + 13034.665823606138_dp/) ELSE IF (E_range < 5800.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1502608626762777_dp, & 0.46529381929136415_dp, & 0.8255984287192656_dp, & @@ -11683,9 +11686,9 @@ CONTAINS 1049.2452864243335_dp, & 1837.0994387864066_dp, & 3929.4241467171732_dp, & - 14836.654624922767_dp] + 14836.654624922767_dp/) ELSE IF (E_range < 7000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15216067096721872_dp, & 0.471565223326128_dp, & 0.8380780093696487_dp, & @@ -11741,9 +11744,9 @@ CONTAINS 1233.5478315642981_dp, & 2167.935258865102_dp, & 4639.411026254049_dp, & - 17485.041970829057_dp] + 17485.041970829057_dp/) ELSE IF (E_range < 8500.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1540799216139811_dp, & 0.47791627634651673_dp, & 0.850769563354445_dp, & @@ -11799,9 +11802,9 @@ CONTAINS 1457.1994566202313_dp, & 2571.939694554795_dp, & 5508.2172091289185_dp, & - 20720.162172438253_dp] + 20720.162172438253_dp/) ELSE IF (E_range < 11000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15656226451877622_dp, & 0.4861541997731515_dp, & 0.8673131850431656_dp, & @@ -11857,9 +11860,9 @@ CONTAINS 1816.6489638049509_dp, & 3226.5521973584873_dp, & 6920.118346610322_dp, & - 25967.01374573565_dp] + 25967.01374573565_dp/) ELSE IF (E_range < 14000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15881564616129193_dp, & 0.4936556598653273_dp, & 0.8824588841815081_dp, & @@ -11915,9 +11918,9 @@ CONTAINS 2230.6304097502575_dp, & 3987.780431784136_dp, & 8568.294988757902_dp, & - 32079.26783423429_dp] + 32079.26783423429_dp/) ELSE IF (E_range < 18000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1610939781339949_dp, & 0.5012631407780889_dp, & 0.8978984268667602_dp, & @@ -11973,9 +11976,9 @@ CONTAINS 2759.7196504068343_dp, & 4970.842422998521_dp, & 10706.437123051388_dp, & - 39993.678157447954_dp] + 39993.678157447954_dp/) ELSE IF (E_range < 22000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16286202517738316_dp, & 0.5071829401058993_dp, & 0.9099691167949224_dp, & @@ -12031,9 +12034,9 @@ CONTAINS 3268.0690080523195_dp, & 5925.0502577809875_dp, & 12791.74491637296_dp, & - 47700.6553314684_dp] + 47700.6553314684_dp/) ELSE IF (E_range < 30000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16550588765942553_dp, & 0.516062009336416_dp, & 0.9281674926129342_dp, & @@ -12089,9 +12092,9 @@ CONTAINS 4236.78509184323_dp, & 7766.730019457065_dp, & 16842.450828736164_dp, & - 62648.76273159001_dp] + 62648.76273159001_dp/) ELSE IF (E_range < 40000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1678624984386396_dp, & 0.5240039277065677_dp, & 0.9445413343768262_dp, & @@ -12147,9 +12150,9 @@ CONTAINS 5379.192173747507_dp, & 9973.306180469173_dp, & 21737.4521360814_dp, & - 80688.08263620315_dp] + 80688.08263620315_dp/) ELSE IF (E_range < 55000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17036496307430077_dp, & 0.5324663182632273_dp, & 0.9620895318113227_dp, & @@ -12205,9 +12208,9 @@ CONTAINS 6988.303443289154_dp, & 13136.528535241805_dp, & 28826.90535778617_dp, & - 106792.5668680263_dp] + 106792.5668680263_dp/) ELSE IF (E_range < 75000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17269556592412857_dp, & 0.5403748964029321_dp, & 0.9785852679690707_dp, & @@ -12263,9 +12266,9 @@ CONTAINS 8991.001468037319_dp, & 17151.64888313862_dp, & 37936.68288424044_dp, & - 140330.3757792011_dp] + 140330.3757792011_dp/) ELSE IF (E_range < 100000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17476493191141415_dp, & 0.5474193940515534_dp, & 0.9933573948794411_dp, & @@ -12321,9 +12324,9 @@ CONTAINS 11326.739601304256_dp, & 21929.575378095506_dp, & 48923.087093047834_dp, & - 180801.94440922138_dp] + 180801.94440922138_dp/) ELSE IF (E_range < 140000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17707349703529857_dp, & 0.5553034658173043_dp, & 1.0099791730991756_dp, & @@ -12379,9 +12382,9 @@ CONTAINS 14783.538737749648_dp, & 29163.479733223845_dp, & 65827.4645722146_dp, & - 243179.26518144744_dp] + 243179.26518144744_dp/) ELSE IF (E_range < 200000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17939121623291196_dp, & 0.5632460962554191_dp, & 1.0268207360191903_dp, & @@ -12437,9 +12440,9 @@ CONTAINS 19511.673781213012_dp, & 39328.72129742758_dp, & 90071.79118231079_dp, & - 332938.41349157074_dp] + 332938.41349157074_dp/) ELSE IF (E_range < 280000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18145787532761345_dp, & 0.5703516980411364_dp, & 1.041969987100468_dp, & @@ -12495,9 +12498,9 @@ CONTAINS 25223.35236302233_dp, & 51966.7592745666_dp, & 120920.32428947231_dp, & - 447736.17541344964_dp] + 447736.17541344964_dp/) ELSE IF (E_range < 400000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18352365749998711_dp, & 0.5774767415391759_dp, & 1.0572402465072317_dp, & @@ -12553,9 +12556,9 @@ CONTAINS 32921.61554906603_dp, & 69533.14758216766_dp, & 164947.39394785516_dp, & - 612800.2731138045_dp] + 612800.2731138045_dp/) ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1865127174002091_dp, & 0.5878264119237888_dp, & 1.0795642254870847_dp, & @@ -12611,9 +12614,9 @@ CONTAINS 49336.106221828624_dp, & 108694.3328979675_dp, & 267237.7291173849_dp, & - 1002021.1700926761_dp] + 1002021.1700926761_dp/) ELSE IF (E_range < 1200000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18910898992309827_dp, & 0.5968553778314455_dp, & 1.099179600396227_dp, & @@ -12669,9 +12672,9 @@ CONTAINS 71590.44785506214_dp, & 164831.2803483035_dp, & 422312.83970923733_dp, & - 1607194.846517409_dp] + 1607194.846517409_dp/) ELSE IF (E_range < 2000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19132297837375925_dp, & 0.6045842212401715_dp, & 1.116075239909931_dp, & @@ -12727,9 +12730,9 @@ CONTAINS 100098.51304747425_dp, & 240936.64519318528_dp, & 645993.0255202315_dp, & - 2511145.760363479_dp] + 2511145.760363479_dp/) ELSE IF (E_range < 4500000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19436594608582472_dp, & 0.6152519388154075_dp, & 1.1395565637382394_dp, & @@ -12785,9 +12788,9 @@ CONTAINS 163720.9776403595_dp, & 424479.54068993696_dp, & 1238540.16298379_dp, & - 5075528.538071685_dp] + 5075528.538071685_dp/) ELSE IF (E_range < 10000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19682681061058516_dp, & 0.6239175967168831_dp, & 1.1587697829037367_dp, & @@ -12843,9 +12846,9 @@ CONTAINS 251532.47511127745_dp, & 702946.2892638468_dp, & 2257925.6950304266_dp, & - 10050972.42119658_dp] + 10050972.42119658_dp/) ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.20028753559878754_dp, & 0.636163845466183_dp, & 1.1861370761903154_dp, & @@ -12901,9 +12904,9 @@ CONTAINS 488713.1004068534_dp, & 1569108.161138_dp, & 6194788.779558858_dp, & - 36612022.104547605_dp] + 36612022.104547605_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.20148359962188625_dp, & 0.6404126846191118_dp, & 1.1956914499421463_dp, & @@ -12959,9 +12962,9 @@ CONTAINS 627349.5338890508_dp, & 2140772.611660053_dp, & 9364952.860952146_dp, & - 68700022.28914484_dp] + 68700022.28914484_dp/) END IF - END SUBROUTINE get_coeff_28 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -12980,7 +12983,7 @@ CONTAINS IF (E_range < 2906.0_dp) THEN E_ratio = 2906.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13472077973006066_dp, & 0.41454012407362284_dp, & 0.7264650127115554_dp, & @@ -13040,9 +13043,9 @@ CONTAINS 619.9912456625073_dp, & 1067.5959324975324_dp, & 2286.544806677275_dp, & - 8738.901002766614_dp] + 8738.901002766614_dp/) ELSE IF (E_range < 3236.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13585569926755156_dp, & 0.41821529920891193_dp, & 0.7335359382994969_dp, & @@ -13102,9 +13105,9 @@ CONTAINS 681.1401603164769_dp, & 1173.9561106510982_dp, & 2513.427330670278_dp, & - 9596.45252078042_dp] + 9596.45252078042_dp/) ELSE IF (E_range < 3810.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1375558839742156_dp, & 0.4237299246561157_dp, & 0.7441765936480988_dp, & @@ -13164,9 +13167,9 @@ CONTAINS 785.6426382482606_dp, & 1356.1465778665718_dp, & 2902.1064912290262_dp, & - 11063.595563099649_dp] + 11063.595563099649_dp/) ELSE IF (E_range < 4405.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13904406912216055_dp, & 0.4285658262322887_dp, & 0.7535381269110286_dp, & @@ -13226,9 +13229,9 @@ CONTAINS 891.8325474154066_dp, & 1541.8004917177743_dp, & 3298.2637895129933_dp, & - 12556.72637834854_dp] + 12556.72637834854_dp/) ELSE IF (E_range < 5400.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1410960680209205_dp, & 0.43524771510986004_dp, & 0.7665207024486466_dp, & @@ -13288,9 +13291,9 @@ CONTAINS 1065.3146704916662_dp, & 1846.16967438266_dp, & 3948.0236905716197_dp, & - 15001.510222225108_dp] + 15001.510222225108_dp/) ELSE IF (E_range < 6800.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1433674220737173_dp, & 0.4426628898148459_dp, & 0.7809932553639084_dp, & @@ -13350,9 +13353,9 @@ CONTAINS 1302.3421015152915_dp, & 2264.016465253404_dp, & 4840.7455216590715_dp, & - 18353.395351716823_dp] + 18353.395351716823_dp/) ELSE IF (E_range < 8400.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14540131106958792_dp, & 0.4493201231807535_dp, & 0.7940459513320671_dp, & @@ -13412,9 +13415,9 @@ CONTAINS 1565.1330028308446_dp, & 2729.7495636084445_dp, & 5836.893913938098_dp, & - 22085.748007810864_dp] + 22085.748007810864_dp/) ELSE IF (E_range < 10000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14704498509396693_dp, & 0.4547122051327194_dp, & 0.8046596707087634_dp, & @@ -13474,9 +13477,9 @@ CONTAINS 1820.9007070932764_dp, & 3185.3327939434785_dp, & 6812.567149441103_dp, & - 25734.79348292465_dp] + 25734.79348292465_dp/) ELSE IF (E_range < 12000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14873028953425532_dp, & 0.46025228447257244_dp, & 0.815604068464183_dp, & @@ -13536,9 +13539,9 @@ CONTAINS 2132.484724545273_dp, & 3743.164994620193_dp, & 8008.935958082978_dp, & - 30201.87390773344_dp] + 30201.87390773344_dp/) ELSE IF (E_range < 15000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15074658869167354_dp, & 0.4668958035836203_dp, & 0.8287813045866178_dp, & @@ -13598,9 +13601,9 @@ CONTAINS 2585.9493214732233_dp, & 4560.104639212192_dp, & 9764.47140618184_dp, & - 36744.78826999934_dp] + 36744.78826999934_dp/) ELSE IF (E_range < 20000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15327074211168326_dp, & 0.47523666558201105_dp, & 0.8454081293698346_dp, & @@ -13660,9 +13663,9 @@ CONTAINS 3312.4890760215126_dp, & 5880.358930845362_dp, & 12610.246229383727_dp, & - 47327.426186591925_dp] + 47327.426186591925_dp/) ELSE IF (E_range < 28000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15611582449200168_dp, & 0.484670676531795_dp, & 0.864327133672447_dp, & @@ -13722,9 +13725,9 @@ CONTAINS 4418.177298699454_dp, & 7913.127380453787_dp, & 17012.044780129974_dp, & - 63654.92138377425_dp] + 63654.92138377425_dp/) ELSE IF (E_range < 38000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1585986414808211_dp, & 0.49293227874864953_dp, & 0.8809949627642996_dp, & @@ -13784,9 +13787,9 @@ CONTAINS 5728.411572233089_dp, & 10353.785071731596_dp, & 22327.676016416055_dp, & - 83326.1396670659_dp] + 83326.1396670659_dp/) ELSE IF (E_range < 50000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16074983925508995_dp, & 0.5001125329781305_dp, & 0.895558007331798_dp, & @@ -13846,9 +13849,9 @@ CONTAINS 7222.917612404246_dp, & 13174.2778180717_dp, & 28509.267725054422_dp, & - 106160.2639173599_dp] + 106160.2639173599_dp/) ELSE IF (E_range < 64000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16262039381403579_dp, & 0.5063730793021797_dp, & 0.9083149017898943_dp, & @@ -13908,9 +13911,9 @@ CONTAINS 8885.07671917959_dp, & 16351.40165928286_dp, & 35518.56312434257_dp, & - 132016.67889946306_dp] + 132016.67889946306_dp/) ELSE IF (E_range < 84000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16461121992013572_dp, & 0.5130537467027886_dp, & 0.9219891409850267_dp, & @@ -13970,9 +13973,9 @@ CONTAINS 11143.129516033901_dp, & 20727.354533996564_dp, & 45246.467731381585_dp, & - 167864.82966862986_dp] + 167864.82966862986_dp/) ELSE IF (E_range < 110000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16651351865477473_dp, & 0.519454577907408_dp, & 0.9351507515667731_dp, & @@ -14032,9 +14035,9 @@ CONTAINS 13921.767968244894_dp, & 26195.561124088643_dp, & 57512.80156760765_dp, & - 213037.54770361463_dp] + 213037.54770361463_dp/) ELSE IF (E_range < 160000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1690396225959909_dp, & 0.527980783630836_dp, & 0.9527749551685267_dp, & @@ -14094,9 +14097,9 @@ CONTAINS 18902.03087469423_dp, & 36195.04534310194_dp, & 80228.85952678222_dp, & - 296685.58400527935_dp] + 296685.58400527935_dp/) ELSE IF (E_range < 220000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17108080746256005_dp, & 0.5348926066785868_dp, & 0.9671403722271738_dp, & @@ -14156,9 +14159,9 @@ CONTAINS 24425.382905474227_dp, & 47540.939727448866_dp, & 106401.9838008185_dp, & - 393145.5653859997_dp] + 393145.5653859997_dp/) ELSE IF (E_range < 370000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.174208015078396_dp, & 0.5455214527091232_dp, & 0.9893700986809595_dp, & @@ -14218,9 +14221,9 @@ CONTAINS 36827.67063798521_dp, & 73825.92204301585_dp, & 168436.45444117606_dp, & - 622444.873239739_dp] + 622444.873239739_dp/) ELSE IF (E_range < 520000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1761202582043389_dp, & 0.5520447609872519_dp, & 1.0030974507555772_dp, & @@ -14280,9 +14283,9 @@ CONTAINS 47901.44750228873_dp, & 98085.01445426073_dp, & 227192.3617986822_dp, & - 840731.2172617969_dp] + 840731.2172617969_dp/) ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1777047921517639_dp, & 0.5574641492548221_dp, & 1.0145511230139452_dp, & @@ -14342,9 +14345,9 @@ CONTAINS 60011.99599547493_dp, & 125336.8664775516_dp, & 294698.3519483209_dp, & - 1092989.8333233916_dp] + 1092989.8333233916_dp/) ELSE IF (E_range < 1100000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1799647702096782_dp, & 0.5652158330702483_dp, & 1.0310122635781176_dp, & @@ -14404,9 +14407,9 @@ CONTAINS 83848.098471279_dp, & 180849.87459593892_dp, & 436512.7424947387_dp, & - 1628215.5545881148_dp] + 1628215.5545881148_dp/) ELSE IF (E_range < 1800000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1822263529525982_dp, & 0.5729996377421059_dp, & 1.047635792810745_dp, & @@ -14466,9 +14469,9 @@ CONTAINS 119209.6009779448_dp, & 267043.87988619285_dp, & 666555.4805450162_dp, & - 2511681.1233505663_dp] + 2511681.1233505663_dp/) ELSE IF (E_range < 3300000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1847328901237733_dp, & 0.5816579181920506_dp, & 1.06623831659397_dp, & @@ -14528,9 +14531,9 @@ CONTAINS 180141.95260617262_dp, & 424305.6328571203_dp, & 1112162.6633453001_dp, & - 4275158.808925236_dp] + 4275158.808925236_dp/) ELSE IF (E_range < 6000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18691650786522696_dp, & 0.5892282516421157_dp, & 1.082601142199495_dp, & @@ -14590,9 +14593,9 @@ CONTAINS 264080.7768830504_dp, & 655640.4058250692_dp, & 1818602.1997626221_dp, & - 7205611.5064693205_dp] + 7205611.5064693205_dp/) ELSE IF (E_range < 18000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19022370155321527_dp, & 0.600743360402157_dp, & 1.1076668599949147_dp, & @@ -14652,9 +14655,9 @@ CONTAINS 494979.5222323457_dp, & 1359946.1830275727_dp, & 4269995.133188314_dp, & - 18594665.56920044_dp] + 18594665.56920044_dp/) ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19253210390672987_dp, & 0.6088167991143922_dp, & 1.1253694421581641_dp, & @@ -14714,9 +14717,9 @@ CONTAINS 801312.2270425739_dp, & 2415145.5599759216_dp, & 8639654.807896439_dp, & - 43666635.56753933_dp] + 43666635.56753933_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.1949107095730563_dp, & 0.6171672239307736_dp, & 1.143792172436484_dp, & @@ -14776,9 +14779,9 @@ CONTAINS 1380639.0831843547_dp, & 4711303.6808049455_dp, & 20609904.76278654_dp, & - 151191206.84136662_dp] + 151191206.84136662_dp/) END IF - END SUBROUTINE get_coeff_30 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -14796,7 +14799,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 4862.0_dp) THEN E_ratio = 4862.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13254275519610229_dp, & 0.4075002434334006_dp, & 0.7129653611128071_dp, & @@ -14860,9 +14863,9 @@ CONTAINS 1039.6543728256195_dp, & 1789.9748349736915_dp, & 3833.9681364720745_dp, & - 14655.44632366239_dp] + 14655.44632366239_dp/) ELSE IF (E_range < 5846.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1343248849882633_dp, & 0.4132592119099152_dp, & 0.7240043390799359_dp, & @@ -14926,9 +14929,9 @@ CONTAINS 1222.611932252175_dp, & 2108.162233431274_dp, & 4512.831122628449_dp, & - 17222.120678400817_dp] + 17222.120678400817_dp/) ELSE IF (E_range < 6665.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13557338601660668_dp, & 0.41730065260389615_dp, & 0.7317746815552322_dp, & @@ -14992,9 +14995,9 @@ CONTAINS 1371.947991018934_dp, & 2368.536327804507_dp, & 5068.399861166353_dp, & - 19319.551508880766_dp] + 19319.551508880766_dp/) ELSE IF (E_range < 7800.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1370499857872464_dp, & 0.422087838650514_dp, & 0.7410040914005517_dp, & @@ -15058,9 +15061,9 @@ CONTAINS 1575.1576866889702_dp, & 2723.745097867967_dp, & 5826.475195617796_dp, & - 22177.608473258828_dp] + 22177.608473258828_dp/) ELSE IF (E_range < 10044.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1393751435556022_dp, & 0.4296428076126454_dp, & 0.7556269118458908_dp, & @@ -15124,9 +15127,9 @@ CONTAINS 1966.3786822155184_dp, & 3410.3262356194664_dp, & 7292.46886903304_dp, & - 27693.855354838164_dp] + 27693.855354838164_dp/) ELSE IF (E_range < 14058.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14237486453944107_dp, & 0.4394200534952092_dp, & 0.7746555330683098_dp, & @@ -15190,9 +15193,9 @@ CONTAINS 2639.3168711629464_dp, & 4598.936377351543_dp, & 9833.306219117254_dp, & - 37228.01191754706_dp] + 37228.01191754706_dp/) ELSE IF (E_range < 19114.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14502370796551703_dp, & 0.4480829010539378_dp, & 0.7916157981286331_dp, & @@ -15256,9 +15259,9 @@ CONTAINS 3450.91828637881_dp, & 6043.794023233803_dp, & 12927.644737686549_dp, & - 48805.08862191054_dp] + 48805.08862191054_dp/) ELSE IF (E_range < 25870.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14754727473790832_dp, & 0.4563621690490255_dp, & 0.8079150128057052_dp, & @@ -15322,9 +15325,9 @@ CONTAINS 4489.970449108518_dp, & 7909.344598672393_dp, & 16932.78473977757_dp, & - 63749.23270457554_dp] + 63749.23270457554_dp/) ELSE IF (E_range < 35180.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15002348519433922_dp, & 0.46451130342750646_dp, & 0.824045021042684_dp, & @@ -15388,9 +15391,9 @@ CONTAINS 5859.209649832797_dp, & 10391.307380953114_dp, & 22278.529118569048_dp, & - 83643.6346001724_dp] + 83643.6346001724_dp/) ELSE IF (E_range < 58986.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15399032986872938_dp, & 0.4776194738561411_dp, & 0.8501753043803365_dp, & @@ -15454,9 +15457,9 @@ CONTAINS 9137.412009720016_dp, & 16424.470778988587_dp, & 35351.12874442453_dp, & - 132131.62635064372_dp] + 132131.62635064372_dp/) ELSE IF (E_range < 85052.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15665201491118563_dp, & 0.48645255086696204_dp, & 0.8679140908633145_dp, & @@ -15520,9 +15523,9 @@ CONTAINS 12481.117979830125_dp, & 22687.396569080272_dp, & 49029.27213151443_dp, & - 182714.99577064996_dp] + 182714.99577064996_dp/) ELSE IF (E_range < 126612.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15940855323823325_dp, & 0.4956331404107984_dp, & 0.8864643437510178_dp, & @@ -15586,9 +15589,9 @@ CONTAINS 17463.261532301312_dp, & 32186.387908159864_dp, & 69962.03966745277_dp, & - 259964.04274551442_dp] + 259964.04274551442_dp/) ELSE IF (E_range < 247709.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16373958436697705_dp, & 0.5101264978608379_dp, & 0.9159896069529507_dp, & @@ -15652,9 +15655,9 @@ CONTAINS 30505.194880449075_dp, & 57794.75930208428_dp, & 127350.9867284555_dp, & - 471374.61882211326_dp] + 471374.61882211326_dp/) ELSE IF (E_range < 452410.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16729345587752817_dp, & 0.5220837915443625_dp, & 0.9405741148525995_dp, & @@ -15718,9 +15721,9 @@ CONTAINS 49765.1843652489_dp, & 97101.2613405646_dp, & 217655.43736295513_dp, & - 804161.4023302288_dp] + 804161.4023302288_dp/) ELSE IF (E_range < 1104308.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17199827765823103_dp, & 0.5380059294727404_dp, & 0.9736341997615289_dp, & @@ -15784,9 +15787,9 @@ CONTAINS 100319.89810256775_dp, & 206207.35016280194_dp, & 478990.19443877833_dp, & - 1773158.149536881_dp] + 1773158.149536881_dp/) ELSE IF (E_range < 2582180.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17588045499160682_dp, & 0.5512257021498627_dp, & 1.0013703118630188_dp, & @@ -15850,9 +15853,9 @@ CONTAINS 189213.13598878586_dp, & 412506.46573426365_dp, & 1004859.506854019_dp, & - 3757500.169762731_dp] + 3757500.169762731_dp/) ELSE IF (E_range < 10786426.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18118431919794764_dp, & 0.569409896731795_dp, & 1.0399575954447753_dp, & @@ -15916,9 +15919,9 @@ CONTAINS 501508.5608275271_dp, & 1228961.4319415095_dp, & 3359678.97519788_dp, & - 13198823.17240385_dp] + 13198823.17240385_dp/) ELSE IF (E_range < 72565710.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1860758083606257_dp, & 0.5863105731285033_dp, & 1.0762838189916888_dp, & @@ -15982,9 +15985,9 @@ CONTAINS 1439654.5954696422_dp, & 4195690.360297783_dp, & 14287820.480068853_dp, & - 67797329.79665162_dp] + 67797329.79665162_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.18894944364096963_dp, & 0.5962994473518639_dp, & 1.0979679811546372_dp, & @@ -16048,9 +16051,9 @@ CONTAINS 2964362.2649549907_dp, & 10115616.277159294_dp, & 44251495.17814687_dp, & - 324622278.5292175_dp] + 324622278.5292175_dp/) END IF - END SUBROUTINE get_coeff_32 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -16068,7 +16071,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 9649.0_dp) THEN E_ratio = 9649.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13207515772844727_dp, & 0.405991108403864_dp, & 0.7100791180957539_dp, & @@ -16136,9 +16139,9 @@ CONTAINS 2025.283801158086_dp, & 3491.3059333297665_dp, & 7474.317631875756_dp, & - 28531.55532533201_dp] + 28531.55532533201_dp/) ELSE IF (E_range < 15161.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13599210879419024_dp, & 0.41865733842571035_dp, & 0.734387462880487_dp, & @@ -16206,9 +16209,9 @@ CONTAINS 3017.958277485201_dp, & 5225.5076295652025_dp, & 11175.8295539236_dp, & - 42493.69287150706_dp] + 42493.69287150706_dp/) ELSE IF (E_range < 29986.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14157456993085618_dp, & 0.43680814305293825_dp, & 0.7695603918544728_dp, & @@ -16276,9 +16279,9 @@ CONTAINS 5497.180237430633_dp, & 9607.611108068526_dp, & 20546.39934902344_dp, & - 77652.80170951472_dp] + 77652.80170951472_dp/) ELSE IF (E_range < 49196.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14537972365704172_dp, & 0.44924937732846576_dp, & 0.7939069438582139_dp, & @@ -16346,9 +16349,9 @@ CONTAINS 8473.557800314775_dp, & 14944.543756287507_dp, & 32001.381350595566_dp, & - 120417.37064242488_dp] + 120417.37064242488_dp/) ELSE IF (E_range < 109833.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15111478683237578_dp, & 0.46811081455805653_dp, & 0.8311975658154092_dp, & @@ -16416,9 +16419,9 @@ CONTAINS 16981.74160635827_dp, & 30536.056841551963_dp, & 65732.37502124789_dp, & - 245660.71368655932_dp] + 245660.71368655932_dp/) ELSE IF (E_range < 276208.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15704353232796245_dp, & 0.4877544479660704_dp, & 0.8705376156017336_dp, & @@ -16486,9 +16489,9 @@ CONTAINS 37197.937321555175_dp, & 68943.1032010462_dp, & 150241.71258102785_dp, & - 557720.3208697784_dp] + 557720.3208697784_dp/) ELSE IF (E_range < 852991.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16336922513552726_dp, & 0.5088837963863347_dp, & 0.9134464251208241_dp, & @@ -16556,9 +16559,9 @@ CONTAINS 94285.04834791286_dp, & 183730.02847568074_dp, & 411506.64532360405_dp, & - 1520426.766419325_dp] + 1520426.766419325_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.1835103101234003_dp, & 0.5774305061474206_dp, & 1.057140472868453_dp, & @@ -16626,8 +16629,8 @@ CONTAINS 6223266.011027118_dp, & 21236461.045184538_dp, & 92901077.9747871_dp, & - 681507114.6255051_dp] + 681507114.6255051_dp/) END IF - END SUBROUTINE get_coeff_34 + END SUBROUTINE END MODULE minimax_rpa diff --git a/src/mixed_cdft_methods.F b/src/mixed_cdft_methods.F index d5e1d7c4cc..74f7a80279 100644 --- a/src/mixed_cdft_methods.F +++ b/src/mixed_cdft_methods.F @@ -122,21 +122,6 @@ MODULE mixed_cdft_methods CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mixed_cdft_methods' LOGICAL, PARAMETER, PRIVATE :: debug_this_module = .FALSE. - TYPE buffers_idx_irr - INTEGER :: imap(6) = 0 - INTEGER, DIMENSION(:), & - POINTER :: iv => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :) :: r3 => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :, :) :: r4 => null() - END TYPE buffers_idx_irr - - TYPE buffers_bi - LOGICAL, POINTER, DIMENSION(:) :: bv => NULL() - INTEGER, POINTER, DIMENSION(:) :: iv => NULL() - END TYPE buffers_bi - PUBLIC :: mixed_cdft_init, & mixed_cdft_build_weight, & mixed_cdft_calculate_coupling @@ -195,16 +180,14 @@ CONTAINS mixed_env%do_mixed_cdft = .TRUE. IF (mixed_env%do_mixed_cdft) THEN ! Sanity check - IF (nforce_eval < 2) THEN + IF (nforce_eval < 2) & CALL cp_abort(__LOCATION__, & "Mixed CDFT calculation requires at least 2 force_evals.") - END IF mapping_section => section_vals_get_subs_vals(mixed_section, "MAPPING") CALL section_vals_get(mapping_section, explicit=explicit) ! The sub_force_envs must share the same geometrical structure - IF (explicit) THEN + IF (explicit) & CPABORT("Please disable section &MAPPING for mixed CDFT calculations") - END IF CALL section_vals_val_get(mixed_section, "MIXED_CDFT%COUPLING", i_val=et_freq) IF (et_freq < 0) THEN mixed_env%do_mixed_et = .FALSE. @@ -261,10 +244,9 @@ CONTAINS IF (is_parallel) THEN ! Treat states in parallel, build weight function and gradients in parallel before SCF process mixed_cdft%run_type = mixed_cdft_parallel - IF (.NOT. nforce_eval == 2) THEN + IF (.NOT. nforce_eval == 2) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT calculation supports only 2 force_evals.") - END IF ELSE ! Treat states in parallel, but each states builds its own weight function and gradients mixed_cdft%run_type = mixed_cdft_parallel_nobuild @@ -317,9 +299,8 @@ CONTAINS END IF ! Inversion method CALL section_vals_val_get(mixed_section, "MIXED_CDFT%EPS_SVD", r_val=mixed_cdft%eps_svd) - IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) THEN + IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) & CPABORT("Illegal value for EPS_SVD. Value must be between 0.0 and 1.0.") - END IF ! MD related settings CALL force_env_get(force_env, root_section=root_section) md_section => section_vals_get_subs_vals(root_section, "MOTION%MD") @@ -465,7 +446,6 @@ CONTAINS INTEGER, DIMENSION(2, 3) :: bo INTEGER, DIMENSION(:), POINTER :: lb, sendbuffer_i, ub REAL(KIND=dp) :: t1, t2 - TYPE(buffers_idx_irr), DIMENSION(:), POINTER :: recvbuffer TYPE(cdft_control_type), POINTER :: cdft_control, cdft_control_target TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys_mix @@ -480,6 +460,17 @@ CONTAINS TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: force_env_section, print_section + TYPE buffers + INTEGER :: imap(6) + INTEGER, DIMENSION(:), & + POINTER :: iv => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :) :: r3 => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :, :) :: r4 => null() + END TYPE buffers + TYPE(buffers), DIMENSION(:), POINTER :: recvbuffer + NULLIFY (subsys_mix, force_env_qs, particles_mix, force_env_section, print_section, & mixed_env, mixed_cdft, pw_env, auxbas_pw_pool, mixed_auxbas_pw_pool, & qs_env, dft_control, sendbuffer_i, lb, ub, req_total, recvbuffer, & @@ -618,9 +609,8 @@ CONTAINS IF (mixed_cdft%dlb_control%recv_work_repl(1) .OR. mixed_cdft%dlb_control%recv_work_repl(2)) THEN DO j = 1, 2 recv_offset = 0 - IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN + IF (mixed_cdft%dlb_control%recv_work_repl(j)) & recv_offset = SUM(mixed_cdft%dlb_control%recv_info(j)%target_list(2, :)) - END IF IF (mixed_cdft%is_pencil) THEN recvbuffer(j)%imap(1) = recvbuffer(j)%imap(1) + recv_offset ELSE @@ -822,17 +812,15 @@ CONTAINS IF (ANY(mixed_cdft%dlb_control%recv_work_repl)) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%recv_work_repl) IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN - IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) & DEALLOCATE (mixed_cdft%dlb_control%recv_info(j)%target_list) - END IF DEALLOCATE (mixed_cdft%dlb_control%recvbuff(j)%buffs) END IF END DO DEALLOCATE (mixed_cdft%dlb_control%recv_info, mixed_cdft%dlb_control%recvbuff) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) & DEALLOCATE (mixed_cdft%dlb_control%target_list) - END IF DEALLOCATE (mixed_cdft%dlb_control%recv_work_repl) END IF DEALLOCATE (recvbuffer) @@ -994,9 +982,8 @@ CONTAINS END IF ! Atomic weight functions needed for CDFT charges IF (cdft_control_source%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control_target%charge)) THEN + IF (.NOT. ASSOCIATED(cdft_control_target%charge)) & ALLOCATE (cdft_control_target%charge(cdft_control_target%natoms)) - END IF DO iatom = 1, cdft_control_target%natoms CALL auxbas_pw_pool_target%create_pw(cdft_control_target%charge(iatom)) CALL pw_copy(cdft_control_source%charge(iatom), cdft_control_target%charge(iatom)) @@ -1245,14 +1232,12 @@ CONTAINS CALL cp_fm_get_info(mixed_mo_coeff(1, ispin), ncol_global=check_mo(1), nrow_global=check_ao(1)) DO iforce_eval = 2, nforce_eval CALL cp_fm_get_info(mixed_mo_coeff(iforce_eval, ispin), ncol_global=check_mo(2), nrow_global=check_ao(2)) - IF (check_ao(1) /= check_ao(2)) THEN + IF (check_ao(1) /= check_ao(2)) & CALL cp_abort(__LOCATION__, & "The number of atomic orbitals must be the same in every CDFT state.") - END IF - IF (check_mo(1) /= check_mo(2)) THEN + IF (check_mo(1) /= check_mo(2)) & CALL cp_abort(__LOCATION__, & "The number of molecular orbitals must be the same in every CDFT state.") - END IF END DO END DO ! Allocate work @@ -1281,15 +1266,13 @@ CONTAINS ALLOCATE (homo(nforce_eval, nspins)) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL section_vals_val_get(mixed_cdft_section, "EPS_OCCUPIED", r_val=eps_occupied) - IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) THEN + IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Keyword EPS_OCCUPIED only accepts values between 0.0 and 1.0") - END IF - IF (mixed_cdft%eps_svd == 0.0_dp) THEN + IF (mixed_cdft%eps_svd == 0.0_dp) & CALL cp_warn(__LOCATION__, & "The usage of SVD based matrix inversions with fractionally occupied "// & "orbitals is strongly recommended to screen nearly orthogonal states.") - END IF CALL section_vals_val_get(mixed_cdft_section, "SCALE_WITH_OCCUPATION_NUMBERS", l_val=should_scale) END IF ! Start the actual calculation @@ -1321,9 +1304,8 @@ CONTAINS nelectron_mismatch = .FALSE. nelectron_tot = SUM(mixed_cdft%occupations(1, ispin)%array(1:nmo)) DO istate = 2, nforce_eval - IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) THEN + IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) & nelectron_mismatch = .TRUE. - END IF END DO IF (ANY(homo(:, ispin) /= nmo)) THEN IF (ispin == 1) THEN @@ -1386,10 +1368,9 @@ CONTAINS name="MO_COEFF_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_" & //TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX") CALL cp_fm_to_fm(tmp2, mixed_mo_coeff(iforce_eval, ispin)) - IF (should_scale) THEN + IF (should_scale) & CALL cp_fm_column_scale(mixed_mo_coeff(iforce_eval, ispin), & mixed_cdft%occupations(iforce_eval, ispin)%array(1:nmo)) - END IF DEALLOCATE (mixed_cdft%occupations(iforce_eval, ispin)%array) END DO END IF @@ -1403,13 +1384,12 @@ CONTAINS CALL parallel_gemm('T', 'N', nmo, nmo, nao, 1.0_dp, & mixed_mo_coeff(jstate, ispin), & tmp2, 0.0_dp, mo_overlap(ipermutation)) - IF (print_mo) THEN + IF (print_mo) & CALL cp_fm_write_formatted(mo_overlap(ipermutation), mounit, & "# MO overlap matrix (step "//TRIM(ADJUSTL(cp_to_string(mixed_cdft%sim_step)))// & "): CDFT states "//TRIM(ADJUSTL(cp_to_string(istate)))//" and "// & TRIM(ADJUSTL(cp_to_string(jstate)))//" (spin "// & TRIM(ADJUSTL(cp_to_string(ispin)))//")") - END IF END DO END DO ! calculate the MO-representations of the restraint matrices of all CDFT states @@ -1509,10 +1489,9 @@ CONTAINS END SELECT END DO ! Compute density matrix difference P = P_j - P_i - IF (mixed_cdft%calculate_metric) THEN + IF (mixed_cdft%calculate_metric) & CALL dbcsr_add(density_matrix_diff(ipermutation, ispin)%matrix, & density_matrix(jstate, ispin)%matrix, -1.0_dp, 1.0_dp) - END IF ! CALL force_env%para_env%sum(a(ispin, :, ipermutation)) CALL force_env%para_env%sum(b(ispin, :, ipermutation)) @@ -1539,14 +1518,12 @@ CONTAINS DEALLOCATE (homo) DEALLOCATE (mixed_cdft%occupations) END IF - IF (print_mo) THEN + IF (print_mo) & CALL cp_print_key_finished_output(mounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) - END IF - IF (print_mo_eigval) THEN + IF (print_mo_eigval) & CALL cp_print_key_finished_output(moeigvalunit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) - END IF ! solve eigenstates for the projector matrix ALLOCATE (Wda(nvar, npermutations)) ALLOCATE (Sda(npermutations)) @@ -1672,10 +1649,9 @@ CONTAINS ! Compute coupling also with the wavefunction overlap method, see Migliore2009 ! Requires the unconstrained KS ground state wavefunction as input IF (mixed_cdft%wfn_overlap_method) THEN - IF (.NOT. uniform_occupation) THEN + IF (.NOT. uniform_occupation) & CALL cp_abort(__LOCATION__, & "Wavefunction overlap method supports only uniformly occupied MOs.") - END IF CALL mixed_cdft_wfn_overlap_method(force_env, mixed_cdft, ncol_mo, nrow_mo) END IF ! Release remaining work @@ -1982,10 +1958,9 @@ CONTAINS END DO DEALLOCATE (H_block, S_block, eigenvalues, blocks) END DO ! recursion - IF (iounit > 0) THEN + IF (iounit > 0) & WRITE (iounit, '(T3,A)') & - '------------------------------------------------------------------------------' - END IF + '------------------------------------------------------------------------------' CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -2026,9 +2001,8 @@ CONTAINS ALLOCATE (evals(ncol_mo(ispin))) DO ipermutation = 1, npermutations ! Take into account doubly occupied orbitals without LSD - IF (nspins == 1) THEN + IF (nspins == 1) & CALL dbcsr_scale(density_matrix_diff(ipermutation, 1)%matrix, alpha_scalar=0.5_dp) - END IF ! Diagonalize difference density matrix CALL cp_dbcsr_syevd(density_matrix_diff(ipermutation, ispin)%matrix, e_vectors, evals, & para_env=force_env%para_env, blacs_env=mixed_cdft%blacs_env) @@ -2119,35 +2093,31 @@ CONTAINS ALLOCATE (mo_set(ispin)%occupation_numbers(nmo)) END DO ! Read wfn file (note we assume that the basis set is the same) - IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN + IF (force_env%mixed_env%do_mixed_qmmm_cdft) & ! This really shouldnt be a problem? CALL cp_abort(__LOCATION__, & "QMMM + wavefunction overlap method not supported.") - END IF CALL force_env_get(force_env=force_env, subsys=subsys_mix) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL cp_subsys_get(subsys_mix, atomic_kind_set=atomic_kind_set, particle_set=particle_set) CPASSERT(ASSOCIATED(mixed_cdft%qs_kind_set)) - IF (force_env%para_env%is_source()) THEN + IF (force_env%para_env%is_source()) & CALL wfn_restart_file_name(file_name, exist, mixed_cdft_section, logger) - END IF CALL force_env%para_env%bcast(exist) CALL force_env%para_env%bcast(file_name) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CALL cp_abort(__LOCATION__, & "User requested to restart the wavefunction from the file named: "// & TRIM(file_name)//". This file does not exist. Please check the existence of"// & " the file or change properly the value of the keyword WFN_RESTART_FILE_NAME in"// & " section FORCE_EVAL\MIXED\MIXED_CDFT.") - END IF CALL read_mo_set_from_restart(mo_array=mo_set, qs_kind_set=mixed_cdft%qs_kind_set, particle_set=particle_set, & para_env=force_env%para_env, id_nr=0, multiplicity=mixed_cdft%multiplicity, & dft_section=mixed_cdft_section, natom_mismatch=natom_mismatch, & cdft=.TRUE.) - IF (natom_mismatch) THEN + IF (natom_mismatch) & CALL cp_abort(__LOCATION__, & "Restart wfn file has a wrong number of atoms") - END IF ! Orthonormalize wfn DO ispin = 1, nspins IF (mixed_cdft%has_unit_metric) THEN @@ -2380,11 +2350,10 @@ CONTAINS CASE (becke_cutoff_global) cdft_control%becke_control%cutoffs(:) = cdft_control%becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) & CALL cp_abort(__LOCATION__, & "Size of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does "// & "not match number of atomic kinds in the input coordinate file.") - END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -2410,23 +2379,20 @@ CONTAINS is_constraint = .FALSE. END IF in_memory = calculate_forces .AND. cdft_control%becke_control%in_memory - IF (in_memory .NEQV. calculate_forces) THEN + IF (in_memory .NEQV. calculate_forces) & CALL cp_abort(__LOCATION__, & "The flag BECKE_CONSTRAINT\IN_MEMORY must be activated "// & "for the calculation of mixed CDFT forces") - END IF IF (in_memory .OR. mixed_cdft%first_iteration) ALLOCATE (coefficients(natom)) DO i = 1, cdft_control%natoms catom(i) = cdft_control%atoms(i) IF (cdft_control%save_pot .OR. & cdft_control%becke_control%cavity_confine .OR. & cdft_control%becke_control%should_skip .OR. & - mixed_cdft%first_iteration) THEN + mixed_cdft%first_iteration) & is_constraint(catom(i)) = .TRUE. - END IF - IF (in_memory .OR. mixed_cdft%first_iteration) THEN + IF (in_memory .OR. mixed_cdft%first_iteration) & coefficients(catom(i)) = cdft_control%group(1)%coeff(i) - END IF END DO CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_pw_pool=auxbas_pw_pool) bo = auxbas_pw_pool%pw_grid%bounds_local @@ -2458,7 +2424,7 @@ CONTAINS pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - R12(iatom, jatom) = NORM2(dist_vec) + R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) R12(jatom, iatom) = R12(iatom, jatom) IF (build) THEN CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & @@ -2555,9 +2521,8 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=cdft_control%becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) THEN + IF (ASSOCIATED(radii_list)) & DEALLOCATE (radii_list) - END IF END IF NULLIFY (rs_cavity) CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_rs_grid=rs_cavity, & @@ -2657,10 +2622,9 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (force_env%para_env%is_source() .AND. unit_nr < 1) THEN + IF (force_env%para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") - END IF CALL cp_pw_to_cube(cdft_control%becke_control%cavity, & unit_nr, "CAVITY", particles=particles, & stride=stride, mpi_io=mpi_io) @@ -2669,20 +2633,17 @@ CONTAINS END IF END IF bo_conf = bo - IF (cdft_control%becke_control%cavity_confine) THEN + IF (cdft_control%becke_control%cavity_confine) & bo_conf(:, 3) = cdft_control%becke_control%confine_bounds - END IF ! Load balance - IF (mixed_cdft%dlb) THEN + IF (mixed_cdft%dlb) & CALL mixed_becke_constraint_dlb(force_env, mixed_cdft, my_work, & my_work_size, natom, bo, bo_conf) - END IF ! The bounds have been finalized => time to allocate storage for working matrices offset_dlb = 0 IF (mixed_cdft%dlb) THEN - IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) THEN + IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) & offset_dlb = SUM(mixed_cdft%dlb_control%target_list(2, :)) - END IF END IF IF (cdft_control%becke_control%cavity_confine) THEN ! Get rid of the zero part of the confinement cavity (cr3d -> real(:,:,:)) @@ -2772,7 +2733,6 @@ CONTAINS INTEGER, PARAMETER :: should_deallocate = 7000, & uninitialized = -7000 - CHARACTER(len=2) :: dummy INTEGER :: actually_sent, exhausted_work, handle, i, ind, iounit, ispecial, j, max_targets, & more_work, my_pos, my_special_work, my_target, no_overloaded, no_underloaded, nsend, & nsend_limit, nsend_max, offset, offset_proc, offset_special, send_total, tags(2) @@ -2784,13 +2744,19 @@ CONTAINS REAL(kind=dp) :: average_work, load_scale, & very_overloaded, work_factor REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: cavity - TYPE(buffers_bi), DIMENSION(:), POINTER :: recvbuffer, sbuff TYPE(cdft_control_type), POINTER :: cdft_control TYPE(cp_logger_type), POINTER :: logger TYPE(mp_request_type), DIMENSION(4) :: req TYPE(mp_request_type), DIMENSION(:), POINTER :: req_recv, req_total TYPE(section_vals_type), POINTER :: force_env_section, print_section + TYPE buffers + LOGICAL, POINTER, DIMENSION(:) :: bv + INTEGER, POINTER, DIMENSION(:) :: iv + END TYPE buffers + TYPE(buffers), POINTER, DIMENSION(:) :: recvbuffer, sbuff + CHARACTER(len=2) :: dummy + logger => cp_get_default_logger() CALL timeset(routineN, handle) mixed_cdft%dlb_control%recv_work = .FALSE. @@ -2855,9 +2821,8 @@ CONTAINS ! We store the unsorted expected work to refine the estimate on subsequent calls to this routine mixed_cdft%dlb_control%expected_work = expected_work ! Take into account the prediction error of the last step - IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & expected_work = expected_work - mixed_cdft%dlb_control%prediction_error - END IF ! average_work = REAL(SUM(expected_work), dp)/REAL(force_env%para_env%num_pe, dp) ALLOCATE (work_index(force_env%para_env%num_pe), & @@ -2959,9 +2924,8 @@ CONTAINS ! Prevent over redistribution: leave at least (1-work_factor)*nsend_limit slices to my_pos IF (nsend > NINT(work_factor*nsend_limit - send_total)) THEN nsend = NINT(work_factor*nsend_limit - send_total) - IF (debug_this_module) THEN + IF (debug_this_module) & should_warn(force_env%para_env%mepos + 1) = 1 - END IF END IF mixed_cdft%dlb_control%target_list(1, i) = work_index(my_target) - 1 ! This is the actual processor rank IF (mixed_cdft%is_special) THEN @@ -3004,10 +2968,9 @@ CONTAINS EXIT END IF i = i + 1 - IF (i > max_targets) THEN + IF (i > max_targets) & CALL cp_abort(__LOCATION__, & "Load balancing error: increase max_targets") - END IF END DO IF (.NOT. mixed_cdft%is_special) THEN CALL reallocate(mixed_cdft%dlb_control%target_list, 1, 3, 1, i) @@ -3030,12 +2993,11 @@ CONTAINS CALL force_env%para_env%sum(targets) IF (debug_this_module) THEN CALL force_env%para_env%sum(should_warn) - IF (ANY(should_warn == 1)) THEN + IF (ANY(should_warn == 1)) & CALL cp_warn(__LOCATION__, & "MIXED_CDFT DLB: Attempted to redistribute more array"// & " slices than actually available. Leaving a fraction of the total"// & " slices on the overloaded processor. Perhaps you have set LOAD_SCALE too high?") - END IF DEALLOCATE (should_warn) END IF ! check that there is one-to-one mapping between over- and underloaded processors @@ -3274,12 +3236,11 @@ CONTAINS CALL force_env%para_env%irecv(msgout=recvbuffer(i)%bv, & source=mixed_cdft%source_list(i), & request=req_total(i), tag=1) - IF (mixed_cdft%is_special) THEN + IF (mixed_cdft%is_special) & CALL force_env%para_env%irecv(msgout=recvbuffer(i)%iv, & source=mixed_cdft%source_list(i), & request=req_total(i + SIZE(mixed_cdft%source_list)), & tag=2) - END IF END DO DO i = 1, my_special_work DO j = 1, SIZE(mixed_cdft%dest_list) @@ -3297,9 +3258,8 @@ CONTAINS IF (touched(j)) THEN nsend = 0 DO ispecial = 1, SIZE(mixed_cdft%dlb_control%target_list, 2) - IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) THEN + IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) & nsend = nsend + 1 - END IF END DO sbuff(j)%iv(3) = nsend nsend_proc(j) = nsend @@ -3311,11 +3271,10 @@ CONTAINS CALL force_env%para_env%isend(msgin=sbuff(j)%bv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind), tag=1) - IF (mixed_cdft%is_special) THEN + IF (mixed_cdft%is_special) & CALL force_env%para_env%isend(msgin=sbuff(j)%iv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind + 2*SIZE(mixed_cdft%dest_list)), tag=2) - END IF END DO END DO CALL mp_waitall(req_total) @@ -3390,9 +3349,8 @@ CONTAINS IF (mixed_cdft%dlb_control%send_work) THEN ind = COUNT(mixed_cdft%dlb_control%recv_work_repl) + 1 DO i = 1, 2 - IF (i == 2) THEN + IF (i == 2) & mixed_cdft%dlb_control%target_list(3, :) = mixed_cdft%dlb_control%target_list(3, :) + 3*max_targets - END IF CALL force_env%para_env%isend(msgin=mixed_cdft%dlb_control%target_list, & dest=mixed_cdft%dest_list(i), & request=req_total(ind)) @@ -3888,9 +3846,8 @@ CONTAINS END DO END IF ! Poll to prevent starvation - IF (ASSOCIATED(req_recv)) THEN + IF (ASSOCIATED(req_recv)) & completed_recv = mp_testall(req_recv) - END IF ! DO i = LBOUND(weight, 3), UBOUND(weight, 3) IF (cdft_control%becke_control%cavity_confine) THEN @@ -3928,7 +3885,7 @@ CONTAINS IF (distances(iatom) == 0.0_dp) THEN r = position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) distance_vecs(:, iatom) = dist_vec distances(iatom) = dist1 ELSE @@ -3941,7 +3898,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -3957,7 +3914,7 @@ CONTAINS IF (distances(jatom) == 0.0_dp) THEN r1 = position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) distance_vecs(:, jatom) = dist_vec distances(jatom) = dist2 ELSE @@ -3970,7 +3927,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (in_memory) THEN IF (store_vectors) THEN @@ -4033,30 +3990,27 @@ CONTAINS IF (in_memory) THEN dP_i_dRi(:, iatom) = cell_functions(iatom)*dP_i_dRi(:, iatom) d_sum_Pm_dR(:, iatom) = d_sum_Pm_dR(:, iatom) + dP_i_dRi(:, iatom) - IF (is_constraint(iatom)) THEN + IF (is_constraint(iatom)) & d_sum_const_dR(:, iatom) = d_sum_const_dR(:, iatom) + dP_i_dRi(:, iatom)* & coefficients(iatom) - END IF DO jatom = 1, natom IF (jatom /= iatom) THEN IF (jatom < iatom) THEN IF (.NOT. skip_me(jatom)) THEN dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) THEN + IF (is_constraint(iatom)) & d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + & dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) - END IF CYCLE END IF END IF dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) THEN + IF (is_constraint(iatom)) & d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) - END IF END IF END DO END IF @@ -4096,9 +4050,8 @@ CONTAINS END IF END DO END IF - IF (ABS(sum_cell_f_all) > 0.000001) THEN + IF (ABS(sum_cell_f_all) > 0.000001) & weight(k, j, i) = sum_cell_f_constr/sum_cell_f_all - END IF END DO ! i END DO ! j END DO ! k @@ -4161,26 +4114,20 @@ CONTAINS END DO CALL mp_waitall(req_total) DEALLOCATE (req_total) - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & DEALLOCATE (mixed_cdft%dlb_control%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%gradients) - END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) - END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4189,26 +4136,20 @@ CONTAINS IF (should_communicate) THEN CALL mp_waitall(req_send) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & DEALLOCATE (mixed_cdft%dlb_control%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%gradients) - END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) - END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4221,9 +4162,8 @@ CONTAINS IF (mixed_cdft%dlb) THEN CALL force_env%para_env%sum(work) CALL force_env%para_env%sum(work_dlb) - IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN + IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & ALLOCATE (mixed_cdft%dlb_control%prediction_error(force_env%para_env%num_pe)) - END IF mixed_cdft%dlb_control%prediction_error = mixed_cdft%dlb_control%expected_work - work IF (debug_this_module .AND. iounit > 0) THEN DO i = 1, SIZE(work, 1) @@ -4234,9 +4174,8 @@ CONTAINS DEALLOCATE (work, work_dlb, mixed_cdft%dlb_control%expected_work) END IF NULLIFY (gradients, weight, cavity) - IF (ALLOCATED(coefficients)) THEN + IF (ALLOCATED(coefficients)) & DEALLOCATE (coefficients) - END IF IF (in_memory) THEN DEALLOCATE (ds_dR_j) DEALLOCATE (ds_dR_i) @@ -4250,30 +4189,25 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) THEN + IF (ALLOCATED(is_constraint)) & DEALLOCATE (is_constraint) - END IF DEALLOCATE (catom) DEALLOCATE (R12) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) - IF (ALLOCATED(completed)) THEN + IF (ALLOCATED(completed)) & DEALLOCATE (completed) - END IF - IF (ASSOCIATED(nsent)) THEN + IF (ASSOCIATED(nsent)) & DEALLOCATE (nsent) - END IF IF (store_vectors) THEN DEALLOCATE (distances) DEALLOCATE (distance_vecs) DEALLOCATE (position_vecs) END IF - IF (ASSOCIATED(req_send)) THEN + IF (ASSOCIATED(req_send)) & DEALLOCATE (req_send) - END IF - IF (ASSOCIATED(req_recv)) THEN + IF (ASSOCIATED(req_recv)) & DEALLOCATE (req_recv) - END IF CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/mixed_cdft_types.F b/src/mixed_cdft_types.F index 1fa57726d9..5a05d67a39 100644 --- a/src/mixed_cdft_types.F +++ b/src/mixed_cdft_types.F @@ -310,55 +310,41 @@ CONTAINS INTEGER :: i, j CALL pw_env_release(cdft_control%pw_env) - IF (ASSOCIATED(cdft_control%dest_list)) THEN + IF (ASSOCIATED(cdft_control%dest_list)) & DEALLOCATE (cdft_control%dest_list) - END IF - IF (ASSOCIATED(cdft_control%dest_list_save)) THEN + IF (ASSOCIATED(cdft_control%dest_list_save)) & DEALLOCATE (cdft_control%dest_list_save) - END IF - IF (ASSOCIATED(cdft_control%dest_list_bo)) THEN + IF (ASSOCIATED(cdft_control%dest_list_bo)) & DEALLOCATE (cdft_control%dest_list_bo) - END IF - IF (ASSOCIATED(cdft_control%dest_bo_save)) THEN + IF (ASSOCIATED(cdft_control%dest_bo_save)) & DEALLOCATE (cdft_control%dest_bo_save) - END IF - IF (ASSOCIATED(cdft_control%source_list)) THEN + IF (ASSOCIATED(cdft_control%source_list)) & DEALLOCATE (cdft_control%source_list) - END IF - IF (ASSOCIATED(cdft_control%source_list_save)) THEN + IF (ASSOCIATED(cdft_control%source_list_save)) & DEALLOCATE (cdft_control%source_list_save) - END IF - IF (ASSOCIATED(cdft_control%source_list_bo)) THEN + IF (ASSOCIATED(cdft_control%source_list_bo)) & DEALLOCATE (cdft_control%source_list_bo) - END IF - IF (ASSOCIATED(cdft_control%source_bo_save)) THEN + IF (ASSOCIATED(cdft_control%source_bo_save)) & DEALLOCATE (cdft_control%source_bo_save) - END IF - IF (ASSOCIATED(cdft_control%recv_bo)) THEN + IF (ASSOCIATED(cdft_control%recv_bo)) & DEALLOCATE (cdft_control%recv_bo) - END IF - IF (ASSOCIATED(cdft_control%weight)) THEN + IF (ASSOCIATED(cdft_control%weight)) & DEALLOCATE (cdft_control%weight) - END IF - IF (ASSOCIATED(cdft_control%cavity)) THEN + IF (ASSOCIATED(cdft_control%cavity)) & DEALLOCATE (cdft_control%cavity) - END IF - IF (ALLOCATED(cdft_control%constraint_type)) THEN + IF (ALLOCATED(cdft_control%constraint_type)) & DEALLOCATE (cdft_control%constraint_type) - END IF IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations, 1) DO j = 1, SIZE(cdft_control%occupations, 2) - IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) THEN + IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) & DEALLOCATE (cdft_control%occupations(i, j)%array) - END IF END DO END DO DEALLOCATE (cdft_control%occupations) END IF - IF (ASSOCIATED(cdft_control%dlb_control)) THEN + IF (ASSOCIATED(cdft_control%dlb_control)) & CALL mixed_cdft_dlb_release(cdft_control%dlb_control) - END IF IF (ASSOCIATED(cdft_control%sendbuff)) THEN DO i = 1, SIZE(cdft_control%sendbuff) CALL mixed_cdft_buffers_release(cdft_control%sendbuff(i)) @@ -369,12 +355,10 @@ CONTAINS CALL cdft_control_release(cdft_control%cdft_control) DEALLOCATE (cdft_control%cdft_control) END IF - IF (ASSOCIATED(cdft_control%blacs_env)) THEN + IF (ASSOCIATED(cdft_control%blacs_env)) & CALL cp_blacs_env_release(cdft_control%blacs_env) - END IF - IF (ASSOCIATED(cdft_control%qs_kind_set)) THEN + IF (ASSOCIATED(cdft_control%qs_kind_set)) & CALL deallocate_qs_kind_set(cdft_control%qs_kind_set) - END IF IF (ASSOCIATED(cdft_control%sub_logger)) THEN DO i = 1, SIZE(cdft_control%sub_logger) CALL cp_logger_release(cdft_control%sub_logger(i)%p) @@ -397,9 +381,8 @@ CONTAINS INTEGER :: i - IF (ASSOCIATED(dlb_control%recv_work_repl)) THEN + IF (ASSOCIATED(dlb_control%recv_work_repl)) & DEALLOCATE (dlb_control%recv_work_repl) - END IF IF (ASSOCIATED(dlb_control%sendbuff)) THEN DO i = 1, SIZE(dlb_control%sendbuff) CALL mixed_cdft_buffers_release(dlb_control%sendbuff(i)) @@ -414,36 +397,27 @@ CONTAINS END IF IF (ASSOCIATED(dlb_control%recv_info)) THEN DO i = 1, SIZE(dlb_control%recv_info) - IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) THEN + IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) & DEALLOCATE (dlb_control%recv_info(i)%matrix_info) - END IF - IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) THEN + IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) & DEALLOCATE (dlb_control%recv_info(i)%target_list) - END IF END DO DEALLOCATE (dlb_control%recv_info) END IF - IF (ASSOCIATED(dlb_control%bo)) THEN + IF (ASSOCIATED(dlb_control%bo)) & DEALLOCATE (dlb_control%bo) - END IF - IF (ASSOCIATED(dlb_control%expected_work)) THEN + IF (ASSOCIATED(dlb_control%expected_work)) & DEALLOCATE (dlb_control%expected_work) - END IF - IF (ASSOCIATED(dlb_control%prediction_error)) THEN + IF (ASSOCIATED(dlb_control%prediction_error)) & DEALLOCATE (dlb_control%prediction_error) - END IF - IF (ASSOCIATED(dlb_control%target_list)) THEN + IF (ASSOCIATED(dlb_control%target_list)) & DEALLOCATE (dlb_control%target_list) - END IF - IF (ASSOCIATED(dlb_control%cavity)) THEN + IF (ASSOCIATED(dlb_control%cavity)) & DEALLOCATE (dlb_control%cavity) - END IF - IF (ASSOCIATED(dlb_control%weight)) THEN + IF (ASSOCIATED(dlb_control%weight)) & DEALLOCATE (dlb_control%weight) - END IF - IF (ASSOCIATED(dlb_control%gradients)) THEN + IF (ASSOCIATED(dlb_control%gradients)) & DEALLOCATE (dlb_control%gradients) - END IF DEALLOCATE (dlb_control) END SUBROUTINE mixed_cdft_dlb_release @@ -456,15 +430,12 @@ CONTAINS SUBROUTINE mixed_cdft_buffers_release(buffer) TYPE(buffers) :: buffer - IF (ASSOCIATED(buffer%cavity)) THEN + IF (ASSOCIATED(buffer%cavity)) & DEALLOCATE (buffer%cavity) - END IF - IF (ASSOCIATED(buffer%weight)) THEN + IF (ASSOCIATED(buffer%weight)) & DEALLOCATE (buffer%weight) - END IF - IF (ASSOCIATED(buffer%gradients)) THEN + IF (ASSOCIATED(buffer%gradients)) & DEALLOCATE (buffer%gradients) - END IF END SUBROUTINE mixed_cdft_buffers_release diff --git a/src/mixed_cdft_utils.F b/src/mixed_cdft_utils.F index cba3f032cf..89fcedfe23 100644 --- a/src/mixed_cdft_utils.F +++ b/src/mixed_cdft_utils.F @@ -209,11 +209,10 @@ CONTAINS CALL force_env_get(force_env_qs, qs_env=qs_env) END IF CALL get_qs_env(qs_env, pw_env=pw_env, dft_control=dft_control) - IF (.NOT. dft_control%qs_control%cdft) THEN + IF (.NOT. dft_control%qs_control%cdft) & CALL cp_abort(__LOCATION__, & "A mixed CDFT simulation with multiple force_evals was requested, "// & "but CDFT constraints were not active in the QS section of all force_evals!") - END IF cdft_control => dft_control%qs_control%cdft_control CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) settings%bo = auxbas_pw_pool%pw_grid%bounds_local @@ -228,15 +227,13 @@ CONTAINS settings%rs_dims(:, iforce_eval) = auxbas_pw_pool%pw_grid%para%group%num_pe_cart IF (auxbas_pw_pool%pw_grid%grid_span == HALFSPACE) settings%odd(iforce_eval) = 1 ! Becke constraint atoms/coeffs - IF (cdft_control%natoms > SIZE(settings%atoms, 1)) THEN + IF (cdft_control%natoms > SIZE(settings%atoms, 1)) & CALL cp_abort(__LOCATION__, & "More CDFT constraint atoms than defined in mixed section. "// & "Use default values for MIXED\MAPPING.") - END IF settings%atoms(1:cdft_control%natoms, iforce_eval) = cdft_control%atoms - IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (mixed_cdft%run_type == mixed_cdft_parallel) & settings%coeffs(1:cdft_control%natoms, iforce_eval) = cdft_control%group(1)%coeff - END IF ! Integer type settings IF (cdft_control%type == outer_scf_becke_constraint) THEN settings%si(1, iforce_eval) = cdft_control%becke_control%cutoff_type @@ -277,46 +274,41 @@ CONTAINS IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN nkinds = SIZE(cdft_control%becke_control%cutoffs_tmp) - IF (nkinds > settings%max_nkinds) THEN + IF (nkinds > settings%max_nkinds) & CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ELEMENT_CUTOFF. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") - END IF settings%cutoffs(1:nkinds, iforce_eval) = cdft_control%becke_control%cutoffs_tmp(:) END IF IF (cdft_control%becke_control%adjust) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) & CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF nkinds = SIZE(cdft_control%becke_control%radii_tmp) - IF (nkinds > settings%max_nkinds) THEN + IF (nkinds > settings%max_nkinds) & CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ATOMIC_RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") - END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%becke_control%radii_tmp(:) END IF END IF IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN IF (ASSOCIATED(cdft_control%hirshfeld_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) & CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT&RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF nkinds = SIZE(cdft_control%hirshfeld_control%radii) - IF (nkinds > settings%max_nkinds) THEN + IF (nkinds > settings%max_nkinds) & CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in HIRSHFELD_CONSTRAINT&RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") - END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%hirshfeld_control%radii(:) END IF END IF @@ -341,17 +333,15 @@ CONTAINS is_match = is_match .AND. (settings%rs_dims(2, 1) == settings%rs_dims(2, iforce_eval)) is_match = is_match .AND. (settings%odd(1) == settings%odd(iforce_eval)) END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &MGRID settings of the CDFT force_evals.") - END IF IF (settings%spherical(1) == 1) settings%is_spherical = .TRUE. IF (settings%odd(1) == 1) settings%is_odd = .TRUE. ! Make sure CDFT settings are consistent CALL force_env%para_env%sum(settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (mixed_cdft%run_type == mixed_cdft_parallel) & CALL force_env%para_env%sum(settings%coeffs) - END IF settings%ncdft = 0 DO i = 1, SIZE(settings%atoms, 1) DO iforce_eval = 2, nforce_eval @@ -362,13 +352,12 @@ CONTAINS END DO IF (settings%atoms(i, 1) /= 0) settings%ncdft = settings%ncdft + 1 END DO - IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT section of the CDFT force_evals. "// & "Parallel mode mixed CDFT requires identical constraint definitions in both CDFT states. "// & "Switch to serial mode or disable keyword PARALLEL_BUILD if you "// & "want to use nonidentical constraint definitions.") - END IF CALL force_env%para_env%sum(settings%si) CALL force_env%para_env%sum(settings%sr) DO i = 1, SIZE(settings%sb, 1) @@ -388,15 +377,13 @@ CONTAINS IF (settings%sr(i, 1) /= settings%sr(i, iforce_eval)) is_match = .FALSE. END DO END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT settings of the CDFT force_evals.") - END IF ! Some CDFT features are currently disabled for mixed calculations: check that these features were not requested - IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) THEN + IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT load balancing requires Gaussian cavity confinement.") - END IF ! Check for identical constraints in case of run type serial/parallel_nobuild IF (mixed_cdft%run_type /= mixed_cdft_parallel) THEN ! Get array sizes @@ -422,9 +409,8 @@ CONTAINS ! Sum up array sizes and check consistency CALL force_env%para_env%sum(array_sizes) IF (ANY(array_sizes(:, :, 1) /= array_sizes(1, 1, 1)) .OR. & - ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) THEN + ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) & mixed_cdft%identical_constraints = .FALSE. - END IF ! Check constraint definitions IF (mixed_cdft%identical_constraints) THEN ! Prepare temporary storage @@ -468,17 +454,14 @@ CONTAINS END DO DO iforce_eval = 2, nforce_eval DO iatom = 1, SIZE(atoms(1, i)%array) - IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) THEN + IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) & mixed_cdft%identical_constraints = .FALSE. - END IF - IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) THEN + IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) & mixed_cdft%identical_constraints = .FALSE. - END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO - IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) THEN + IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) & mixed_cdft%identical_constraints = .FALSE. - END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO IF (.NOT. mixed_cdft%identical_constraints) EXIT @@ -526,15 +509,12 @@ CONTAINS END DO IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (.NOT. cdft_control%atomic_charges) DEALLOCATE (cdft_control%atoms) - IF (cdft_control%becke_control%cavity_confine) THEN + IF (cdft_control%becke_control%cavity_confine) & CALL release_hirshfeld_type(cdft_control%becke_control%cavity_env) - END IF - IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN + IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) & DEALLOCATE (cdft_control%becke_control%cutoffs_tmp) - END IF - IF (cdft_control%becke_control%adjust) THEN + IF (cdft_control%becke_control%adjust) & DEALLOCATE (cdft_control%becke_control%radii_tmp) - END IF END IF END IF END DO @@ -569,19 +549,16 @@ CONTAINS settings%radius = settings%sr(5, 1) ! Transfer settings only needed if the constraint should be built in parallel IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN - IF (settings%sb(6, 1)) THEN + IF (settings%sb(6, 1)) & CALL cp_abort(__LOCATION__, & "Calculation of atomic Becke charges not supported with parallel mode mixed CDFT") - END IF - IF (mixed_cdft%nconstraint /= 1) THEN + IF (mixed_cdft%nconstraint /= 1) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not yet support multiple constraints.") - END IF - IF (settings%si(5, 1) /= outer_scf_becke_constraint) THEN + IF (settings%si(5, 1) /= outer_scf_becke_constraint) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not support Hirshfeld constraints.") - END IF ALLOCATE (mixed_cdft%cdft_control) CALL cdft_control_create(mixed_cdft%cdft_control) @@ -616,11 +593,10 @@ CONTAINS IF (settings%cutoffs(i, 1) /= settings%cutoffs(i, 2)) is_match = .FALSE. IF (settings%cutoffs(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ELEMENT_CUTOFF settings of the two force_evals.") - END IF ALLOCATE (cdft_control%becke_control%cutoffs_tmp(nkinds)) cdft_control%becke_control%cutoffs_tmp = settings%cutoffs(1:nkinds, 1) END IF @@ -631,11 +607,10 @@ CONTAINS IF (settings%radii(i, 1) /= settings%radii(i, 2)) is_match = .FALSE. IF (settings%radii(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ATOMIC_RADII settings of the two force_evals.") - END IF ALLOCATE (cdft_control%becke_control%radii(nkinds)) cdft_control%becke_control%radii = settings%radii(1:nkinds, 1) END IF @@ -731,9 +706,8 @@ CONTAINS mixed_cdft%is_special = .FALSE. ! Flag to control the last mapping ! With xc smoothing, the grid is always (ncpu/2,1) distributed ! and correct behavior cannot be guaranteed for ncpu/2 > nx, so we abort... - IF (ncpu/2 > settings%npts(1, 1)) THEN + IF (ncpu/2 > settings%npts(1, 1)) & CPABORT("ncpu/2 => nx: decrease ncpu or disable xc_smoothing") - END IF ! ALLOCATE (mixed_rs_dims(2)) IF (settings%rs_dims(2, 1) /= 1) mixed_cdft%is_pencil = .TRUE. @@ -766,12 +740,11 @@ CONTAINS ELSE IF (.NOT. pw_grid%para%group%num_pe_cart(2) == 1) is_match = .FALSE. END IF - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Unable to create a suitable grid distribution "// & "for mixed CDFT calculations. Try decreasing the total number "// & "of processors or disabling xc_smoothing.") - END IF DEALLOCATE (mixed_rs_dims) ! Create the pool bo_mixed = pw_grid%bounds_local @@ -1037,9 +1010,8 @@ CONTAINS DEALLOCATE (settings%rs_dims) DEALLOCATE (settings%odd) DEALLOCATE (settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (mixed_cdft%run_type == mixed_cdft_parallel) & DEALLOCATE (settings%coeffs) - END IF DEALLOCATE (settings%cutoffs) DEALLOCATE (settings%radii) DEALLOCATE (settings%si) @@ -1116,17 +1088,15 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) CPASSERT(ASSOCIATED(dft_control)) nspins = dft_control%nspins - IF (force_env_qs%para_env%is_source()) THEN + IF (force_env_qs%para_env%is_source()) & has_occupation_numbers(iforce_eval) = ALLOCATED(dft_control%qs_control%cdft_control%occupations) - END IF END DO CALL force_env%para_env%sum(has_occupation_numbers(1)) DO iforce_eval = 2, nforce_eval CALL force_env%para_env%sum(has_occupation_numbers(iforce_eval)) - IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) THEN + IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) & CALL cp_abort(__LOCATION__, & "Mixing of uniform and non-uniform occupations is not allowed.") - END IF END DO uniform_occupation = .NOT. has_occupation_numbers(1) DEALLOCATE (has_occupation_numbers) @@ -1184,9 +1154,8 @@ CONTAINS ! Valgrind 3.12/gfortran 4.8.4 oddly complains here (unconditional jump) ! if mixed_cdft%calculate_metric = .FALSE. and the need to null the array ! is queried with IF (mixed_cdft%calculate_metric) & - IF (.NOT. uniform_occupation) THEN + IF (.NOT. uniform_occupation) & NULLIFY (occno_tmp(iforce_eval, ispin)%array) - END IF END DO IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! From this point onward, we access data local to the sub_force_envs @@ -1259,9 +1228,8 @@ CONTAINS ! Occupation numbers IF (.NOT. uniform_occupation) THEN DO ispin = 1, nspins - IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) THEN + IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) & CPABORT("Array dimensions dont match.") - END IF IF (force_env_qs%para_env%is_source()) THEN ALLOCATE (occno_tmp(iforce_eval, ispin)%array(ncol_mo(ispin))) occno_tmp(iforce_eval, ispin)%array = dft_control%qs_control%cdft_control%occupations(ispin)%array @@ -1280,9 +1248,8 @@ CONTAINS ! We use this method for the serial case (mixed_cdft%run_type == mixed_cdft_serial) as well to move the arrays to the ! correct blacs_env, which is impossible using a simple copy of the arrays ALLOCATE (mixed_wmat_tmp(nforce_eval, nvar)) - IF (mixed_cdft%calculate_metric) THEN + IF (mixed_cdft%calculate_metric) & ALLOCATE (mixed_matrix_p_tmp(nforce_eval, nspins)) - END IF DO iforce_eval = 1, nforce_eval ! MO coefficients DO ispin = 1, nspins @@ -1414,9 +1381,8 @@ CONTAINS WRITE (iounit, '(T3,A,I3,A,I3,A)') '###### CDFT states I =', istate, ' and J = ', jstate, ' ######' WRITE (iounit, '(T3,A)') REPEAT('#', 44) DO ivar = 1, nvar - IF (ivar > 1) THEN + IF (ivar > 1) & WRITE (iounit, '(A)') '' - END IF WRITE (iounit, '(T3,A,T60,(3X,I18))') 'Atomic group:', ivar WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Strength of constraint I:', mixed_cdft%results%strength(ivar, istate) @@ -1525,9 +1491,8 @@ CONTAINS INTEGER :: kcol, kpermutation, krow, npermutations npermutations = n*(n - 1)/2 ! Size of upper triangular part - IF (ipermutation > npermutations) THEN + IF (ipermutation > npermutations) & CPABORT("Permutation index out of bounds") - END IF kpermutation = 0 DO krow = 1, n DO kcol = krow + 1, n @@ -1645,20 +1610,18 @@ CONTAINS block_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%BLOCK_DIAGONALIZE") CALL section_vals_get(block_section, explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CALL cp_abort(__LOCATION__, & "Block diagonalization of CDFT Hamiltonian was requested, but the "// & "corresponding input section is missing!") - END IF CALL section_vals_val_get(block_section, "BLOCK", n_rep_val=nblk) ALLOCATE (blocks(nblk)) DO i = 1, nblk NULLIFY (blocks(i)%array) CALL section_vals_val_get(block_section, "BLOCK", i_rep_val=i, i_vals=tmplist) - IF (SIZE(tmplist) < 1) THEN + IF (SIZE(tmplist) < 1) & CPABORT("Each BLOCK must contain at least 1 state.") - END IF ALLOCATE (blocks(i)%array(SIZE(tmplist))) blocks(i)%array(:) = tmplist(:) END DO @@ -1667,9 +1630,8 @@ CONTAINS ! Check that the requested states exist DO i = 1, nblk DO j = 1, SIZE(blocks(i)%array) - IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) THEN + IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) & CPABORT("Requested state does not exist.") - END IF END DO END DO ! Check for duplicates @@ -1701,10 +1663,9 @@ CONTAINS ELSE nrecursion = nblk/2 END IF - IF (nrecursion /= 1 .AND. .NOT. ignore_excited) THEN + IF (nrecursion /= 1 .AND. .NOT. ignore_excited) & CALL cp_abort(__LOCATION__, & "Keyword IGNORE_EXCITED must be active for recursive diagonalization.") - END IF END IF END SUBROUTINE mixed_cdft_read_block_diag @@ -1748,11 +1709,10 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_block(i)%array >= 0.0_dp)) THEN + IF (ANY(H_block(i)%array >= 0.0_dp)) & CALL cp_abort(__LOCATION__, & "At least one of the interaction energies within block "//TRIM(ADJUSTL(cp_to_string(i)))// & " is repulsive.") - END IF END DO END SUBROUTINE mixed_cdft_get_blocks @@ -1887,11 +1847,10 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_offdiag >= 0.0_dp)) THEN + IF (ANY(H_offdiag >= 0.0_dp)) & CALL cp_abort(__LOCATION__, & "At least one of the interaction energies between blocks "//TRIM(ADJUSTL(cp_to_string(i)))// & " and "//TRIM(ADJUSTL(cp_to_string(j)))//" is repulsive.") - END IF ! Now transform: C_i^T * H * C_j H_offdiag(:, :) = MATMUL(H_offdiag, H_block(j)%array) H_offdiag(:, :) = MATMUL(TRANSPOSE(H_block(i)%array), H_offdiag) diff --git a/src/mixed_environment_types.F b/src/mixed_environment_types.F index 267d51da65..0cb02288c5 100644 --- a/src/mixed_environment_types.F +++ b/src/mixed_environment_types.F @@ -321,12 +321,10 @@ CONTAINS IF (ASSOCIATED(mixed_env%group_distribution)) THEN DEALLOCATE (mixed_env%group_distribution) END IF - IF (ASSOCIATED(mixed_env%cdft_control)) THEN + IF (ASSOCIATED(mixed_env%cdft_control)) & CALL mixed_cdft_type_release(mixed_env%cdft_control) - END IF - IF (ASSOCIATED(mixed_env%strength)) THEN + IF (ASSOCIATED(mixed_env%strength)) & DEALLOCATE (mixed_env%strength) - END IF END SUBROUTINE mixed_env_release diff --git a/src/mode_selective.F b/src/mode_selective.F index 9877810b97..753dfb8bae 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -330,9 +330,8 @@ CONTAINS END IF END IF END IF - IF (ms_vib%select_id == 0) THEN + IF (ms_vib%select_id == 0) & CPABORT("no frequency, range or involved atoms specified ") - END IF ionode = para_env%is_source() SELECT CASE (guess) CASE (ms_guess_atomic) @@ -375,7 +374,7 @@ CONTAINS ms_vib%b_vec(jj, i) = ABS(globenv%gaussian_rng_stream%next()) END DO END DO - norm = NORM2(ms_vib%b_vec(:, i)) + norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO @@ -387,7 +386,7 @@ CONTAINS ms_vib%b_vec(:, j) = & ms_vib%b_vec(:, j) - DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, i))*ms_vib%b_vec(:, i) ms_vib%b_vec(:, j) = & - ms_vib%b_vec(:, j)/NORM2(ms_vib%b_vec(:, j)) + ms_vib%b_vec(:, j)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, j))) END IF END DO END DO @@ -425,8 +424,8 @@ CONTAINS CALL para_env%bcast(ms_vib%b_vec) CALL para_env%bcast(ms_vib%delta_vec) DO i = 1, nrep - ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) - ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) + ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) + ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) END DO CALL timestop(handle) @@ -452,8 +451,8 @@ CONTAINS INTEGER :: nrep CHARACTER(LEN=default_path_length) :: hes_filename - INTEGER :: hesunit, i, istat, j, jj, k, natoms, & - ncoord, output_unit, stat + INTEGER :: hesunit, i, j, jj, k, natoms, ncoord, & + output_unit, stat INTEGER, DIMENSION(:), POINTER :: tmplist REAL(KIND=dp) :: my_val, norm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp @@ -477,14 +476,12 @@ CONTAINS ALLOCATE (tmplist(ncoord)) ! should use the cp_fm_read_unformatted... - istat = 0 DO i = 1, ncoord READ (UNIT=hesunit, IOSTAT=stat) ms_vib%hes_bfgs(:, i) - istat = istat + stat END DO CALL close_file(hesunit) IF (output_unit > 0) THEN - IF (istat /= 0) THEN + IF (stat /= 0) THEN WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading HESSIAN **" ELSE WRITE (output_unit, FMT="(/,T2,A)") & @@ -520,7 +517,7 @@ CONTAINS CALL sort(tmp, ncoord, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = ms_vib%hes_bfgs(:, tmplist(i)) - norm = NORM2(ms_vib%b_vec(:, i)) + norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, SIZE(ms_vib%b_vec, 1) @@ -600,19 +597,18 @@ CONTAINS END IF IF (ionode) THEN statint = 0 - READ (UNIT=hesunit) ms_vib%b_mat + READ (UNIT=hesunit, IOSTAT=stat) ms_vib%b_mat READ (UNIT=hesunit, IOSTAT=stat) ms_vib%s_mat - IF (stat /= 0 .AND. output_unit > 0) THEN - WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" - END IF - IF (calc_intens) THEN - READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) - IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & - "intensities are requested but not present in restart file **" - END IF + IF (calc_intens) READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) + IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & + "intensities are requested but not present in restart file **" CALL close_file(hesunit) - IF (stat == 0 .AND. statint == 0 .AND. output_unit > 0) THEN - WRITE (output_unit, FMT="(/,T2,A)") "*** MS_RESTART has been read successfully ***" + IF (output_unit > 0) THEN + IF (stat /= 0) THEN + WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" + ELSE + WRITE (output_unit, FMT="(/,T2,A)") "*** RESTART has been read successfully ***" + END IF END IF END IF CALL para_env%bcast(ms_vib%b_mat) @@ -634,7 +630,7 @@ CONTAINS DO j = 1, ms_vib%mat_size ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i) + approx_H(j, ind(i))*ms_vib%b_mat(:, j) END DO - ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/NORM2(ms_vib%b_vec(:, i)) + ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) END DO DEALLOCATE (ms_vib%s_mat) @@ -704,8 +700,8 @@ CONTAINS unit_number=iw) END IF info = "" - READ (iw, *) info - READ (iw, *) info + READ (iw, *, IOSTAT=stat) info + READ (iw, *, IOSTAT=stat) info istat = 0 nvibs = 0 reading_vib = .FALSE. @@ -788,7 +784,7 @@ CONTAINS CALL sort(tmp, nvibs, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = modes(:, tmplist(i))*mass(:) - norm = NORM2(ms_vib%b_vec(:, i)) + norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, nrep @@ -924,8 +920,8 @@ CONTAINS END DO DO i = 1, nrep - ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) - ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) + ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) + ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) END DO converged = .FALSE. IF (MAXVAL(criteria(1, :)) <= ms_vib%eps(1) .AND. MAXVAL(criteria(2, :)) & @@ -950,14 +946,14 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) + tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) END DO IF (calc_intens) THEN DO i = 1, ms_vib%mat_size DO j = 1, ms_vib%mat_size tmp_s(:, i) = tmp_s(:, i) + ms_vib%dip_deriv(:, j)*approx_H(j, i) END DO - IF (calc_intens) intensities(i) = NORM2(tmp_s(:, i)) + IF (calc_intens) intensities(i) = SQRT(DOT_PRODUCT(tmp_s(:, i), tmp_s(:, i))) END DO END IF IF (calc_intens) THEN @@ -1045,7 +1041,7 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) + tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) END DO tmp = 0._dp DO i = 1, ms_vib%mat_size @@ -1082,12 +1078,12 @@ CONTAINS IF (PRESENT(criteria)) THEN DO i = 1, nrep criteria(1, i) = MAXVAL((residuum(:, i))) - criteria(2, i) = NORM2(residuum(:, i)) + criteria(2, i) = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) END DO END IF DO i = 1, nrep - norm = NORM2(residuum(:, i)) + norm = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) residuum(:, i) = residuum(:, i)/norm END DO @@ -1095,13 +1091,13 @@ CONTAINS DO j = 1, nrep DO i = 1, ms_vib%mat_size residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), ms_vib%b_mat(:, i))*ms_vib%b_mat(:, i) - residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) + residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) END DO IF (nrep > 1) THEN DO i = 1, nrep IF (i /= j) THEN residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), residuum(:, i))*residuum(:, i) - residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) + residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) END IF END DO END IF @@ -1143,7 +1139,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), OPTIONAL :: intensities TYPE(cp_logger_type), POINTER :: logger - INTEGER :: i, j, msunit + INTEGER :: i, j, msunit, stat REAL(KIND=dp) :: crit_a, crit_b, fint, gintval REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: residuum TYPE(section_vals_type), POINTER :: ms_vib_section @@ -1176,7 +1172,7 @@ CONTAINS residuum(:) = residuum(:) - DOT_PRODUCT(residuum(:), ms_vib%b_mat(:, j))*ms_vib%b_mat(:, j) END DO crit_a = MAXVAL(residuum(:)) - crit_b = NORM2(residuum) + crit_b = SQRT(DOT_PRODUCT(residuum, residuum)) IF (PRESENT(intensities)) THEN gintval = fint*intensities(i)**2 IF (crit_a <= ms_vib%eps(1) .AND. crit_b <= ms_vib%eps(2)) THEN @@ -1204,10 +1200,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit) ms_vib%mat_size - WRITE (UNIT=msunit) ms_vib%b_mat - WRITE (UNIT=msunit) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & @@ -1221,10 +1217,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit) ms_vib%mat_size - WRITE (UNIT=msunit) ms_vib%b_mat - WRITE (UNIT=msunit) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & diff --git a/src/mol_force.F b/src/mol_force.F index 8788183cdc..fecd8c1f7a 100644 --- a/src/mol_force.F +++ b/src/mol_force.F @@ -53,17 +53,17 @@ CONTAINS SELECT CASE (id_type) CASE (do_ff_quartic) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 energy = (f12*k(1) + (f13*k(2) + f14*k(3)*disp)*disp)*disp*disp fscalar = ((k(1) + (k(2) + k(3)*disp)*disp)*disp)/dij CASE (do_ff_morse) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 energy = k(1)*((1 - EXP(-k(2)*disp))**2 - 1) fscalar = 2*k(1)*k(2)*EXP(-k(2)*disp)*(1 - EXP(-k(2)*disp))/dij CASE (do_ff_cubic) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 energy = k(1)*disp**2*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) fscalar = (2.0_dp*k(1)*disp*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) + & @@ -76,7 +76,7 @@ CONTAINS energy = f14*k(1)*disp*disp fscalar = k(1)*disp CASE (do_ff_charmm, do_ff_amber) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -86,7 +86,7 @@ CONTAINS fscalar = 2.0_dp*k(1)*disp/dij END IF CASE (do_ff_harmonic, do_ff_g87) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -96,7 +96,7 @@ CONTAINS fscalar = k(1)*disp/dij END IF CASE (do_ff_fues) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = r0/dij energy = f12*k(1)*r0*r0*(1.0_dp + disp*(disp - 2.0_dp)) fscalar = k(1)*r0*disp*disp*(1.0_dp - disp)/dij @@ -507,7 +507,7 @@ CONTAINS b = DOT_PRODUCT(t41, t41) - D !inverse norm of t41 - is41 = 1.0_dp/NORM2(t41) + is41 = 1.0_dp/SQRT(DOT_PRODUCT(t41, t41)) cosphi = SQRT(b)*is41 IF (cosphi > 1.0_dp) cosphi = 1.0_dp diff --git a/src/molecular_dipoles.F b/src/molecular_dipoles.F index eb53cae2bb..90a768e113 100644 --- a/src/molecular_dipoles.F +++ b/src/molecular_dipoles.F @@ -76,7 +76,7 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dipole_set REAL(KIND=dp), DIMENSION(3) :: ci, gvec, rcc REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point - REAL(KIND=dp), DIMENSION(:, :), POINTER :: center + REAL(KIND=dp), DIMENSION(:, :), POINTER :: center(:, :) TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(cell_type), POINTER :: cell TYPE(cp_logger_type), POINTER :: logger @@ -84,7 +84,7 @@ CONTAINS TYPE(distribution_1d_type), POINTER :: local_molecules TYPE(molecule_kind_type), POINTER :: molecule_kind TYPE(mp_para_env_type), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(particle_type), POINTER :: particle_set(:) TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set logger => cp_get_default_logger() @@ -224,7 +224,7 @@ CONTAINS dipole_set(:, :) = dipole_set(:, :)*debye ! Debye DO I = 1, SIZE(dipole_set, 2) WRITE (UNIT=iounit, FMT='(T8,I6,T21,5F12.6)') I, charge_set(I), dipole_set(1:3, I), & - NORM2(dipole_set(1:3, I)) + SQRT(DOT_PRODUCT(dipole_set(1:3, I), dipole_set(1:3, I))) END DO WRITE (UNIT=iounit, FMT="(T2,A,T61,E20.12)") ' DIPOLE : CheckSum =', SUM(dipole_set) END IF diff --git a/src/molsym.F b/src/molsym.F index 3d44715eae..466f6762b2 100644 --- a/src/molsym.F +++ b/src/molsym.F @@ -1210,12 +1210,10 @@ CONTAINS IF (.NOT. sym%linear) THEN DO icn = 2, sym%ncn DO isec = 1, sym%nsec(icn) - IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) THEN + IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) & CALL addses(icn, sym%sec(:, isec, icn), sym) - END IF - IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) THEN + IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) & CALL addses(2*icn, sym%sec(:, isec, icn), sym) - END IF END DO END DO END IF diff --git a/src/motion/bfgs_optimizer.F b/src/motion/bfgs_optimizer.F index 54e89bffa8..ef6ae345ea 100644 --- a/src/motion/bfgs_optimizer.F +++ b/src/motion/bfgs_optimizer.F @@ -194,14 +194,13 @@ CONTAINS ndf = SIZE(x0) nfree = gopt_env%nfree - IF (ndf > 3000) THEN + IF (ndf > 3000) & CALL cp_warn(__LOCATION__, & "The dimension of the Hessian matrix ("// & TRIM(ADJUSTL(cp_to_string(ndf)))//") is greater than 3000. "// & "The diagonalisation of the full Hessian matrix needed for BFGS "// & "is computationally expensive. You should consider to use the linear "// & "scaling variant L-BFGS instead.") - END IF ! Initialize hessian (hes = unitary matrix or model hessian ) CALL cp_blacs_env_create(blacs_env, para_env, globenv%blacs_grid_layout, & @@ -240,10 +239,8 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) - IF (output_unit > 0) THEN - WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, using unity as model Hessian." - END IF + IF (output_unit > 0) WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, using unity as model Hessian." ELSE DO its = 1, SIZE(eigval) IF (eigval(its) < 0.1_dp) eigval(its) = 0.1_dp @@ -376,10 +373,8 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN - IF (output_unit > 0) THEN - WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, resetting Hessian to unity." - END IF + IF (output_unit > 0) WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, resetting Hessian to unity." CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) CALL cp_fm_to_fm(hess_mat, hess_tmp) CALL choose_eigv_solver(hess_tmp, eigvec_mat, eigval) @@ -1092,7 +1087,7 @@ CONTAINS !pbc for a distance vector r_ij(j, i, :) = pbc(particles%els(i)%r, particles%els(j)%r, cell) r_ij(i, j, :) = -r_ij(j, i, :) - d_ij(j, i) = NORM2(r_ij(j, i, :)) + d_ij(j, i) = SQRT(DOT_PRODUCT(r_ij(j, i, :), r_ij(j, i, :))) d_ij(i, j) = d_ij(j, i) rho_ij(j, i) = EXP(alpha(jat_row, iat_row)*(r0(jat_row, iat_row)**2 - d_ij(j, i)**2)) rho_ij(i, j) = rho_ij(j, i) @@ -1109,28 +1104,25 @@ CONTAINS iat_row = (jglobal + 2)/3 IF (iat_row > natom) CYCLE IF (iat_row /= iat_col) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN + IF (d_ij(iat_row, iat_col) < 6.0_dp) & local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) - END IF ELSE local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) END IF IF (iat_col /= iat_row) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN + IF (d_ij(iat_row, iat_col) < 6.0_dp) & local_data(j, i) = local_data(j, i) - & dist_second_deriv(r_ij(iat_col, iat_row, :), & iind, jind, d_ij(iat_row, iat_col), rho_ij(iat_row, iat_col)) - END IF ELSE DO k = 1, natom IF (k == iat_col) CYCLE - IF (d_ij(iat_row, k) < 6.0_dp) THEN + IF (d_ij(iat_row, k) < 6.0_dp) & local_data(j, i) = local_data(j, i) + & dist_second_deriv(r_ij(iat_col, k, :), & iind, jind, d_ij(iat_row, k), rho_ij(iat_row, k)) - END IF END DO END IF IF (fixed(jind, iat_row) < 0.5_dp .OR. fixed(iind, iat_col) < 0.5_dp) THEN diff --git a/src/motion/cell_opt_utils.F b/src/motion/cell_opt_utils.F index 48b29fb216..ed25d9fb70 100644 --- a/src/motion/cell_opt_utils.F +++ b/src/motion/cell_opt_utils.F @@ -184,9 +184,8 @@ CONTAINS pres_ext = 0.0_dp CALL section_vals_val_get(geo_section, "EXTERNAL_PRESSURE", r_vals=pvals) check = (SIZE(pvals) == 1) .OR. (SIZE(pvals) == 9) - IF (.NOT. check) THEN + IF (.NOT. check) & CPABORT("EXTERNAL_PRESSURE can have 1 or 9 components only!") - END IF IF (SIZE(pvals) == 9) THEN ind = 0 @@ -426,8 +425,7 @@ CONTAINS gamma = angle(cell%hmat(:, 1), cell%hmat(:, 2)) cosg = COS(gamma) sing = SIN(gamma) - ! Here, g is the average derivative of the cell vector length ab_length, - ! and deriv_gamma is the derivative of the angle gamma + ! Here, g is the average derivative of the cell vector length ab_length, and deriv_gamma is the derivative of the angle gamma g = 0.5_dp*(gradient(1) + cosg*gradient(2) + sing*gradient(3)) deriv_gamma = (gradient(3)*cosg - gradient(2)*sing)/b_length gradient(1) = g diff --git a/src/motion/cg_utils.F b/src/motion/cg_utils.F index 017c5041f2..a2beb77590 100644 --- a/src/motion/cg_utils.F +++ b/src/motion/cg_utils.F @@ -163,7 +163,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: gradient2, ls_norm CALL timeset(routineN, handle) - norm_ls_vec = NORM2(ls_vec) + norm_ls_vec = SQRT(DOT_PRODUCT(ls_vec, ls_vec)) my_use_only_grad = .FALSE. IF (PRESENT(use_only_grad)) my_use_only_grad = use_only_grad IF (norm_ls_vec /= 0.0_dp) THEN @@ -260,7 +260,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: tls_norm CALL timeset(routineN, handle) - norm_tls_vec = NORM2(tls_vec) + norm_tls_vec = SQRT(DOT_PRODUCT(tls_vec, tls_vec)) IF (norm_tls_vec /= 0.0_dp) THEN ALLOCATE (tls_norm(SIZE(tls_vec))) @@ -379,7 +379,7 @@ CONTAINS dimer_env%rot%g0 work = -2.0_dp*(work - dimer_env%rot%g0) work = work - DOT_PRODUCT(work, dimer_env%nvec)*dimer_env%nvec - opt_energy = NORM2(work) + opt_energy = SQRT(DOT_PRODUCT(work, work)) DEALLOCATE (work) END IF dimer_env%rot%angle2 = angle @@ -434,7 +434,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/NORM2(xicom) + xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -520,7 +520,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/NORM2(xicom) + xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -866,10 +866,9 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(/,T2,A)") REPEAT("*", 79) WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,I7,T78,A)") & "***", "BRENT - NUMBER OF ENERGY EVALUATIONS : ", loc_iter, "***" - IF (iter == itmax + 1) THEN + IF (iter == itmax + 1) & WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,T78,A)") & - "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" - END IF + "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", 79) END IF CPASSERT(iter /= itmax + 1) @@ -1080,7 +1079,7 @@ CONTAINS g = h h = -xi*dimer_env%cg_rot%norm_theta + gam*dimer_env%cg_rot%norm_h*dimer_env%cg_rot%nvec_old h = h - DOT_PRODUCT(h, dimer_env%nvec)*dimer_env%nvec - norm_h = NORM2(h) + norm_h = SQRT(DOT_PRODUCT(h, h)) IF (norm_h < EPSILON(0.0_dp)) THEN h = 0.0_dp ELSE diff --git a/src/motion/cp_lbfgs.F b/src/motion/cp_lbfgs.F index 99ff16249c..8d245095e5 100644 --- a/src/motion/cp_lbfgs.F +++ b/src/motion/cp_lbfgs.F @@ -1460,9 +1460,8 @@ CONTAINS dtm = -f1/f2 tsum = zero nseg = 1 - IF (iprint >= 99) THEN + IF (iprint >= 99) & WRITE (wunit, 1011) nbreak - END IF nleft = nbreak iter = 1 @@ -3430,30 +3429,24 @@ CONTAINS ! algorithm enters the second stage. ftest = finit + stp*gtest - IF (stage == 1 .AND. f <= ftest .AND. g >= zero) THEN + IF (stage == 1 .AND. f <= ftest .AND. g >= zero) & stage = 2 - END IF ! Test for warnings. - IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) THEN + IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) & task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' - END IF - IF (brackt .AND. stmax - stmin <= xtol*stmax) THEN + IF (brackt .AND. stmax - stmin <= xtol*stmax) & task = 'WARNING: XTOL TEST SATISFIED' - END IF - IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) THEN + IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) & task = 'WARNING: STP = STPMAX' - END IF - IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) THEN + IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) & task = 'WARNING: STP = STPMIN' - END IF ! Test for convergence. - IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) THEN + IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) & task = 'CONVERGENCE' - END IF ! Test for termination. diff --git a/src/motion/cp_lbfgs_geo.F b/src/motion/cp_lbfgs_geo.F index 83701fccc3..ef4abb4441 100644 --- a/src/motion/cp_lbfgs_geo.F +++ b/src/motion/cp_lbfgs_geo.F @@ -114,9 +114,8 @@ CONTAINS END IF ! Stop if not implemented - IF (gopt_env%type_id == default_ts_method_id) THEN + IF (gopt_env%type_id == default_ts_method_id) & CPABORT("BFGS method not yet working with DIMER") - END IF ALLOCATE (optimizer) CALL cp_opt_gopt_create(optimizer, para_env=para_env, obj_funct=gopt_env, & diff --git a/src/motion/cp_lbfgs_optimizer_gopt.F b/src/motion/cp_lbfgs_optimizer_gopt.F index decb8d6681..92fcd24488 100644 --- a/src/motion/cp_lbfgs_optimizer_gopt.F +++ b/src/motion/cp_lbfgs_optimizer_gopt.F @@ -234,12 +234,10 @@ CONTAINS optimizer%gradient = 0.0_dp optimizer%dsave = 0.0_dp optimizer%work_array = 0.0_dp - IF (PRESENT(wanted_relative_f_delta)) THEN + IF (PRESENT(wanted_relative_f_delta)) & optimizer%wanted_relative_f_delta = wanted_relative_f_delta - END IF - IF (PRESENT(wanted_projected_gradient)) THEN + IF (PRESENT(wanted_projected_gradient)) & optimizer%wanted_projected_gradient = wanted_projected_gradient - END IF optimizer%kind_of_bound = 0 IF (PRESENT(kind_of_bound)) optimizer%kind_of_bound = kind_of_bound IF (PRESENT(lower_bound)) optimizer%lower_bound = lower_bound @@ -377,12 +375,10 @@ CONTAINS IF (PRESENT(obj_funct)) obj_funct = optimizer%obj_funct IF (PRESENT(m)) m = optimizer%m IF (PRESENT(max_f_per_iter)) max_f_per_iter = optimizer%max_f_per_iter - IF (PRESENT(wanted_projected_gradient)) THEN + IF (PRESENT(wanted_projected_gradient)) & wanted_projected_gradient = optimizer%wanted_projected_gradient - END IF - IF (PRESENT(wanted_relative_f_delta)) THEN + IF (PRESENT(wanted_relative_f_delta)) & wanted_relative_f_delta = optimizer%wanted_relative_f_delta - END IF IF (PRESENT(print_every)) print_every = optimizer%print_every IF (PRESENT(x)) x => optimizer%x IF (PRESENT(n_var)) n_var = SIZE(x) @@ -393,17 +389,15 @@ CONTAINS IF (PRESENT(last_f)) last_f = optimizer%last_f IF (PRESENT(f)) f = optimizer%f IF (PRESENT(at_end)) at_end = optimizer%status > 3 - IF (PRESENT(actual_projected_gradient)) THEN + IF (PRESENT(actual_projected_gradient)) & actual_projected_gradient = optimizer%projected_gradient - END IF IF (optimizer%master == optimizer%para_env%mepos) THEN IF (optimizer%isave(30) > 1 .AND. (optimizer%task(1:5) == "NEW_X" .OR. & optimizer%task(1:4) == "STOP" .AND. optimizer%task(7:9) == "CPU")) THEN ! nr iterations >1 .and. dsave contains the wanted data IF (PRESENT(last_f)) last_f = optimizer%dsave(2) - IF (PRESENT(actual_projected_gradient)) THEN + IF (PRESENT(actual_projected_gradient)) & actual_projected_gradient = optimizer%dsave(13) - END IF ELSE CPASSERT(.NOT. PRESENT(last_f)) CPASSERT(.NOT. PRESENT(actual_projected_gradient)) @@ -704,7 +698,8 @@ CONTAINS DEALLOCATE (xold) IF (PRESENT(f)) f = optimizer%f IF (PRESENT(last_f)) last_f = optimizer%last_f - IF (PRESENT(projected_gradient)) projected_gradient = optimizer%projected_gradient + IF (PRESENT(projected_gradient)) & + projected_gradient = optimizer%projected_gradient IF (PRESENT(n_iter)) n_iter = optimizer%n_iter CALL timestop(handle) @@ -740,7 +735,8 @@ CONTAINS IF (PRESENT(n_iter)) n_iter = NINT(results(1)) IF (PRESENT(f)) f = results(2) IF (PRESENT(last_f)) last_f = results(3) - IF (PRESENT(projected_gradient)) projected_gradient = results(4) + IF (PRESENT(projected_gradient)) & + projected_gradient = results(4) END SUBROUTINE cp_opt_gopt_bcast_res diff --git a/src/motion/dimer_methods.F b/src/motion/dimer_methods.F index 63b2ca9eba..c3b1e2c5cf 100644 --- a/src/motion/dimer_methods.F +++ b/src/motion/dimer_methods.F @@ -197,10 +197,10 @@ CONTAINS END IF IF (debug_this_module .AND. (iw > 0)) THEN WRITE (iw, *) "final gradient:", gradient - WRITE (iw, '(A,F20.10)') "norm gradient:", NORM2(gradient) + WRITE (iw, '(A,F20.10)') "norm gradient:", SQRT(DOT_PRODUCT(gradient, gradient)) END IF IF (.NOT. gopt_env%do_line_search) THEN - f = NORM2(gradient) + f = SQRT(DOT_PRODUCT(gradient, gradient)) ELSE f = -DOT_PRODUCT(gradient, dimer_env%tsl%tls_vec) END IF @@ -237,7 +237,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) natoms = particles%n_els - norm_gradient_old = NORM2(gradient) + norm_gradient_old = SQRT(DOT_PRODUCT(gradient, gradient)) IF (norm_gradient_old > 0.0_dp) THEN IF (natoms > 1) THEN CALL rot_ana(particles%els, mat, dof, print_section, keep_rotations=.FALSE., & diff --git a/src/motion/dimer_types.F b/src/motion/dimer_types.F index 608a867801..840a3acc4a 100644 --- a/src/motion/dimer_types.F +++ b/src/motion/dimer_types.F @@ -193,9 +193,8 @@ CONTAINS CALL dimer_fixed_atom_control(dimer_env%nvec, subsys, unit_nr) ! Normalize dimer vector norm = SQRT(SUM(dimer_env%nvec**2)) - IF (norm <= EPSILON(0.0_dp)) THEN + IF (norm <= EPSILON(0.0_dp)) & CPABORT("The norm of the dimer vector is 0! Calculation cannot proceed further.") - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, "(T2,A,T9,A,T69,F12.6)") & "DIMER|", "Norm of dimer vector to be normalized by rescaling", norm @@ -415,9 +414,8 @@ CONTAINS CALL globenv%gaussian_rng_stream%fill(dimer_env%nvec) CASE (dimer_init_molden) CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CPABORT("INITIALIZATION_METHOD MOLDEN requires VIB_MOLDEN_NAME") - END IF CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", c_val=molden_name) IF (unit > 0) THEN WRITE (unit, "(/,T2,A,T9,A)") & @@ -443,12 +441,11 @@ CONTAINS CALL parser_get_next_line(parser, 1) READ (UNIT=parser%input_line, FMT=*, IOSTAT=ierr) & array_r(3*j - 2), array_r(3*j - 1), array_r(3*j) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CALL cp_abort(__LOCATION__, & "Error while reading MOLDEN file: cannot parse the line "// & TRIM(ADJUSTL(cp_to_string(j)))//" of <"//vib_name//"> "// & "for components of the normal mode") - END IF END DO dimer_env%nvec(:) = dimer_env%nvec(:) + array_r(:)*vib_wt_list(i) END DO Vib_modes diff --git a/src/motion/dimer_utils.F b/src/motion/dimer_utils.F index 9ecc75dfa1..d5006aa274 100644 --- a/src/motion/dimer_utils.F +++ b/src/motion/dimer_utils.F @@ -120,7 +120,7 @@ CONTAINS REAL(KIND=dp), INTENT(OUT) :: norm gradient = gradient - DOT_PRODUCT(gradient, dimer_env%nvec)*dimer_env%nvec - norm = NORM2(gradient) + norm = SQRT(DOT_PRODUCT(gradient, gradient)) IF (norm < EPSILON(0.0_dp)) THEN ! This means that NVEC is totally aligned with minimum curvature mode gradient = 0.0_dp diff --git a/src/motion/dumpdcd.F b/src/motion/dumpdcd.F index 9db62af431..8117ddef9f 100644 --- a/src/motion/dumpdcd.F +++ b/src/motion/dumpdcd.F @@ -31,8 +31,7 @@ PROGRAM dumpdcd ! The output in DCD format is in binary format. ! The input coordinates should be in Angstrom. Velocities and forces are expected to be in atomic units. -! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding -! variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -619,9 +618,9 @@ PROGRAM dumpdcd gamma_dcd = gamma END IF ! Overwrite cell information from DCD header - a = NORM2(hmat(1:3, 1)) - b = NORM2(hmat(1:3, 2)) - c = NORM2(hmat(1:3, 3)) + a = SQRT(DOT_PRODUCT(hmat(1:3, 1), hmat(1:3, 1))) + b = SQRT(DOT_PRODUCT(hmat(1:3, 2), hmat(1:3, 2))) + c = SQRT(DOT_PRODUCT(hmat(1:3, 3), hmat(1:3, 3))) ! Lattice vectors from DCD headers of VEL files are atomic units, but the CP2K cell file is in Angstrom IF (unit_string == "[a.u.]") THEN a = a/angstrom @@ -1015,8 +1014,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 = NORM2(a) - length_of_b = NORM2(b) + length_of_a = SQRT(DOT_PRODUCT(a, a)) + length_of_b = SQRT(DOT_PRODUCT(b, b)) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion/free_energy_methods.F b/src/motion/free_energy_methods.F index 1af3620815..dc4f234ead 100644 --- a/src/motion/free_energy_methods.F +++ b/src/motion/free_energy_methods.F @@ -136,11 +136,10 @@ CONTAINS CASE (do_fe_ac) CALL initf(2) ! Alchemical Changes - IF (.NOT. ASSOCIATED(force_env%mixed_env)) THEN + IF (.NOT. ASSOCIATED(force_env%mixed_env)) & CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' Free Energy calculations require the definition of a mixed env!') - END IF my_par => force_env%mixed_env%par my_val => force_env%mixed_env%val dx = force_env%mixed_env%dx diff --git a/src/motion/geo_opt.F b/src/motion/geo_opt.F index 0a1aec4be0..af142047e5 100644 --- a/src/motion/geo_opt.F +++ b/src/motion/geo_opt.F @@ -103,9 +103,8 @@ CONTAINS ! Reset counter for next iteration, unless rm_restart_info==.FALSE. my_rm_restart_info = .TRUE. IF (PRESENT(rm_restart_info)) my_rm_restart_info = rm_restart_info - IF (my_rm_restart_info) THEN + IF (my_rm_restart_info) & CALL section_vals_val_set(geo_section, "STEP_START_VAL", i_val=0) - END IF DEALLOCATE (x0) CALL gopt_f_release(gopt_env) diff --git a/src/motion/glbopt_callback.F b/src/motion/glbopt_callback.F index a42d2bfc12..5c65c43d7c 100644 --- a/src/motion/glbopt_callback.F +++ b/src/motion/glbopt_callback.F @@ -69,21 +69,18 @@ CONTAINS ! check if we passed a minimum passed_minimum = .TRUE. DO i = 1, mdctrl_data%bump_steps_upwards - IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) THEN + IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) & passed_minimum = .FALSE. - END IF END DO DO i = mdctrl_data%bump_steps_upwards + 1, mdctrl_data%bump_steps_upwards + mdctrl_data%bump_steps_downwards - IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) THEN + IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) & passed_minimum = .FALSE. - END IF END DO ! count the passed bumps and stop md_run when md_bumps_max is reached. - IF (passed_minimum) THEN + IF (passed_minimum) & mdctrl_data%md_bump_counter = mdctrl_data%md_bump_counter + 1 - END IF IF (mdctrl_data%md_bump_counter >= mdctrl_data%md_bumps_max) THEN should_stop = .TRUE. diff --git a/src/motion/gopt_f77_methods.F b/src/motion/gopt_f77_methods.F index e7483d533b..8d5b6727fd 100644 --- a/src/motion/gopt_f77_methods.F +++ b/src/motion/gopt_f77_methods.F @@ -171,13 +171,12 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & CALL unpack_subsys_particles(subsys=subsys, r=x) CASE (default_cell_method_id) ! Check for VIRIAL - IF (.NOT. virial%pv_availability) THEN + IF (.NOT. virial%pv_availability) & CALL cp_abort(__LOCATION__, & "For a cell optimization task with CELL_OPT/TYPE "// & "DIRECT_CELL_OPT, the FORCE_EVAL/STRESS_TENSOR "// & "keyword MUST be defined in the input file for the "// & "evaluation of the stress tensor, but none is found!") - END IF IF (gopt_env%cell_env%keep_volume) THEN nparticle = force_env_get_nparticle(gopt_env%force_env) idg = 3*nparticle @@ -229,9 +228,8 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & ! some callers expect pres_int to be available on all ranks. Also, here master is not necessarily a single rank. ! Assume at least master==0 CALL para_env%bcast(gopt_env%cell_env%pres_int, 0) - IF (gopt_env%cell_env%constraint_id /= fix_none) THEN + IF (gopt_env%cell_env%constraint_id /= fix_none) & CALL para_env%bcast(gopt_env%cell_env%pres_constr, 0) - END IF END IF END BLOCK CASE (default_shellcore_method_id) diff --git a/src/motion/gopt_f_methods.F b/src/motion/gopt_f_methods.F index bf385d8762..65682a68ca 100644 --- a/src/motion/gopt_f_methods.F +++ b/src/motion/gopt_f_methods.F @@ -112,12 +112,10 @@ CONTAINS CASE (default_minimization_method_id, default_ts_method_id) CALL force_env_get(gopt_env%force_env, subsys=subsys) ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) THEN + IF (gopt_env%force_env%in_use == use_qmmm) & CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - END IF - IF (gopt_env%force_env%in_use == use_qmmmx) THEN + IF (gopt_env%force_env%in_use == use_qmmmx) & CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) - END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -126,12 +124,10 @@ CONTAINS ! Store reference cell gopt_env%h_ref = cell%hmat ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) THEN + IF (gopt_env%force_env%in_use == use_qmmm) & CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - END IF - IF (gopt_env%force_env%in_use == use_qmmmx) THEN + IF (gopt_env%force_env%in_use == use_qmmmx) & CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) - END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle + 6)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -674,7 +670,7 @@ CONTAINS IF (PRESENT(pres_diff_constr) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff_constr) < ABS(pres_tol) - ELSE IF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN + ELSEIF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff) < ABS(pres_tol) END IF @@ -900,9 +896,8 @@ CONTAINS CALL write_structure_data(particle_set, cell, motion_section) CALL write_restart(force_env=force_env, root_section=root_section) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (UNIT=output_unit, FMT="(/,T20,' Reevaluating energy at the minimum')") - END IF CALL cp_eval_at(gopt_env, x0, f=etot, master=master, final_evaluation=.TRUE., & para_env=para_env) diff --git a/src/motion/helium_common.F b/src/motion/helium_common.F index f37fda09d0..d979d518fd 100644 --- a/src/motion/helium_common.F +++ b/src/motion/helium_common.F @@ -94,21 +94,21 @@ CONTAINS rx = r(1)*cell_size_inv IF (rx > 0.5_dp) THEN rx = rx - REAL(INT(rx + 0.5_dp), dp) - ELSE IF (rx < -0.5_dp) THEN + ELSEIF (rx < -0.5_dp) THEN rx = rx - REAL(INT(rx - 0.5_dp), dp) END IF ry = r(2)*cell_size_inv IF (ry > 0.5_dp) THEN ry = ry - REAL(INT(ry + 0.5_dp), dp) - ELSE IF (ry < -0.5_dp) THEN + ELSEIF (ry < -0.5_dp) THEN ry = ry - REAL(INT(ry - 0.5_dp), dp) END IF rz = r(3)*cell_size_inv IF (rz > 0.5_dp) THEN rz = rz - REAL(INT(rz + 0.5_dp), dp) - ELSE IF (rz < -0.5_dp) THEN + ELSEIF (rz < -0.5_dp) THEN rz = rz - REAL(INT(rz - 0.5_dp), dp) END IF diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index 2544940b5e..d987d46f6f 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -765,7 +765,7 @@ CONTAINS DO i_com = 1, helium%nnp%n_committee !loop over committee members ! Predict energy CALL nnp_predict(helium%nnp%arc(ind), helium%nnp, i_com) - helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) + helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) ! + helium%nnp%atom_energies(ind) !Gradients IF (PRESENT(force)) THEN @@ -1068,7 +1068,7 @@ CONTAINS p = np db = db - 1 END DO - ELSE IF (delta_bead < 0) THEN + ELSEIF (delta_bead < 0) THEN bead = ref_bead p = part db = delta_bead diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index 252ada46cc..3733c09a9d 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -661,7 +661,7 @@ CONTAINS IF (x >= 0.01_dp) EXIT END DO z = -LOG(0.01_dp) - y = LOG(x)/z + 1.0_dp + y = LOG(x)/z + 1.0_dp; cyclen = INT(helium%maxcycle*y) + 1 IF (cyclen /= helium%m_value) EXIT END DO diff --git a/src/motion/helium_types.F b/src/motion/helium_types.F index aeed271a61..835b11bcec 100644 --- a/src/motion/helium_types.F +++ b/src/motion/helium_types.F @@ -121,8 +121,7 @@ MODULE helium_types REAL(KIND=dp), DIMENSION(3) :: origin = 0.0_dp!< origin of the cell (first voxel position) REAL(KIND=dp) :: droplet_radius = 0.0_dp !< radius of the droplet - REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of - ! periodic cell (if periodic) or COM of helium + REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of periodic cell (if periodic) or COM of helium INTEGER :: sampling_method = helium_sampling_ceperley ! worm sampling parameters @@ -152,8 +151,7 @@ MODULE helium_types LOGICAL :: worm_is_closed = .FALSE.!before isector=1 -> open; isector=0 -> closed INTEGER :: iter_norot = 0!< number of iterations to try for a given imaginary time slice rotation (num inner MC loop iters) - INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) - ! (num outer MC loop iters) + INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) (num outer MC loop iters) ! INTEGER :: maxcycle = 0!< maximum cyclic permutation change to attempt INTEGER :: m_dist_type = 0!< distribution from which the cycle length m is sampled @@ -188,8 +186,7 @@ MODULE helium_types INTEGER(KIND=int_8) :: accepts = 0_int_8!< number of accepted new configurations ! REAL(KIND=dp), DIMENSION(:, :), POINTER :: tmatrix => NULL()!< ? permutation probability related - REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related - ! [use might change/new ones added/etc] + REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related [use might change/new ones added/etc] REAL(KIND=dp) :: pweight = 0.0_dp!< ? permutation probability related REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix => NULL() INTEGER, DIMENSION(:, :), POINTER :: nmatrix => NULL() @@ -211,8 +208,7 @@ MODULE helium_types TYPE(helium_vector_type) :: prarea2 = helium_vector_type()!< projected area squared TYPE(helium_vector_type) :: mominer = helium_vector_type()!< moment of inertia INTEGER :: averages_iweight = 0!< weight for restarted averages - LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages - ! have been restarted + LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages have been restarted REAL(KIND=dp) :: link_action = 0.0_dp, inter_action = 0.0_dp, pair_action = 0.0_dp @@ -270,10 +266,8 @@ MODULE helium_types INTEGER :: solute_beads = 0!< number of solute beads (pint_env%p) INTEGER :: get_helium_forces = 0!< parameter to determine whether the average or last MC force should be taken to MD CHARACTER(LEN=2), DIMENSION(:), POINTER :: solute_element => NULL()!< element names of solute atoms (pint_env%ndim/3) - TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) - ! (should be removed at some point) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent - ! on the solute DIM(p,ndim) + TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) (should be removed at some point) + REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent on the solute DIM(p,ndim) REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_inst => NULL()!< instantaneous forces exerted by He on the solute (p,ndim) CHARACTER(LEN=2), DIMENSION(:), POINTER :: ename => NULL() INTEGER :: enum = 0 diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index 13a66afdc8..f2db450a6f 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -231,7 +231,7 @@ CONTAINS IF (PRESENT(md_env)) THEN CALL get_md_env(md_env=md_env, force_env=my_force_env) - ELSE IF (PRESENT(force_env)) THEN + ELSEIF (PRESENT(force_env)) THEN my_force_env => force_env END IF @@ -551,9 +551,9 @@ CONTAINS ELSE IF (ASSOCIATED(force_env)) THEN para_env => force_env%para_env - ELSE IF (PRESENT(pint_env)) THEN + ELSEIF (PRESENT(pint_env)) THEN para_env => pint_env%logger%para_env - ELSE IF (PRESENT(helium_env)) THEN + ELSEIF (PRESENT(helium_env)) THEN ! Only needed in case that pure helium is simulated ! In this case write_restart is called only by processors ! with associated helium_env @@ -995,7 +995,7 @@ CONTAINS CALL section_vals_val_set(pint_section, "NOSE%VELOCITY%_DEFAULT_KEYWORD_", & r_vals_ptr=r_vals) - ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (tmpsec) tmpsec => section_vals_get_subs_vals(pint_section, "GLE") @@ -1326,9 +1326,8 @@ CONTAINS WRITE (stmp, *) reqlen err_str = TRIM(ADJUSTL(err_str))// & TRIM(ADJUSTL(stmp))//"'." - IF (msgLEN /= reqlen) THEN + IF (msgLEN /= reqlen) & CPABORT(err_str) - END IF ! allocate the buffer to be saved and fill it with forces ! forces should be the same on all processors, but we don't check that here @@ -1459,10 +1458,9 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(work_section%values, 2) == 1) EXIT @@ -1940,10 +1938,9 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT CALL section_vals_add_values(coord_section) @@ -2068,10 +2065,9 @@ CONTAINS CPASSERT(ss_section%ref_count > 0) section => ss_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(ss_section%values, 2) == 1) EXIT CALL section_vals_add_values(ss_section) @@ -2139,10 +2135,9 @@ CONTAINS CPASSERT(ds_section%ref_count > 0) section => ds_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(ds_section%values, 2) == 1) EXIT CALL section_vals_add_values(ds_section) @@ -2209,10 +2204,9 @@ CONTAINS CPASSERT(ww_section%ref_count > 0) section => ww_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(ww_section%values, 2) == 1) EXIT CALL section_vals_add_values(ww_section) @@ -2276,10 +2270,9 @@ CONTAINS CPASSERT(invdt_section%ref_count > 0) section => invdt_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(invdt_section%values, 2) == 1) EXIT CALL section_vals_add_values(invdt_section) diff --git a/src/motion/integrator.F b/src/motion/integrator.F index a8bd19ad1f..96de427a30 100644 --- a/src/motion/integrator.F +++ b/src/motion/integrator.F @@ -195,9 +195,8 @@ CONTAINS nshell=nshell, & particles=particles, & virial=virial) - IF (nshell /= 0) THEN + IF (nshell /= 0) & CPABORT("Langevin dynamics is not yet implemented for core-shell models") - END IF nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1652,11 +1651,10 @@ CONTAINS ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & CALL cp_abort(__LOCATION__, & "Reached the end of the Trajectory frames in the TRAJECTORY file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") - END IF END IF ! Read cell parameters from cell file if requested and if not yet available @@ -1666,11 +1664,10 @@ CONTAINS CPASSERT(trj_itimes == cell_itimes) ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & CALL cp_abort(__LOCATION__, & "Reached the end of the cell info frames in the CELL file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") - END IF END IF END IF @@ -2530,10 +2527,9 @@ CONTAINS core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial - IF (simpar%constraint) THEN + IF (simpar%constraint) & CALL pv_constraint(gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, virial, para_env) - END IF CALL virial_evaluate(atomic_kind_set, particle_set, & local_particles, virial, para_env) diff --git a/src/motion/integrator_utils.F b/src/motion/integrator_utils.F index 0e567938f2..eb6f960915 100644 --- a/src/motion/integrator_utils.F +++ b/src/motion/integrator_utils.F @@ -969,8 +969,8 @@ CONTAINS npt(:, :)%f = (1.0_dp + (3.0_dp*infree))*kin + fdotr - & 3.0_dp*simpar%p_ext*box%deth - ELSE IF (simpar%ensemble == npt_f_ensemble .OR. & - simpar%ensemble == npe_f_ensemble) THEN + ELSEIF (simpar%ensemble == npt_f_ensemble .OR. & + simpar%ensemble == npe_f_ensemble) THEN npt(:, :)%f = virial%pv_virial(:, :) + & pv_kin(:, :) + virial%pv_constraint(:, :) - & unit(:, :)*simpar%p_ext*box%deth + & @@ -980,8 +980,8 @@ CONTAINS trace = trace/3.0_dp npt(:, :)%f = trace*unit(:, :) END IF - ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. & - simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. & + simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v = box%deth vi = 1._dp/v v0 = simpar%v0 diff --git a/src/motion/mc/mc_control.F b/src/motion/mc/mc_control.F index e55faf23dd..7a9ca26164 100644 --- a/src/motion/mc/mc_control.F +++ b/src/motion/mc/mc_control.F @@ -372,9 +372,8 @@ CONTAINS CALL destroy_force_env(f_env_id, ierr, .FALSE.) IF (ierr /= 0) CPABORT("mc_create_force_env: destroy_force_env failed") - IF (PRESENT(globenv_new)) THEN + IF (PRESENT(globenv_new)) & CALL force_env_get(force_env, globenv=globenv_new) - END IF END SUBROUTINE mc_create_force_env @@ -409,10 +408,9 @@ CONTAINS TYPE(mc_input_file_type), POINTER :: mc_input_file LOGICAL, INTENT(IN) :: ionode - IF (ionode) THEN + IF (ionode) & CALL mc_make_dat_file_new(r(:, :), atom_symbols, nunits_tot, & box_length(:), 'bias_temp.dat', nchains(:), mc_input_file) - END IF CALL mc_create_force_env(bias_env, input_declaration, para_env, 'bias_temp.dat') diff --git a/src/motion/mc/mc_coordinates.F b/src/motion/mc/mc_coordinates.F index 68c12b10bf..d675054f4d 100644 --- a/src/motion/mc/mc_coordinates.F +++ b/src/motion/mc/mc_coordinates.F @@ -516,7 +516,7 @@ CONTAINS IF (exponent > exp_max_val) THEN boltz_weights(imove) = max_val - ELSE IF (exponent < exp_min_val) THEN + ELSEIF (exponent < exp_min_val) THEN boltz_weights(imove) = min_val ELSE boltz_weights(imove) = EXP(exponent) @@ -587,9 +587,8 @@ CONTAINS END IF ! make sure a configuration was chosen - IF (choosen == 0) THEN + IF (choosen == 0) & CPABORT('CBMC swap move failed to select config') - END IF ! if this is an old configuration, we always choose the first one IF (lremove) choosen = 1 @@ -762,7 +761,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSE IF (PRESENT(box)) THEN + ELSEIF (PRESENT(box)) THEN ! any molecule in box...need to find molecule type and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(:, box)), KIND=dp)) @@ -780,7 +779,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSE IF (PRESENT(molecule_type_old)) THEN + ELSEIF (PRESENT(molecule_type_old)) THEN ! any molecule of type molecule_type_old...need to find box number and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(molecule_type_old, :)), KIND=dp)) diff --git a/src/motion/mc/mc_ensembles.F b/src/motion/mc/mc_ensembles.F index 1b9c1650ca..87c18a4743 100644 --- a/src/motion/mc/mc_ensembles.F +++ b/src/motion/mc/mc_ensembles.F @@ -426,9 +426,8 @@ CONTAINS ! if we're doing a discrete volume move, we need to set up the array ! that keeps track of which direction we can move in IF (ldiscrete) THEN - IF (nboxes /= 1) THEN + IF (nboxes /= 1) & CPABORT('ldiscrete=.true. ONLY for systems with 1 box') - END IF CALL create_discrete_array(abc(:, 1), discrete_array(:, :), & discrete_step) END IF @@ -550,7 +549,7 @@ CONTAINS END DO END IF - ELSE IF (rand < pmswap) THEN + ELSEIF (rand < pmswap) THEN ! try a swap move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN @@ -570,7 +569,7 @@ CONTAINS mol_type=mol_type, nchain_total=nchain_total, nunits=nunits, & atom_names=atom_names, mass=mass) - ELSE IF (rand < pmhmc) THEN + ELSEIF (rand < pmhmc) THEN ! try hybrid Monte Carlo IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting a hybrid Monte Carlo move" @@ -596,7 +595,7 @@ CONTAINS energy_check(box_number), r_old(:, :, box_number), & rng_stream) - ELSE IF (rand < pmavbmc) THEN + ELSEIF (rand < pmavbmc) THEN ! try an AVBMC move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting an AVBMC1 move" @@ -627,9 +626,8 @@ CONTAINS EXIT END IF END DO - IF (molecule_type_swap == 0) THEN + IF (molecule_type_swap == 0) & CPABORT('Did not choose a molecule type to swap...check AVBMC input') - END IF ! now pick a molecule, automatically rejecting the move if the ! box is empty or only has one molecule @@ -751,8 +749,8 @@ CONTAINS ! figure out what kind of move we're doing IF (rand < conf_prob(1, molecule_type)) THEN move_type = 'bond' - ELSE IF (rand < (conf_prob(1, molecule_type) + & - conf_prob(2, molecule_type))) THEN + ELSEIF (rand < (conf_prob(1, molecule_type) + & + conf_prob(2, molecule_type))) THEN move_type = 'angle' ELSE move_type = 'dihedral' @@ -768,7 +766,7 @@ CONTAINS move_type, lreject, rng_stream) IF (lreject) EXIT END IF - ELSE IF (rand < pmtrans) THEN + ELSEIF (rand < pmtrans) THEN ! translate a whole molecule in the system ! pick a molecule type IF (ionode) rand = rng_stream%next() @@ -785,11 +783,10 @@ CONTAINS 'Did not choose a molecule type to translate...PMTRANS_MOL should not be all 0.0') ! now pick a molecule of that type - IF (ionode) THEN + IF (ionode) & CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) - END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -801,7 +798,7 @@ CONTAINS start_atom, box_number, bias_energy(box_number), & molecule_type, lreject, rng_stream) IF (lreject) EXIT - ELSE IF (rand < pmcltrans) THEN + ELSEIF (rand < pmcltrans) THEN ! translate a whole cluster in the system ! first, pick a box to do it for IF (ionode) rand = rng_stream%next() @@ -838,11 +835,10 @@ CONTAINS __LOCATION__, & 'Did not choose a molecule type to rotate...PMROT_MOL should not be all 0.0') - IF (ionode) THEN + IF (ionode) & CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) - END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -1275,10 +1271,9 @@ CONTAINS CPABORT('The box needs to be cubic for a virial calculation (it is easiest).') END IF IF (virial_cutoffs(nintegral_divisions) > abc(1)/2.0E0_dp) THEN - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, *) "Box length ", abc(1)*angstrom, " virial cutoff ", & - virial_cutoffs(nintegral_divisions)*angstrom - END IF + virial_cutoffs(nintegral_divisions)*angstrom CPABORT('You need a bigger box to deal with this virial cutoff (see above).') END IF @@ -1376,7 +1371,7 @@ CONTAINS IF (exponent > exp_max_val) THEN exponent = exp_max_val - ELSE IF (exponent < exp_min_val) THEN + ELSEIF (exponent < exp_min_val) THEN exponent = exp_min_val END IF mayer(itemp, ibin) = mayer(itemp, ibin) + EXP(exponent) - 1.0_dp @@ -1387,9 +1382,8 @@ CONTAINS END DO ! write out some info that keeps track of where we are IF (iw > 0) THEN - IF (MOD(ivirial, iprint) == 0) THEN + IF (MOD(ivirial, iprint) == 0) & WRITE (iw, '(A,I6,A,I6)') ' Done with config ', ivirial, ' out of ', nvirial - END IF END IF END DO diff --git a/src/motion/mc/mc_ge_moves.F b/src/motion/mc/mc_ge_moves.F index 09393baaea..fad365147d 100644 --- a/src/motion/mc/mc_ge_moves.F +++ b/src/motion/mc/mc_ge_moves.F @@ -242,9 +242,8 @@ CONTAINS end_mol = start_mol + SUM(nchains(:, ibox)) - 1 CALL check_for_overlap(bias_env(ibox)%force_env, & nchains(:, ibox), nunits(:), loverlap, mol_type(start_mol:end_mol)) - IF (loverlap) THEN + IF (loverlap) & CPABORT('Quickstep move found an overlap in the old config') - END IF END IF bias_energy_old(ibox) = last_bias_energy(ibox) END DO @@ -255,7 +254,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= -1.0E-8) THEN w = 1.0_dp - ELSE IF (energies <= -500.0_dp) THEN + ELSEIF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -273,7 +272,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= 0.0_dp) THEN w = 1.0_dp - ELSE IF (energies <= -500.0_dp) THEN + ELSEIF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -368,10 +367,9 @@ CONTAINS DO iparticle = 1, nunits_tot(ibox) particles(ibox)%list%els(iparticle)%r(1:3) = & r_old(1:3, iparticle, ibox) - IF (lbias .AND. box_flag(ibox) == 1) THEN + IF (lbias .AND. box_flag(ibox) == 1) & particles_bias(ibox)%list%els(iparticle)%r(1:3) = & - r_old(1:3, iparticle, ibox) - END IF + r_old(1:3, iparticle, ibox) END DO END DO @@ -388,10 +386,9 @@ CONTAINS DO ibox = 1, nboxes CALL cp_subsys_set(subsys(ibox)%subsys, & particles=particles(ibox)%list) - IF (lbias .AND. box_flag(ibox) == 1) THEN + IF (lbias .AND. box_flag(ibox) == 1) & CALL cp_subsys_set(subsys_bias(ibox)%subsys, & particles=particles_bias(ibox)%list) - END IF END DO ! deallocate some stuff @@ -994,7 +991,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSE IF (del_quickstep_energy < exp_min_val) THEN + ELSEIF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = min_val ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -1248,13 +1245,11 @@ CONTAINS ! add to one box, subtract from the other IF (old_cell_length(1, 1)*old_cell_length(2, 1)* & - old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN + old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) & CPABORT('GE_volume moves are trying to make box 1 smaller than 3') - END IF IF (old_cell_length(1, 2)*old_cell_length(2, 2)* & - old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN + old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) & CPABORT('GE_volume moves are trying to make box 2 smaller than 3') - END IF DO iside = 1, 3 new_cell_length(iside, 1) = (old_cell_length(1, 1)**3 + & diff --git a/src/motion/mc/mc_move_control.F b/src/motion/mc/mc_move_control.F index 7e5d6426bb..eeb70485d6 100644 --- a/src/motion/mc/mc_move_control.F +++ b/src/motion/mc/mc_move_control.F @@ -401,8 +401,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_bond%successes == 0) THEN rmbond(molecule_type) = rmbond(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_bond%successes == & - move_updates%bias_bond%attempts) THEN + ELSEIF (move_updates%bias_bond%successes == & + move_updates%bias_bond%attempts) THEN rmbond(molecule_type) = rmbond(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -429,8 +429,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_angle%successes == 0) THEN rmangle(molecule_type) = rmangle(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_angle%successes == & - move_updates%bias_angle%attempts) THEN + ELSEIF (move_updates%bias_angle%successes == & + move_updates%bias_angle%attempts) THEN rmangle(molecule_type) = rmangle(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -459,8 +459,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_dihedral%successes == 0) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_dihedral%successes == & - move_updates%bias_dihedral%attempts) THEN + ELSEIF (move_updates%bias_dihedral%successes == & + move_updates%bias_dihedral%attempts) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -489,8 +489,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_trans%successes == 0) THEN rmtrans(molecule_type) = rmtrans(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_trans%successes == & - move_updates%bias_trans%attempts) THEN + ELSEIF (move_updates%bias_trans%successes == & + move_updates%bias_trans%attempts) THEN rmtrans(molecule_type) = rmtrans(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -502,9 +502,8 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmtrans(molecule_type) > 10.0E0_dp) THEN + IF (rmtrans(molecule_type) > 10.0E0_dp) & rmtrans(molecule_type) = 10.0E0_dp - END IF ! clear the counters move_updates%bias_trans%attempts = 0 @@ -521,8 +520,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_cltrans%successes == 0) THEN rmcltrans = rmcltrans/2.0E0_dp - ELSE IF (move_updates%bias_cltrans%successes == & - move_updates%bias_cltrans%attempts) THEN + ELSEIF (move_updates%bias_cltrans%successes == & + move_updates%bias_cltrans%attempts) THEN rmcltrans = rmcltrans*2.0E0_dp ELSE ! now for the middle case @@ -534,9 +533,8 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmcltrans > 10.0E0_dp) THEN + IF (rmcltrans > 10.0E0_dp) & rmcltrans = 10.0E0_dp - END IF ! clear the counters move_updates%bias_cltrans%attempts = 0 @@ -556,8 +554,8 @@ CONTAINS IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi - ELSE IF (move_updates%bias_rot%successes == & - move_updates%bias_rot%attempts) THEN + ELSEIF (move_updates%bias_rot%successes == & + move_updates%bias_rot%attempts) THEN rmrot(molecule_type) = rmrot(molecule_type)*2.0E0_dp ! more than pi rotation is meaningless @@ -594,8 +592,8 @@ CONTAINS IF (move_updates%volume%successes == 0) THEN rmvolume = rmvolume/2.0E0_dp - ELSE IF (move_updates%volume%successes == & - move_updates%volume%attempts) THEN + ELSEIF (move_updates%volume%successes == & + move_updates%volume%attempts) THEN rmvolume = rmvolume*2.0E0_dp ELSE ! now for the middle case diff --git a/src/motion/mc/mc_moves.F b/src/motion/mc/mc_moves.F index aabf5bcf1f..bced55b54c 100644 --- a/src/motion/mc/mc_moves.F +++ b/src/motion/mc/mc_moves.F @@ -261,7 +261,7 @@ CONTAINS CALL change_bond_length(r_old, r_new, mc_par, molecule_type, & molecule_kind, dis_length, particles, rng_stream) - ELSE IF (move_type == 'angle') THEN + ELSEIF (move_type == 'angle') THEN ! record the attempt moves%angle%attempts = moves%angle%attempts + 1 @@ -338,7 +338,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value)*dis_length**2 @@ -366,7 +366,7 @@ CONTAINS moves%bias_bond%successes = moves%bias_bond%successes + 1 move_updates%bias_bond%successes = & move_updates%bias_bond%successes + 1 - ELSE IF (move_type == 'angle') THEN + ELSEIF (move_type == 'angle') THEN moves%angle%qsuccesses = moves%angle%qsuccesses + 1 move_updates%angle%successes = & move_updates%angle%successes + 1 @@ -581,7 +581,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -780,7 +780,7 @@ CONTAINS IF (dir == 1) THEN lx = .TRUE. - ELSE IF (dir == 2) THEN + ELSEIF (dir == 2) THEN ly = .TRUE. END IF @@ -822,7 +822,7 @@ CONTAINS particles%els(iunit)%r(3) = rznew + nzcm END DO - ELSE IF (ly) THEN + ELSEIF (ly) THEN ! *** ROTATE UNITS OF I AROUND y-AXIS *** @@ -884,7 +884,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1208,9 +1208,8 @@ CONTAINS END IF END IF CALL group%bcast(ltoo_small, source) - IF (ltoo_small) THEN + IF (ltoo_small) & CPABORT("Attempted a volume move where box size got too small.") - END IF ! now compute the energy CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) @@ -1228,7 +1227,7 @@ CONTAINS value = -BETA*(energy_term + volume_term + pressure_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1375,7 +1374,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSE IF (bond_list(ibond)%b == iatom) THEN + ELSEIF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1422,7 +1421,7 @@ CONTAINS ! notice we weight by the opposite masses...therefore lighter segments ! will move further - old_length = NORM2(bond_a) + old_length = SQRT(DOT_PRODUCT(bond_a, bond_a)) new_length_a = dis_length*mass_b/(mass_a + mass_b) new_length_b = dis_length*mass_a/(mass_a + mass_b) @@ -1544,7 +1543,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSE IF (bond_list(ibond)%b == iatom) THEN + ELSEIF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1592,15 +1591,15 @@ CONTAINS bond_c(i) = r_new(i, bend_list(bend_number)%c) - & r_new(i, bend_list(bend_number)%b) END DO - old_length_a = NORM2(bond_a) - old_length_c = NORM2(bond_c) + old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) + old_length_c = SQRT(DOT_PRODUCT(bond_c, bond_c)) old_angle = ACOS(DOT_PRODUCT(bond_a, bond_c)/(old_length_a*old_length_c)) DO i = 1, 3 bisector(i) = bond_a(i)/old_length_a + & ! not yet normalized bond_c(i)/old_length_c END DO - bis_length = NORM2(bisector) + bis_length = SQRT(DOT_PRODUCT(bisector, bisector)) bisector(1:3) = bisector(1:3)/bis_length ! now we need to find the cross product of the B-A and B-C vectors and normalize @@ -1608,14 +1607,14 @@ CONTAINS cross_prod(1) = bond_a(2)*bond_c(3) - bond_a(3)*bond_c(2) cross_prod(2) = bond_a(3)*bond_c(1) - bond_a(1)*bond_c(3) cross_prod(3) = bond_a(1)*bond_c(2) - bond_a(2)*bond_c(1) - cross_prod(1:3) = cross_prod(1:3)/NORM2(cross_prod) + cross_prod(1:3) = cross_prod(1:3)/SQRT(DOT_PRODUCT(cross_prod, cross_prod)) ! we have two axis of a coordinate system...let's get the third cross_prod_plane(1) = cross_prod(2)*bisector(3) - cross_prod(3)*bisector(2) cross_prod_plane(2) = cross_prod(3)*bisector(1) - cross_prod(1)*bisector(3) cross_prod_plane(3) = cross_prod(1)*bisector(2) - cross_prod(2)*bisector(1) cross_prod_plane(1:3) = cross_prod_plane(1:3)/ & - NORM2(cross_prod_plane) + SQRT(DOT_PRODUCT(cross_prod_plane, cross_prod_plane)) ! now bisector is x, cross_prod_plane is the y vector (pointing towards c), ! and cross_prod is z @@ -1637,7 +1636,7 @@ CONTAINS temp(1:3) = r_new(1:3, iatom) - & DOT_PRODUCT(cross_prod(1:3), r_new(1:3, iatom))* & cross_prod(1:3) - temp_length = NORM2(temp) + temp_length = SQRT(DOT_PRODUCT(temp, temp)) ! we can now compute all three components of the new bond vector along the ! axis defined above @@ -1668,7 +1667,7 @@ CONTAINS cross_prod(1:3) END IF - ELSE IF (atom_c(iatom) == 1) THEN + ELSEIF (atom_c(iatom) == 1) THEN ! if the y-coordinate is less than zero, we need to switch the sign when we make the vector, ! as the angle computed by the dot product can't distinguish between that @@ -1806,7 +1805,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSE IF (bond_list(ibond)%b == iatom) THEN + ELSEIF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1847,7 +1846,7 @@ CONTAINS bond_a(i) = r_new(i, torsion_list(torsion_number)%c) - & r_new(i, torsion_list(torsion_number)%b) END DO - old_length_a = NORM2(bond_a) + old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) bond_a(1:3) = bond_a(1:3)/old_length_a ! figure out how much we move each side, since we're mass-weighting, by the @@ -1881,7 +1880,7 @@ CONTAINS temp(1:3) = temp(1:3) + r_new(1:3, torsion_list(torsion_number)%b) r_new(1:3, iatom) = temp(1:3) - ELSE IF (atom_d(iatom) == 1) THEN + ELSEIF (atom_d(iatom) == 1) THEN ! shift the coords so c is at the origin r_new(1:3, iatom) = r_new(1:3, iatom) - & @@ -2215,7 +2214,7 @@ CONTAINS .NOT. lin .AND. move_type == 'out') THEN ! standard Metropolis rule prefactor = 1.0_dp - ELSE IF (.NOT. lin .AND. move_type == 'in') THEN + ELSEIF (.NOT. lin .AND. move_type == 'in') THEN prefactor = (1.0_dp - pbias(molecule_type))*volume_in/(pbias(molecule_type)*volume_out) ELSE prefactor = pbias(molecule_type)*volume_out/((1.0_dp - pbias(molecule_type))*volume_in) @@ -2230,7 +2229,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSE IF (del_quickstep_energy < exp_min_val) THEN + ELSEIF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = 0.0_dp ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -2417,7 +2416,7 @@ CONTAINS value = -BETA*(energy_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -2675,7 +2674,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/mc/mc_types.F b/src/motion/mc/mc_types.F index 25ace61db2..71b691a80f 100644 --- a/src/motion/mc/mc_types.F +++ b/src/motion/mc/mc_types.F @@ -1751,9 +1751,8 @@ CONTAINS rcutsq_max = 0.0e0_dp DO itype = 1, SIZE(potparm%pot, 1) DO jtype = itype, SIZE(potparm%pot, 2) - IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) THEN + IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) & rcutsq_max = potparm%pot(itype, jtype)%pot%rcutsq - END IF END DO END DO @@ -1866,9 +1865,8 @@ CONTAINS DO itype = 1, ntypes lnew_type = .TRUE. DO jtype = 1, itype - 1 - IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) THEN + IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) & lnew_type = .FALSE. - END IF END DO IF (lnew_type) THEN nmol_types = nmol_types + 1 @@ -2070,24 +2068,19 @@ CONTAINS ! some ensembles require multiple boxes or molecule types SELECT CASE (mc_par%ensemble) CASE ("GEMC_NPT") - IF (nmol_types <= 1) THEN + IF (nmol_types <= 1) & CPABORT('Cannot have GEMC-NPT simulation with only one molecule type') - END IF - IF (nboxes <= 1) THEN + IF (nboxes <= 1) & CPABORT('Cannot have GEMC-NPT simulation with only one box') - END IF CASE ("GEMC_NVT") - IF (nboxes <= 1) THEN + IF (nboxes <= 1) & CPABORT('Cannot have GEMC-NVT simulation with only one box') - END IF CASE ("TRADITIONAL") - IF (mc_par%pmswap > 0.0E0_dp) THEN + IF (mc_par%pmswap > 0.0E0_dp) & CPABORT('You cannot do swap moves in a system with only one box') - END IF CASE ("VIRIAL") - IF (nchain_total /= 2) THEN + IF (nchain_total /= 2) & CPABORT('You need exactly two molecules in the box to compute the second virial.') - END IF END SELECT ! can't choose an AVBMC target atom number higher than the number diff --git a/src/motion/mc/tamc_run.F b/src/motion/mc/tamc_run.F index 7be1019e15..bff6b10485 100644 --- a/src/motion/mc/tamc_run.F +++ b/src/motion/mc/tamc_run.F @@ -269,6 +269,13 @@ CONTAINS IF (simpar%v0 == 0._dp) simpar%v0 = cell%deth END IF + ! Initialize velocities possibly applying constraints at the zeroth MD step +! ! ! CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& +! ! ! l_val=write_binary_restart_file) +!! let us see if this created all the trouble +! CALL setup_velocities(force_env,simpar,globenv,md_env,md_section,constraint_section, & +! write_binary_restart_file) + ! Setup Free Energy Calculation (if required) CALL fe_env_create(fe_env, free_energy_section) CALL set_md_env(md_env=md_env, simpar=simpar, fe_env=fe_env, cell=cell, & @@ -287,6 +294,7 @@ CONTAINS force_env%meta_env%dt = force_env%meta_env%zdt CALL initialize_md_ener(md_ener, force_env, simpar) +! force_env%meta_env%dt=force_env%meta_env%zdt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MC setup up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -298,8 +306,11 @@ CONTAINS ! set some values...will use get_globenv if that ever comes around ! initialize the random numbers +! IF (para_env%is_source()) THEN rng_stream_mc = rng_stream_type(name="Random numbers for monte carlo acc/rej", & distribution_type=UNIFORM) +! ENDIF +!!!!! this should go in a routine hmc_read NULLIFY (mc_section) ALLOCATE (mc_par) @@ -317,6 +328,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "RANDOMTOSKIP", i_val=rand2skip) CPASSERT(rand2skip >= 0) temp = cp_unit_from_cp2k(simpar%temp_ext, "K") +! CALL set_mc_par(mc_par, ensemble=ensemble, nstep=nmccycles, iprint=iprint, temperature=temp, & beta=1.0_dp/temp/boltzmann*joule, exp_max_val=0.9_dp*LOG(HUGE(0.0_dp)), & @@ -360,12 +372,11 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file! "// & "You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR. "// & "Be sure the method you are using can compute the virial!") - END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -375,12 +386,11 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") - END IF END IF ! Computing Forces at zero MD step @@ -401,12 +411,15 @@ CONTAINS CALL section_vals_remove_values(work_section) END IF +! CALL force_env_calc_energy_force (force_env, calc_force=.TRUE.) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) force_env%meta_env => meta_env_saved IF (ASSOCIATED(force_env%qs_env)) THEN +! force_env%qs_env%sim_time=time +! force_env%qs_env%sim_step=itimes force_env%qs_env%sim_time = 0.0_dp force_env%qs_env%sim_step = 0 END IF @@ -421,7 +434,26 @@ CONTAINS END DO END DO END IF +! IF (force_env%meta_env%well_tempered) THEN +! force_env%meta_env%wttemperature = simpar%temp_ext +! IF (force_env%meta_env%wtgamma>EPSILON(1._dp)) THEN +! dummy=force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma-1._dp) +! IF (force_env%meta_env%delta_t>EPSILON(1._dp)) THEN +! check=ABS(force_env%meta_env%delta_t-dummy)<1.E+3_dp*EPSILON(1._dp) +! IF(.NOT.check) CALL cp_abort(__LOCATION__,& +! "Inconsistency between DELTA_T and WTGAMMA (both specified):"//& +! " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") +! ELSE +! force_env%meta_env%delta_t = dummy +! ENDIF +! ELSE +! force_env%meta_env%wtgamma = 1._dp & +! + force_env%meta_env%delta_t/force_env%meta_env%wttemperature +! ENDIF +! force_env%meta_env%invdt = 1._dp/force_env%meta_env%delta_t +! ENDIF CALL tamc_force(force_env) +! CALL metadyn_write_colvar(force_env) END IF IF (simpar%do_respa) THEN @@ -429,10 +461,16 @@ CONTAINS calc_force=.TRUE.) END IF +! CALL force_env_get( force_env, subsys=subsys) +! +! CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& +! particles=particles) + CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles, & virial, force_env%para_env) CALL md_energy(md_env, md_ener) +! CALL md_write_output(md_env) !inits the print env at itimes == 0 also writes trajectories md_stride = 1 ELSE CALL get_md_env(md_env, reftraj=reftraj) @@ -448,6 +486,7 @@ CONTAINS CALL init_mc_moves(moves) CALL init_mc_moves(gmoves) ALLOCATE (r(1:3, SIZE(particles%els))) +! ALLOCATE (r_old(1:3,size(particles%els))) CALL mc_averages_create(MCaverages) !!!!! some more buffers ! Allocate random number for Langevin Thermostat acting on COLVARS @@ -490,6 +529,7 @@ CONTAINS IF (output_unit > 0) THEN WRITE (output_unit, '(a)') "HMC|==== end initial average forces" END IF +! call set_md_env(md_env, init=.FALSE.) CALL metadyn_write_colvar(force_env) @@ -535,6 +575,8 @@ CONTAINS ! Free Energy calculation ! CALL free_energy_evaluate(md_env,should_stop,free_energy_section) + ![AME:UB] IF (should_stop) EXIT + ! Test for .EXIT_MD or for WALL_TIME to exit ! Default: ! IF so we don't overwrite the restart or append to the trajectory @@ -547,13 +589,30 @@ CONTAINS CALL external_control(should_stop, "MD", globenv=globenv) IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) +! CALL md_output(md_env,md_section,force_env%root_section,should_stop) EXIT END IF +! IF(simpar%ensemble /= reftraj_ensemble) THEN +! CALL md_energy(md_env, md_ener) +! CALL temperature_control(simpar, md_env, md_ener, force_env, logger) +! CALL comvel_control(md_ener, force_env, md_section, logger) +! CALL angvel_control(md_ener, force_env, md_section, logger) +! ELSE +! CALL md_ener_reftraj(md_env, md_ener) +! END IF + time_iter_stop = m_walltime() used_time = time_iter_stop - time_iter_start time_iter_start = time_iter_stop +!!!!! this writes the restart... +! CALL md_output(md_env,md_section,force_env%root_section,should_stop) + +! IF(simpar%ensemble == reftraj_ensemble ) THEN +! CALL write_output_reftraj(md_env) +! END IF + IF (output_unit > 0) THEN WRITE (output_unit, '(a,1x,i0)') "HMC| end z step ", istep WRITE (output_unit, '(a)') "HMC|===================================" @@ -568,6 +627,7 @@ CONTAINS CALL write_restart(md_env=md_env, root_section=force_env%root_section) ! if we need the final kinetic energy for Hybrid Monte Carlo +! hmc_ekin%final_ekin=md_ener%ekin ! Remove the iteration level CALL cp_rm_iter_level(logger%iter_info, "MD") @@ -579,12 +639,15 @@ CONTAINS DEALLOCATE (md_env) ! Clean restartable sections.. IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section) +! IF (para_env%is_source()) THEN +! ENDIF CALL MC_ENV_RELEASE(mc_env) DEALLOCATE (mc_env) DEALLOCATE (mc_par) CALL MC_MOVES_RELEASE(moves) CALL MC_MOVES_RELEASE(gmoves) DEALLOCATE (r) +! DEALLOCATE(r_old) DEALLOCATE (xieta) DEALLOCATE (An) DEALLOCATE (fz) @@ -946,6 +1009,10 @@ CONTAINS fz = 0.0_dp ishift = 0 END IF +! lrestart = .false. +! if (present(logger) .and. present(iter)) THEN +! lrestart=.true. +! ENDIF CALL get_mc_par(mc_par, nstep=nstep, iprint=iprint) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) @@ -1003,6 +1070,20 @@ CONTAINS WRITE (output_unit, '(a,f16.8)') "HMC| Running average for potential energy ", averages%ave_energy WRITE (output_unit, '(a,1x,i0)') "HMC|======== End Monte Carlo cycle ", i + ishift END IF +! IF (lrestart) THEN +! k=nstep/5 +! IF(MOD(i,k) == 0) THEN +! force_env%qs_env%sim_time=t1 +! force_env%qs_env%sim_step=it1 +! DO j=1,force_env%meta_env%n_colvar +! force_env%meta_env%metavar(j)%ff_s=fz(j)/real(i+ishift,dp) +! ENDDO +! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=-1) +! CALL section_vals_val_set(mcsec,"RANDOMTOSKIP",i_val=i+ishift) +! CALL write_restart(md_env=mdenv,root_section=force_env%root_section) +! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter) +! ENDIF +! ENDIF END DO force_env%qs_env%sim_time = t1 force_env%qs_env%sim_step = it1 @@ -1135,7 +1216,7 @@ CONTAINS ! to prevent overflows IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/md_conserved_quantities.F b/src/motion/md_conserved_quantities.F index dc65d3fd8f..1c09efe72f 100644 --- a/src/motion/md_conserved_quantities.F +++ b/src/motion/md_conserved_quantities.F @@ -637,9 +637,8 @@ CONTAINS END DO END IF - IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) THEN + IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) & CPABORT("get_part_ke: qmmm bug") - END IF END SUBROUTINE get_part_ke ! ************************************************************************************************** diff --git a/src/motion/md_energies.F b/src/motion/md_energies.F index 099c430dbc..629579deb7 100644 --- a/src/motion/md_energies.F +++ b/src/motion/md_energies.F @@ -488,12 +488,11 @@ CONTAINS CALL cp_print_key_finished_output(tempkind, logger, motion_section, "MD%PRINT%TEMP_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") - END IF END IF !Thermal Region CALL print_thermal_regions_temperature(thermal_regions, itimes, time*femtoseconds, my_pos, my_act) @@ -559,12 +558,11 @@ CONTAINS "MD%PRINT%TEMP_SHELL_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_SHELL_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_SHELL_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") - END IF END IF END IF END IF diff --git a/src/motion/md_run.F b/src/motion/md_run.F index ababfdc8ac..fbf5728dfa 100644 --- a/src/motion/md_run.F +++ b/src/motion/md_run.F @@ -283,9 +283,8 @@ CONTAINS CALL get_md_env(md_env, ehrenfest_md=ehrenfest_md) !If requested set up the REFTRAJ run - IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) THEN + IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) & CPABORT("Ehrenfest MD does not support reftraj ensemble ") - END IF IF (simpar%ensemble == reftraj_ensemble) THEN reftraj_section => section_vals_get_subs_vals(md_section, "REFTRAJ") ALLOCATE (reftraj) @@ -339,12 +338,11 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file!"// & " You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR."// & " Be sure the method you are using can compute the virial!") - END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -354,12 +352,11 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") - END IF END IF ! Computing Forces at zero MD step @@ -405,11 +402,10 @@ CONTAINS dummy = force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma - 1._dp) IF (force_env%meta_env%delta_t > EPSILON(1._dp)) THEN check = ABS(force_env%meta_env%delta_t - dummy) < 1.E+3_dp*EPSILON(1._dp) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Inconsistency between DELTA_T and WTGAMMA (both specified):"// & " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") - END IF ELSE force_env%meta_env%delta_t = dummy END IF @@ -530,9 +526,8 @@ CONTAINS IF (itimes >= simpar%max_steps) should_stop = .TRUE. ! call external hook e.g. from global optimization - IF (PRESENT(mdctrl)) THEN + IF (PRESENT(mdctrl)) & CALL mdctrl_callback(mdctrl, md_env, should_stop) - END IF IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) diff --git a/src/motion/md_vel_utils.F b/src/motion/md_vel_utils.F index 715e28439d..3bc1acde2b 100644 --- a/src/motion/md_vel_utils.F +++ b/src/motion/md_vel_utils.F @@ -269,7 +269,7 @@ CONTAINS my_ireg = ireg my_nfree = nfree my_temp = temp - ELSE IF (PRESENT(nfree)) THEN + ELSEIF (PRESENT(nfree)) THEN my_ireg = 0 my_nfree = nfree my_temp = simpar%temp_ext @@ -1257,9 +1257,8 @@ CONTAINS IF (simpar%soften_nsteps <= 0) RETURN !nothing todo - IF (ANY(is_fixed /= use_perd_none)) THEN + IF (ANY(is_fixed /= use_perd_none)) & CPABORT("Velocitiy softening with constraints is not supported.") - END IF !backup positions DO i = 1, SIZE(part) @@ -2002,9 +2001,8 @@ CONTAINS CALL get_molecule_kind(molecule_kind=molecule_kind, fixd_list=fixd_list) IF (ASSOCIATED(fixd_list)) THEN DO ifixd = 1, SIZE(fixd_list) - IF (.NOT. fixd_list(ifixd)%restraint%active) THEN + IF (.NOT. fixd_list(ifixd)%restraint%active) & is_fixed(fixd_list(ifixd)%fixd) = fixd_list(ifixd)%itype - END IF END DO END IF END DO @@ -2114,9 +2112,8 @@ CONTAINS CALL get_molecule_kind_set(molecule_kind_set=molecule_kinds%els, & nconstraint=nconstraint, & nconstraint_fixd=nconstraint_fixd) - IF (nconstraint - nconstraint_fixd /= 0) THEN + IF (nconstraint - nconstraint_fixd /= 0) & CPABORT("Only the fixed atom constraint is implemented for core-shell models") - END IF !MK CPPostcondition(.NOT.simpar%constraint,cp_failure_level,routineP,failure) CPASSERT(ASSOCIATED(shell_particles)) CPASSERT(ASSOCIATED(core_particles)) @@ -2254,9 +2251,8 @@ CONTAINS IF (init_cascade) THEN CALL section_vals_val_get(cascade_section, "ENERGY", r_val=energy) - IF (energy < 0.0_dp) THEN + IF (energy < 0.0_dp) & CPABORT("Error occurred reading &CASCADE section: Negative energy found") - END IF IF (iw > 0) THEN ekin = cp_unit_from_cp2k(energy, "keV") @@ -2270,9 +2266,8 @@ CONTAINS atom_list_section => section_vals_get_subs_vals(cascade_section, "ATOM_LIST") CALL section_vals_val_get(atom_list_section, "_DEFAULT_KEYWORD_", n_rep_val=natom) CALL section_vals_list_get(atom_list_section, "_DEFAULT_KEYWORD_", list=atom_list) - IF (natom <= 0) THEN + IF (natom <= 0) & CPABORT("Error occurred reading &CASCADE section: No atom list found") - END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,T11,A,3(11X,A),9X,A)") & @@ -2291,15 +2286,12 @@ CONTAINS no_read_error = .FALSE. READ (UNIT=line, FMT=*, ERR=999) atom_index(iatom), vatom(1:3, iatom), weight(iatom) no_read_error = .TRUE. -999 IF (.NOT. no_read_error) THEN +999 IF (.NOT. no_read_error) & CPABORT("Error occurred reading &CASCADE section. Last line read <"//TRIM(line)//">") - END IF - IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) THEN + IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) & CPABORT("Error occurred reading &CASCADE section: Invalid atom index found") - END IF - IF (weight(iatom) < 0.0_dp) THEN + IF (weight(iatom) < 0.0_dp) & CPABORT("Error occurred reading &CASCADE section: Negative weight found") - END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,I10,4(1X,F14.6))") & "CASCADE| ", atom_index(iatom), vatom(1:3, iatom), weight(iatom) @@ -2319,7 +2311,7 @@ CONTAINS END DO weight(:) = matom(:)*weight(:)*energy/norm DO iatom = 1, natom - norm = NORM2(vatom(1:3, iatom)) + norm = SQRT(DOT_PRODUCT(vatom(1:3, iatom), vatom(1:3, iatom))) vatom(1:3, iatom) = vatom(1:3, iatom)/norm END DO diff --git a/src/motion/neb_io.F b/src/motion/neb_io.F index 1cd40721df..0e23a7bbb3 100644 --- a/src/motion/neb_io.F +++ b/src/motion/neb_io.F @@ -116,37 +116,33 @@ CONTAINS ! Before continuing let's do some consistency check between keywords IF (neb_env%pot_type /= pot_neb_full) THEN ! Requires the use of colvars - IF (.NOT. neb_env%use_colvar) THEN + IF (.NOT. neb_env%use_colvar) & CALL cp_abort(__LOCATION__, & "A potential energy function based on free energy or minimum energy"// & " was requested without enabling the usage of COLVARS. Both methods"// & " are based on COLVARS definition.") - END IF ! Moreover let's check if the proper sections have been defined.. SELECT CASE (neb_env%pot_type) CASE (pot_neb_fe) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%MD") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CALL cp_abort(__LOCATION__, & "A free energy BAND (colvars projected) calculation is requested"// & " but NONE MD section was defined in the input.") - END IF CASE (pot_neb_me) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%GEO_OPT") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CALL cp_abort(__LOCATION__, & "A minimum energy BAND (colvars projected) calculation is requested"// & " but NONE GEO_OPT section was defined in the input.") - END IF END SELECT ELSE - IF (neb_env%use_colvar) THEN + IF (neb_env%use_colvar) & CALL cp_abort(__LOCATION__, & "A band calculation was requested with a full potential energy. USE_COLVAR cannot"// & " be set for this kind of calculation!") - END IF END IF ! String Method CALL section_vals_val_get(neb_section, "STRING_METHOD%SMOOTHING", r_val=neb_env%smoothing) @@ -267,10 +263,9 @@ CONTAINS END IF END DO - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" - END IF + routineN//": Done!" CALL cp_print_key_finished_output(iw, logger, neb_env%neb_section, "FINAL_BAND") diff --git a/src/motion/neb_methods.F b/src/motion/neb_methods.F index cba323ad65..9af2b50a23 100644 --- a/src/motion/neb_methods.F +++ b/src/motion/neb_methods.F @@ -462,16 +462,14 @@ CONTAINS IF (do_ls .AND. (.NOT. skip_ls)) THEN CALL neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces, & vels, particle_set, iw, output_unit, distances, diis_section, iw2) - IF (iw2 > 0) THEN + IF (iw2 > 0) & WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD after linesearch", & - stepsize - END IF + stepsize ELSE stepsize = MIN(norm*stepsize0, max_stepsize) - IF (iw2 > 0) THEN + IF (iw2 > 0) & WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD no linesearch performed", & - stepsize - END IF + stepsize END IF sline%wrk = stepsize*sline%wrk diis_on = accept_diis_step(istep > max_sd_steps, n_diis, err, crr, set_err, sline, coords, & diff --git a/src/motion/neb_opt_utils.F b/src/motion/neb_opt_utils.F index ea36fe5d36..3e1c06599d 100644 --- a/src/motion/neb_opt_utils.F +++ b/src/motion/neb_opt_utils.F @@ -228,7 +228,7 @@ CONTAINS LOGICAL, INTENT(IN) :: check_diis LOGICAL :: accepted - REAL(KIND=dp) :: costh, ref_norm, step_norm + REAL(KIND=dp) :: costh, norm1, norm2 REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp accepted = .TRUE. @@ -237,9 +237,9 @@ CONTAINS ! (a) The direction of the DIIS step, can be compared to the reference step. ! if the angle is grater than a specified value, the DIIS step is not ! acceptable. - ref_norm = NORM2(ref) - step_norm = NORM2(step) - costh = DOT_PRODUCT(ref, step)/(ref_norm*step_norm) + norm1 = SQRT(DOT_PRODUCT(ref, ref)) + norm2 = SQRT(DOT_PRODUCT(step, step)) + costh = DOT_PRODUCT(ref, step)/(norm1*norm2) IF (check_diis) THEN IF (costh < acceptance_factor(MIN(10, nv))) accepted = .FALSE. ELSE @@ -258,7 +258,7 @@ CONTAINS IF (accepted .AND. check_diis) THEN ! (b) The length of the DIIS step is limited to be no more than 10 times ! the reference step - IF (ref_norm > step_norm*10.0_dp) accepted = .FALSE. + IF (norm1 > norm2*10.0_dp) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "The length of the DIIS step is limited to be no more than 10 times", & @@ -267,10 +267,10 @@ CONTAINS END IF IF (accepted .AND. check_diis) THEN ! (d) If the DIIS matrix is nearly singular, the norm of the DIIS step - ! vector becomes small and cwrk/ref_norm becomes large, signaling a - ! numerical stability problems. If the magnitude of cwrk/ref_norm + ! vector becomes small and cwrk/norm1 becomes large, signaling a + ! numerical stability problems. If the magnitude of cwrk/norm1 ! exceeds 10^8 then the step size is assumed to be unacceptable - IF (ANY(ABS(cwrk(1:nv)/ref_norm) > 10**8_dp)) accepted = .FALSE. + IF (ANY(ABS(cwrk(1:nv)/norm1) > 10**8_dp)) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "If the DIIS matrix is nearly singular, the norm of the DIIS step", & diff --git a/src/motion/neb_utils.F b/src/motion/neb_utils.F index 7f38f3c615..264b4260d7 100644 --- a/src/motion/neb_utils.F +++ b/src/motion/neb_utils.F @@ -118,7 +118,8 @@ CONTAINS CALL rmsd3(particle_set, coords%xyz(:, i), coords%xyz(:, i0), & iw, rotate=my_rotate) END IF - distance = NORM2(coords%wrk(:, i) - coords%wrk(:, i0)) + distance = SQRT(DOT_PRODUCT(coords%wrk(:, i) - coords%wrk(:, i0), & + coords%wrk(:, i) - coords%wrk(:, i0))) END SUBROUTINE neb_replica_distance @@ -223,12 +224,11 @@ CONTAINS DO iatom = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for REPLICA coordinates. Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") - END IF READ (parser%input_line, *) dummy_char, r(1:3) ic = 3*(iatom - 1) coords%xyz(ic + 1:ic + 3, i_rep) = r(1:3)*bohr @@ -737,7 +737,7 @@ CONTAINS ! String method.. tangent(:) = 0.0_dp END SELECT - distance0 = NORM2(tangent(:)) + distance0 = SQRT(DOT_PRODUCT(tangent(:), tangent(:))) IF (distance0 /= 0.0_dp) tangent(:) = tangent(:)/distance0 END SUBROUTINE get_tangent @@ -849,7 +849,7 @@ CONTAINS ALLOCATE (dtmp1(nsize_wrk)) dtmp1(:) = forces%wrk(:, i) - dot_product_band(neb_env, forces%wrk(:, i), tangent, Mmatrix)*tangent forces%wrk(:, i) = dtmp1 - tmp = NORM2(dtmp1) + tmp = SQRT(DOT_PRODUCT(dtmp1, dtmp1)) dtmp1(:) = dtmp1(:)/tmp ! Project out only the spring component interfering with the ! orthogonal gradient of the band diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index 8e9e1464c4..1f59bcbb61 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -182,7 +182,7 @@ CONTAINS CHARACTER(len=2*default_string_length) :: msg CHARACTER(len=default_path_length) :: output_file_name, project_name INTEGER :: handle, iat, ibead, icont, idim, idir, & - ierr, ig, itmp, nrep, prep + ierr, ig, itmp, nrep, prep, stat LOGICAL :: explicit, ltmp REAL(kind=dp) :: dt, mass, omega TYPE(cp_subsys_type), POINTER :: subsys @@ -377,7 +377,9 @@ CONTAINS pint_env%uf_h(pint_env%p, pint_env%ndim), & pint_env%centroid(pint_env%ndim), & pint_env%rtmp_ndim(pint_env%ndim), & - pint_env%rtmp_natom(pint_env%ndim/3)) + pint_env%rtmp_natom(pint_env%ndim/3), & + STAT=stat) + CPASSERT(stat == 0) pint_env%x = 0._dp pint_env%v = 0._dp pint_env%f = 0._dp @@ -474,6 +476,7 @@ CONTAINS pint_env%gle%loc_num_gle = pint_env%p*pint_env%ndim pint_env%gle%glob_num_gle = pint_env%gle%loc_num_gle ALLOCATE (pint_env%gle%map_info%index(pint_env%gle%loc_num_gle)) + CPASSERT(stat == 0) DO itmp = 1, pint_env%gle%loc_num_gle pint_env%gle%map_info%index(itmp) = itmp END DO @@ -1165,9 +1168,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & CPABORT("Invalid size of MOTION%PINT%BEADS%COORD") - END IF ic = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1335,9 +1337,8 @@ CONTAINS WRITE (stmp, *) n_rep_val msg = "Invalid number of atoms in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (3*n_rep_val /= pint_env%ndim) THEN + IF (3*n_rep_val /= pint_env%ndim) & CPABORT(msg) - END IF DO ia = 1, pint_env%ndim/3 CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & i_rep_val=ia, r_vals=r_vals) @@ -1346,9 +1347,8 @@ CONTAINS WRITE (stmp, *) itmp msg = "Number of coordinates != 3 in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (itmp /= 3) THEN + IF (itmp /= 3) & CPABORT(msg) - END IF DO ib = 1, pint_env%p DO ic = 1, 3 idim = 3*(ia - 1) + ic @@ -1464,9 +1464,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & CPABORT("Invalid size of MOTION%PINT%BEAD%VELOCITY") - END IF itmp = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1643,9 +1642,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & CPABORT("Invalid size of MOTION%PINT%NOSE%COORD") - END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1672,9 +1670,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & CPABORT("Invalid size of MOTION%PINT%NOSE%VELOCITY") - END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1690,7 +1687,7 @@ CONTAINS END IF END IF - ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (input_section) input_section => section_vals_get_subs_vals(pint_env%input, & "MOTION%PINT%GLE") diff --git a/src/motion/pint_piglet.F b/src/motion/pint_piglet.F index 781149afb0..0170324d7e 100644 --- a/src/motion/pint_piglet.F +++ b/src/motion/pint_piglet.F @@ -493,8 +493,7 @@ CONTAINS END DO END DO - ! the piglet is such a strong thermostat, that it messes up the "exact" integration. - ! The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) + ! the piglet is such a strong thermostat, that it messes up the "exact" integration. The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) piglet_therm%thermostat_energy = piglet_therm%thermostat_energy - 0.5_dp*delta_ekin CALL timestop(handle) diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index c305ca9656..5d9d1bed66 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -148,7 +148,7 @@ CONTAINS np = 2**il ! number of points to be generated at this level dl = n/(2*np) ! interval betw points (in index numbers) - vrnc = vrnc/2.0_dp ! variance at this level (=t at level 0) + vrnc = vrnc/2.0_dp; ! variance at this level (=t at level 0) ! loop over points added in this level DO ip = 0, np - 1 diff --git a/src/motion/reftraj_util.F b/src/motion/reftraj_util.F index 00d61232d1..55daf473eb 100644 --- a/src/motion/reftraj_util.F +++ b/src/motion/reftraj_util.F @@ -112,22 +112,20 @@ CONTAINS END IF reftraj%isnap = nskip - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Reached the end of the trajectory file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") - END IF ! Cell File IF (reftraj%info%variable_volume) THEN IF (nskip > 0) THEN CALL parser_get_next_line(reftraj%info%cell_parser, nskip, at_end=my_end) END IF - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Reached the end of the cell file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") - END IF END IF reftraj%natom = natom diff --git a/src/motion/rt_propagation.F b/src/motion/rt_propagation.F index 67170aa565..5e72c71fbc 100644 --- a/src/motion/rt_propagation.F +++ b/src/motion/rt_propagation.F @@ -294,8 +294,7 @@ CONTAINS CALL rt_initialize_rho_from_mos(rtp, mos) END IF ELSE - ! The wavefunction was minimized using a linear scaling method. - ! The density matrix is therefore taken from the ls_scf_env. + !The wavefunction was minimized using a linear scaling method. The density matrix is therefore taken from the ls_scf_env. CALL get_rtp(rtp=rtp, rho_old=rho_old, rho_new=rho_new) DO ispin = 1, SIZE(rho_old)/2 re = 2*ispin - 1 @@ -418,9 +417,8 @@ CONTAINS CALL cp_iterate(logger%iter_info, last=(i_step == max_steps), iter_nr=i_step) rtp%converged = .FALSE. DO i_iter = 1, max_iter - IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) THEN + IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) & CALL qs_ks_did_change(qs_env%ks_env, s_mstruct_changed=.TRUE.) - END IF rtp%iter = i_iter CALL propagation_step(qs_env, rtp, rtp_control) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) @@ -446,10 +444,9 @@ CONTAINS END DO CALL cp_rm_iter_level(logger%iter_info, "MD") - IF (.NOT. rtp%converged) THEN + IF (.NOT. rtp%converged) & CALL cp_abort(__LOCATION__, "propagation did not converge, "// & "either increase MAX_ITER or use a smaller TIMESTEP") - END IF CALL timestop(handle) @@ -620,9 +617,8 @@ CONTAINS CALL set_ks_env(ks_env, complex_ks=imag_ks) IF (imag_ks) THEN CALL qs_ks_allocate_basics(qs_env, is_complex=imag_ks) - IF (.NOT. dft_control%rtp_control%fixed_ions) THEN + IF (.NOT. dft_control%rtp_control%fixed_ions) & CALL rtp_create_SinvH_imag(rtp, dft_control%nspins) - END IF END IF ! h diff --git a/src/motion/simpar_methods.F b/src/motion/simpar_methods.F index b9b5058f74..0e25a66a64 100644 --- a/src/motion/simpar_methods.F +++ b/src/motion/simpar_methods.F @@ -320,19 +320,17 @@ CONTAINS CALL section_vals_get(tmp_section, explicit=simpar%constraint) IF (simpar%constraint) THEN CALL section_vals_val_get(tmp_section, "SHAKE_TOLERANCE", r_val=simpar%shake_tol) - IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN + IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) & CALL cp_warn(__LOCATION__, & "Shake tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 1000*EPSILON!") - END IF simpar%shake_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%shake_tol) CALL section_vals_val_get(tmp_section, "ROLL_TOLERANCE", r_val=simpar%roll_tol) - IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN + IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) & CALL cp_warn(__LOCATION__, & "Roll tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up roll_tol to 1000*EPSILON!") - END IF simpar%roll_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%roll_tol) END IF diff --git a/src/motion/thermal_region_utils.F b/src/motion/thermal_region_utils.F index b90e95b7af..7d1a6aee4c 100644 --- a/src/motion/thermal_region_utils.F +++ b/src/motion/thermal_region_utils.F @@ -425,14 +425,12 @@ CONTAINS TRIM(my_reg)//" which is not allowed!") END IF ELSE - IF (.NOT. ipart > 0) THEN + IF (.NOT. ipart > 0) & CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is non-positive!") - END IF - IF (.NOT. ipart <= particles%n_els) THEN + IF (.NOT. ipart <= particles%n_els) & CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is out of bounds!") - END IF END IF END SUBROUTINE set_t_region_index diff --git a/src/motion/thermostat/al_system_dynamics.F b/src/motion/thermostat/al_system_dynamics.F index 935d2959e4..c17af73a3b 100644 --- a/src/motion/thermostat/al_system_dynamics.F +++ b/src/motion/thermostat/al_system_dynamics.F @@ -72,23 +72,20 @@ CONTAINS my_shell_adiabatic = .FALSE. map_info => al%map_info - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "INIT") - END IF IF (al%tau_nh <= 0.0_dp) THEN CALL al_OU_step(0.5_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post OU") - END IF ELSE ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 1st OU") - END IF ! Compute the kinetic energy for the region to thermostat for the (T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & @@ -102,9 +99,8 @@ CONTAINS ! Recompute the kinetic energy for the region to thermostat (for the T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & local_molecules, molecule_set, group, vel=vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post rescale_vel") - END IF ! quarter step of chi CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.FALSE.) @@ -112,9 +108,8 @@ CONTAINS ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 2nd OU") - END IF END IF ! Recompute the final kinetic energy for the region to thermostat @@ -192,7 +187,7 @@ CONTAINS iparticle_local, jj, last_atom, nmol_local, nparticle, nparticle_kind, nparticle_local LOGICAL :: check, present_vel REAL(KIND=dp) :: mass - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w(:, :) TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(molecule_type), POINTER :: molecule diff --git a/src/motion/thermostat/al_system_init.F b/src/motion/thermostat/al_system_init.F index 776589c531..f68e657e98 100644 --- a/src/motion/thermostat/al_system_init.F +++ b/src/motion/thermostat/al_system_init.F @@ -130,10 +130,9 @@ CONTAINS work_section => section_vals_get_subs_vals(section_vals=al_section, & subsection_name="MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (restart .NEQV. explicit) THEN + IF (restart .NEQV. explicit) & CALL cp_abort(__LOCATION__, & "You need to define both CHI and MASS sections (or none) in the AD_LANGEVIN section") - END IF restart = restart .AND. explicit IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section, keyword_name="_DEFAULT_KEYWORD_", & diff --git a/src/motion/thermostat/barostat_types.F b/src/motion/thermostat/barostat_types.F index 0fcea72931..b5227e3243 100644 --- a/src/motion/thermostat/barostat_types.F +++ b/src/motion/thermostat/barostat_types.F @@ -118,16 +118,14 @@ CONTAINS ! User defined virial screening CALL section_vals_val_get(barostat_section, "VIRIAL", i_val=barostat%virial_components) check = barostat%virial_components == do_clv_xyz .OR. simpar%ensemble == npt_f_ensemble - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "The screening of the components of "// & "the virial is available only with the NPT_F ensemble!") - END IF ELSE - IF (explicit) THEN + IF (explicit) & CALL cp_warn(__LOCATION__, & "A barostat has been defined with an MD ensemble which does not support barostat! "// & "Its definition will be ignored!") - END IF END IF END SUBROUTINE create_barostat_type diff --git a/src/motion/thermostat/barostat_utils.F b/src/motion/thermostat/barostat_utils.F index 9c03aa5a03..0028cd607a 100644 --- a/src/motion/thermostat/barostat_utils.F +++ b/src/motion/thermostat/barostat_utils.F @@ -75,7 +75,7 @@ CONTAINS baro_kin = baro_kin + 0.5_dp*npt(i, j)%v**2*npt(i, j)%mass END DO END DO - ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v0 = simpar%v0 iv0 = 1._dp/v0 v_shock = simpar%v_shock diff --git a/src/motion/thermostat/extended_system_init.F b/src/motion/thermostat/extended_system_init.F index 733677c944..1f3feae8b0 100644 --- a/src/motion/thermostat/extended_system_init.F +++ b/src/motion/thermostat/extended_system_init.F @@ -126,10 +126,9 @@ CONTAINS restart = explicit work_section2 => section_vals_get_subs_vals(work_section, "MASS") CALL section_vals_get(work_section2, explicit=explicit) - IF (restart .NEQV. explicit) THEN + IF (restart .NEQV. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "MASS section (or none) in the BAROSTAT section") - END IF restart = explicit .AND. restart END IF @@ -617,24 +616,21 @@ CONTAINS restart = explicit work_section => section_vals_get_subs_vals(nose_section, "COORD") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) THEN + IF (.NOT. restart .AND. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") - END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) THEN + IF (.NOT. restart .AND. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") - END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "FORCE") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) THEN + IF (.NOT. restart .AND. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") - END IF restart = explicit .AND. restart END IF diff --git a/src/motion/thermostat/extended_system_mapping.F b/src/motion/thermostat/extended_system_mapping.F index de819b53ab..24296d6be1 100644 --- a/src/motion/thermostat/extended_system_mapping.F +++ b/src/motion/thermostat/extended_system_mapping.F @@ -333,9 +333,8 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 - END IF END DO END DO @@ -429,9 +428,8 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 - END IF END DO END DO diff --git a/src/motion/thermostat/gle_system_dynamics.F b/src/motion/thermostat/gle_system_dynamics.F index 819e98448c..9bbbf2728d 100644 --- a/src/motion/thermostat/gle_system_dynamics.F +++ b/src/motion/thermostat/gle_system_dynamics.F @@ -289,7 +289,7 @@ CONTAINS L(i, i) = 1.0_dp D(i) = SST(i, i) DO j = 1, i - 1 - L(i, j) = SST(i, j) + L(i, j) = SST(i, j); DO k = 1, j - 1 L(i, j) = L(i, j) - L(i, k)*L(j, k)*D(k) END DO diff --git a/src/motion/thermostat/thermostat_utils.F b/src/motion/thermostat/thermostat_utils.F index 3cfc8a24bb..f3e5828f48 100644 --- a/src/motion/thermostat/thermostat_utils.F +++ b/src/motion/thermostat/thermostat_utils.F @@ -384,9 +384,8 @@ CONTAINS DO ipart = first_atom, last_atom natom_local = natom_local + 1 ! only map the correct region to the thermostat - IF (thermolist(ipart) /= HUGE(0)) THEN + IF (thermolist(ipart) /= HUGE(0)) & thermostat_info%map_loc_thermo_gen(natom_local) = thermolist(ipart) - END IF END DO END DO END DO @@ -453,7 +452,7 @@ CONTAINS qmmm_env) TYPE(section_vals_type), POINTER :: region_sections INTEGER, INTENT(INOUT), OPTIONAL :: sum_of_thermostats - INTEGER, POINTER :: thermolist(:) + INTEGER, DIMENSION(:), POINTER :: thermolist(:) TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(molecule_list_type), POINTER :: molecules TYPE(particle_list_type), POINTER :: particles @@ -653,21 +652,19 @@ CONTAINS nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) THEN + IF (sum_of_thermostats < 1) & CALL cp_abort(__LOCATION__, & "A thermostat type DEFINED is requested but no thermostat "// & "regions are defined in THERMOSTAT/DEFINE_REGION.") - END IF CASE (do_region_thermal) ! Similar to defined region above, but in THERMAL_REGION%DEFINE_REGION nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) THEN + IF (sum_of_thermostats < 1) & CALL cp_abort(__LOCATION__, & "A thermostat type THERMAL is requested but no thermal "// & "regions are defined in THERMAL_REGION/DEFINE_REGION.") - END IF END SELECT ! Here we decide which parallel algorithm to use. @@ -1085,25 +1082,19 @@ CONTAINS atomic_kind => particle_set(ipart)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, mass=mass) IF (present_vel) THEN - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*vel(1, ipart)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*vel(2, ipart)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*vel(3, ipart)**2 - END IF ELSE - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*particle_set(ipart)%v(1)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*particle_set(ipart)%v(2)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*particle_set(ipart)%v(3)**2 - END IF END IF END DO END DO diff --git a/src/motion/vibrational_analysis.F b/src/motion/vibrational_analysis.F index cdefc2aa4d..88128bdefa 100644 --- a/src/motion/vibrational_analysis.F +++ b/src/motion/vibrational_analysis.F @@ -653,7 +653,7 @@ CONTAINS DO j = 1, nvib D_deriv(:) = D_deriv(:) + dip_deriv(:, j)*Hint2(j, i) END DO - intensities_d(i) = NORM2(D_deriv) + intensities_d(i) = SQRT(DOT_PRODUCT(D_deriv, D_deriv)) P_deriv = 0._dp DO j = 1, nvib ! P_deriv has units bohr^2/sqrt(a.u.) @@ -970,7 +970,7 @@ CONTAINS work(:) = work - norm*D(:, i) END DO ! Check norm of the new generated vector - norm = NORM2(work) + norm = SQRT(DOT_PRODUCT(work, work)) IF (norm >= 10E4_dp*thrs_motion) THEN ! Accept new vector ifound = ifound + 1 diff --git a/src/motion/xyz2dcd.F b/src/motion/xyz2dcd.F index 91cacc54bc..7ccc80c0aa 100644 --- a/src/motion/xyz2dcd.F +++ b/src/motion/xyz2dcd.F @@ -13,8 +13,7 @@ PROGRAM xyz2dcd ! ! Note: The input coordinates and the cell vectors should be in Angstrom. -! Uncomment the following line if this module is available (e.g. with gfortran) -! and comment the corresponding variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -368,9 +367,9 @@ PROGRAM xyz2dcd a(1:3) = h(1:3, 1) b(1:3) = h(1:3, 2) c(1:3) = h(1:3, 3) - abc(1) = NORM2(a(1:3)) - abc(2) = NORM2(b(1:3)) - abc(3) = NORM2(c(1:3)) + abc(1) = SQRT(DOT_PRODUCT(a(1:3), a(1:3))) + abc(2) = SQRT(DOT_PRODUCT(b(1:3), b(1:3))) + abc(3) = SQRT(DOT_PRODUCT(c(1:3), c(1:3))) alpha = angle(b(1:3), c(1:3))*degree beta = angle(a(1:3), c(1:3))*degree gamma = angle(a(1:3), b(1:3))*degree @@ -580,8 +579,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 = NORM2(a) - length_of_b = NORM2(b) + length_of_a = SQRT(DOT_PRODUCT(a, a)) + length_of_b = SQRT(DOT_PRODUCT(b, b)) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion_utils.F b/src/motion_utils.F index 518479b9b3..d83916a8e3 100644 --- a/src/motion_utils.F +++ b/src/motion_utils.F @@ -180,7 +180,7 @@ CONTAINS END DO ! Normalize Translations DO i = 1, 3 - norm = NORM2(Tr(:, i)) + norm = SQRT(DOT_PRODUCT(Tr(:, i), Tr(:, i))) Tr(:, i) = Tr(:, i)/norm END DO dof = 3 @@ -445,9 +445,8 @@ CONTAINS CALL section_vals_val_get(root_section, "MOTION%PRINT%TRAJECTORY%CHARGE_EXTENDED", & l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) THEN + IF (i > 1) & CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected, ") - END IF END IF IF (new_file) THEN CALL m_timestamp(timestamp) diff --git a/src/mp2_cphf.F b/src/mp2_cphf.F index b79c447ade..17064b72ff 100644 --- a/src/mp2_cphf.F +++ b/src/mp2_cphf.F @@ -1204,9 +1204,8 @@ CONTAINS precond(ispin)%local_data(:, :)*residual(ispin)%local_data(:, :) END DO ELSE - IF (mp2_env%ri_grad%polak_ribiere) THEN + IF (mp2_env%ri_grad%polak_ribiere) & residual_new_dot_diff_search_vec_old = accurate_dot_product_spin(residual, diff_search_vector) - END IF DO ispin = 1, nspins diff_search_vector(ispin)%local_data(:, :) = & @@ -1811,8 +1810,7 @@ CONTAINS deb = force(1)%overlap_admm(1:3, 1) IF (use_virial) e_dummy = third_tr(virial%pv_virial) END IF - ! Add the second half of the projector deriatives contracting the first order - ! density matrix with the fockian in the auxiliary basis + ! Add the second half of the projector deriatives contracting the first order density matrix with the fockian in the auxiliary basis IF (do_exx) THEN CALL admm_projection_derivative(qs_env, matrix_ks_aux, matrix_p_mp2) ELSE diff --git a/src/mp2_eri.F b/src/mp2_eri.F index 41e5c51153..0f8887f897 100644 --- a/src/mp2_eri.F +++ b/src/mp2_eri.F @@ -743,11 +743,9 @@ CONTAINS basis_set_a => basis_set_list_a(ikind)%gto_basis_set ! When RI_AUX NONE is invoked, the pointers to basis_set_a and basis_set_b are created, ! but not filled. Therefore, we check for the association and the number of entries. - IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE - IF (SUM(basis_set_a%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_a) .OR. SUM(basis_set_a%nsgf_set) <= 0) CYCLE basis_set_b => basis_set_list_b(jkind)%gto_basis_set - IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE - IF (SUM(basis_set_b%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_b) .OR. SUM(basis_set_b%nsgf_set) <= 0) CYCLE atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) diff --git a/src/mp2_gpw.F b/src/mp2_gpw.F index a4e5b00af6..98525dd116 100644 --- a/src/mp2_gpw.F +++ b/src/mp2_gpw.F @@ -139,11 +139,11 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_gpw_main' - INTEGER :: blacs_grid_layout, color_sub, dimen_RI, dimen_RI_red, eri_method, handle, ispin, & - local_unit_nr, my_group_L_end, my_group_L_size, my_group_L_start, nmo, nspins, & - potential_type, ri_metric_type - INTEGER, ALLOCATABLE, DIMENSION(:) :: bse_lev_virt, ends_array_mc, ends_array_mc_block, & - gw_corr_lev_occ, gw_corr_lev_virt, homo, starts_array_mc, starts_array_mc_block + INTEGER :: blacs_grid_layout, bse_lev_virt, color_sub, dimen_RI, dimen_RI_red, eri_method, & + handle, ispin, local_unit_nr, my_group_L_end, my_group_L_size, my_group_L_start, nmo, & + nspins, potential_type, ri_metric_type + INTEGER, ALLOCATABLE, DIMENSION(:) :: ends_array_mc, ends_array_mc_block, gw_corr_lev_occ, & + gw_corr_lev_virt, homo, starts_array_mc, starts_array_mc_block INTEGER, DIMENSION(3) :: periodic LOGICAL :: blacs_repeatable, do_bse, do_im_time, do_kpoints_cubic_RPA, my_do_gw, & my_do_ri_mp2, my_do_ri_rpa, my_do_ri_sos_laplace_mp2 @@ -151,6 +151,7 @@ CONTAINS Emp2_EX_BB, eps_gvg_rspace_old, & eps_pgf_orb_old, eps_rho_rspace_old REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Eigenval + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: BIb_C_bse_ab, BIb_C_bse_ij REAL(KIND=dp), DIMENSION(:), POINTER :: mo_eigenvalues TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(block_ind_type), ALLOCATABLE, & @@ -173,9 +174,10 @@ CONTAINS TYPE(dbt_type) :: t_3c_M TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_O TYPE(dft_control_type), POINTER :: dft_control - TYPE(group_dist_d1_type) :: gd_array, gd_B_all + TYPE(group_dist_d1_type) :: gd_array, gd_B_all, gd_B_occ_bse, & + gd_B_virt_bse TYPE(group_dist_d1_type), ALLOCATABLE, & - DIMENSION(:) :: gd_B_occ_bse, gd_B_virt_bse, gd_B_virtual + DIMENSION(:) :: gd_B_virtual TYPE(hfx_compression_type), ALLOCATABLE, & DIMENSION(:, :, :) :: t_3c_O_compressed TYPE(kpoint_type), POINTER :: kpoints, kpoints_from_DFT @@ -187,8 +189,7 @@ CONTAINS TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(three_dim_real_array), ALLOCATABLE, & - DIMENSION(:) :: BIb_C, BIb_C_bse_ab, BIb_C_bse_ij, & - BIb_C_gw + DIMENSION(:) :: BIb_C, BIb_C_gw CALL timeset(routineN, handle) @@ -340,7 +341,7 @@ CONTAINS ! check if we want to do ri-g0w0 on top of ri-rpa my_do_gw = mp2_env%ri_rpa%do_ri_g0w0 - ALLOCATE (gw_corr_lev_occ(nspins), gw_corr_lev_virt(nspins), bse_lev_virt(nspins)) + ALLOCATE (gw_corr_lev_occ(nspins), gw_corr_lev_virt(nspins)) gw_corr_lev_occ(1) = mp2_env%ri_g0w0%corr_mos_occ gw_corr_lev_virt(1) = mp2_env%ri_g0w0%corr_mos_virt IF (nspins == 2) THEN @@ -349,18 +350,20 @@ CONTAINS END IF IF (do_bse) THEN + IF (nspins > 1) THEN + CPABORT("BSE not implemented for open shell calculations") + END IF !Keep default behavior for occupied ! We do not implement an explicit bse_lev_occ here, because the small number of occupied levels ! does not critically influence the memory - ! bse_lev_virt is per-spin (= the per-spin GW-corrected virtual count): the (ab|K) block is sized per spin - bse_lev_virt(:) = gw_corr_lev_virt(:) + bse_lev_virt = gw_corr_lev_virt(1) END IF ! After the components are inside of the routines, we can move this line insight the branch ALLOCATE (mo_coeff_o(nspins), mo_coeff_v(nspins), mo_coeff_all(nspins), mo_coeff_gw(nspins)) ! Always allocate for usage in call of replicate_mat_to_subgroup - ALLOCATE (mo_coeff_o_bse(nspins), mo_coeff_v_bse(nspins)) + ALLOCATE (mo_coeff_o_bse(1), mo_coeff_v_bse(1)) ! for imag. time, we do not need this IF (.NOT. do_im_time) THEN @@ -374,7 +377,7 @@ CONTAINS mo_coeff_o(ispin)%matrix, mo_coeff_v(ispin)%matrix, & mo_coeff_all(ispin)%matrix, mo_coeff_gw(ispin)%matrix, & my_do_gw, gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), do_bse, & - bse_lev_virt(ispin), mo_coeff_o_bse(ispin)%matrix, mo_coeff_v_bse(ispin)%matrix, & + bse_lev_virt, mo_coeff_o_bse(1)%matrix, mo_coeff_v_bse(1)%matrix, & mp2_env%mp2_gpw%eps_filter) END DO @@ -516,12 +519,10 @@ CONTAINS END IF IF (do_bse) THEN - DO ispin = 1, nspins - CALL dbcsr_release(mo_coeff_o_bse(ispin)%matrix) - CALL dbcsr_release(mo_coeff_v_bse(ispin)%matrix) - DEALLOCATE (mo_coeff_o_bse(ispin)%matrix) - DEALLOCATE (mo_coeff_v_bse(ispin)%matrix) - END DO + CALL dbcsr_release(mo_coeff_o_bse(1)%matrix) + CALL dbcsr_release(mo_coeff_v_bse(1)%matrix) + DEALLOCATE (mo_coeff_o_bse(1)%matrix) + DEALLOCATE (mo_coeff_v_bse(1)%matrix) END IF DEALLOCATE (mo_coeff_o_bse, mo_coeff_v_bse) @@ -558,9 +559,8 @@ CONTAINS starts_array_mc, ends_array_mc, & starts_array_mc_block, ends_array_mc_block, calc_forces) - IF (mp2_env%ri_rpa%do_rse) THEN + IF (mp2_env%ri_rpa%do_rse) & CALL rse_energy(qs_env, mp2_env, para_env, dft_control, mo_coeff, homo, Eigenval) - END IF IF (do_im_time) THEN IF (ASSOCIATED(mat_P_global%matrix)) THEN diff --git a/src/mp2_grids.F b/src/mp2_grids.F index 39c9f1f5b6..b252e372b8 100644 --- a/src/mp2_grids.F +++ b/src/mp2_grids.F @@ -108,15 +108,6 @@ CONTAINS CALL determine_energy_range(qs_env, para_env, homo, Eigenval, do_ri_sos_laplace_mp2, & do_kpoints_cubic_RPA, Emin, Emax, e_range, e_fermi) - ! Open-shell uses ONE minimax grid for the combined [min gap, max span] over both spins (the - ! superset covers each channel, so it is accurate; per-spin grids would only be more efficient). - IF (SIZE(homo) > 1) THEN - CALL cp_hint(__LOCATION__, & - "Open-shell RPA/GW uses one minimax grid spanning [min gap, max span] across "// & - "both spin channels; raise QUADRATURE_POINTS if QP convergence is marginal for "// & - "strongly spin-asymmetric systems.") - END IF - CALL greenx_get_minimax_grid(unit_nr, num_integ_points, emin, emax, & tau_tj, tau_wj, qs_env%mp2_env%ri_g0w0%regularization_minimax, & tj, wj, weights_cos_tf_t_to_w, & @@ -142,13 +133,12 @@ CONTAINS my_regularization = regularization IF (num_integ_points > 20 .AND. e_range < 100.0_dp) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL cp_warn(__LOCATION__, & "You requested a large minimax grid (> 20 points) for a small minimax range R (R < 100). "// & "That may lead to numerical "// & "instabilities when computing minimax grid weights. You can prevent small ranges by choosing "// & "a larger basis set with higher angular momenta or alternatively using all-electron calculations.") - END IF END IF IF (.NOT. do_ri_sos_laplace_mp2) THEN diff --git a/src/mp2_integrals.F b/src/mp2_integrals.F index f42d1a1a91..f82734ab4f 100644 --- a/src/mp2_integrals.F +++ b/src/mp2_integrals.F @@ -200,8 +200,9 @@ CONTAINS ri_metric, gd_B_occ_bse, gd_B_virt_bse) TYPE(three_dim_real_array), ALLOCATABLE, & - DIMENSION(:), INTENT(OUT) :: BIb_C, BIb_C_gw, BIb_C_bse_ij, & - BIb_C_bse_ab + DIMENSION(:), INTENT(OUT) :: BIb_C, BIb_C_gw + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & + INTENT(OUT) :: BIb_C_bse_ij, BIb_C_bse_ab TYPE(group_dist_d1_type), INTENT(OUT) :: gd_array TYPE(group_dist_d1_type), ALLOCATABLE, & DIMENSION(:), INTENT(OUT) :: gd_B_virtual @@ -236,8 +237,8 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: starts_array_mc, ends_array_mc, & starts_array_mc_block, & ends_array_mc_block - INTEGER, INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt - INTEGER, DIMENSION(:), INTENT(IN) :: bse_lev_virt + INTEGER, INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, & + bse_lev_virt LOGICAL, INTENT(IN) :: do_im_time, do_kpoints_cubic_RPA TYPE(kpoint_type), POINTER :: kpoints TYPE(dbt_type), INTENT(OUT) :: t_3c_M @@ -248,22 +249,21 @@ CONTAINS TYPE(block_ind_type), ALLOCATABLE, & DIMENSION(:, :, :) :: t_3c_O_ind TYPE(libint_potential_type), INTENT(IN) :: ri_metric - TYPE(group_dist_d1_type), ALLOCATABLE, & - DIMENSION(:), INTENT(OUT) :: gd_B_occ_bse, gd_B_virt_bse + TYPE(group_dist_d1_type), INTENT(OUT) :: gd_B_occ_bse, gd_B_virt_bse CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_ri_gpw_compute_in' INTEGER :: cm, cut_memory, cut_memory_int, eri_method, gw_corr_lev_total, handle, handle2, & handle4, i, i_counter, i_mem, ibasis, ispin, itmp(2), j, jcell, kcell, LLL, min_bsize, & - my_B_all_end, my_B_all_size, my_B_all_start, my_group_L_end, my_group_L_size, & - my_group_L_start, n_rep, natom, ngroup, nimg, nkind, nspins, potential_type, & - ri_metric_type + my_B_all_end, my_B_all_size, my_B_all_start, my_B_occ_bse_end, my_B_occ_bse_size, & + my_B_occ_bse_start, my_B_virt_bse_end, my_B_virt_bse_size, my_B_virt_bse_start, & + my_group_L_end, my_group_L_size, my_group_L_start, n_rep, natom, ngroup, nimg, nkind, & + nspins, potential_type, ri_metric_type INTEGER(int_8) :: nze INTEGER, ALLOCATABLE, DIMENSION(:) :: dist_AO_1, dist_AO_2, dist_RI, & - ends_array_mc_block_int, ends_array_mc_int, my_B_occ_bse_end, my_B_occ_bse_size, & - my_B_occ_bse_start, my_B_size, my_B_virt_bse_end, my_B_virt_bse_size, & - my_B_virt_bse_start, my_B_virtual_end, my_B_virtual_start, sizes_AO, sizes_AO_split, & - sizes_RI, sizes_RI_split, starts_array_mc_block_int, starts_array_mc_int, virtual + ends_array_mc_block_int, ends_array_mc_int, my_B_size, my_B_virtual_end, & + my_B_virtual_start, sizes_AO, sizes_AO_split, sizes_RI, sizes_RI_split, & + starts_array_mc_block_int, starts_array_mc_int, virtual INTEGER, DIMENSION(2, 3) :: bounds INTEGER, DIMENSION(3) :: bounds_3c, pcoord, pdims, pdims_t3c, & periodic @@ -283,9 +283,9 @@ CONTAINS TYPE(distribution_3d_type) :: dist_3d TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER :: basis_set_ao, basis_set_ri_aux TYPE(gto_basis_set_type), POINTER :: orb_basis, ri_basis + TYPE(intermediate_matrix_type) :: intermed_mat_bse_ab, intermed_mat_bse_ij TYPE(intermediate_matrix_type), ALLOCATABLE, & - DIMENSION(:) :: intermed_mat, intermed_mat_bse_ab, & - intermed_mat_bse_ij, intermed_mat_gw + DIMENSION(:) :: intermed_mat, intermed_mat_gw TYPE(mp_cart_type) :: mp_comm_t3c_2 TYPE(neighbor_list_3c_type) :: nl_3c TYPE(pw_c1d_gs_type) :: pot_g, rho_g @@ -434,8 +434,8 @@ CONTAINS END IF mem_for_iaK = dimen_RI*REAL(SUM(homo*virtual), KIND=dp)*8.0_dp/(1024_dp**2) - mem_for_ijK = dimen_RI*REAL(SUM(homo(1:nspins)**2), KIND=dp)*8.0_dp/(1024_dp**2) - mem_for_abK = dimen_RI*REAL(SUM(bse_lev_virt(1:nspins)**2), KIND=dp)*8.0_dp/(1024_dp**2) + mem_for_ijK = dimen_RI*REAL(SUM([homo(1)]**2), KIND=dp)*8.0_dp/(1024_dp**2) + mem_for_abK = dimen_RI*REAL(SUM([bse_lev_virt]**2), KIND=dp)*8.0_dp/(1024_dp**2) IF (.NOT. do_im_time) THEN WRITE (unit_nr, '(T3,A,T66,F11.2,A4)') 'RI_INFO| Total memory for (ia|K) integrals:', & @@ -490,31 +490,21 @@ CONTAINS CALL get_group_dist(gd_B_all, para_env_sub%mepos, my_B_all_start, my_B_all_end, my_B_all_size) IF (do_bse) THEN - ! virt x virt slab size bse_lev_virt(ispin) is per-spin, so gd_B_virt_bse is an array; - ! the occupied count homo(ispin) is per-spin, so gd_B_occ_bse and the bse intermediates are arrays - ALLOCATE (intermed_mat_bse_ab(nspins), intermed_mat_bse_ij(nspins), gd_B_occ_bse(nspins), gd_B_virt_bse(nspins)) - ALLOCATE (my_B_occ_bse_start(nspins), my_B_occ_bse_end(nspins), my_B_occ_bse_size(nspins)) - ALLOCATE (my_B_virt_bse_start(nspins), my_B_virt_bse_end(nspins), my_B_virt_bse_size(nspins)) - DO ispin = 1, nspins - CALL create_group_dist(gd_B_virt_bse(ispin), para_env_sub%num_pe, bse_lev_virt(ispin)) - CALL get_group_dist(gd_B_virt_bse(ispin), para_env_sub%mepos, my_B_virt_bse_start(ispin), & - my_B_virt_bse_end(ispin), my_B_virt_bse_size(ispin)) - ! virt x virt matrices - CALL create_intermediate_matrices(intermed_mat_bse_ab(ispin), mo_coeff_v_bse(ispin)%matrix, & - bse_lev_virt(ispin), bse_lev_virt(ispin), & - "bse_ab_"//TRIM(ADJUSTL(cp_to_string(ispin))), blacs_env_sub, para_env_sub) + ! virt x virt matrices + CALL create_intermediate_matrices(intermed_mat_bse_ab, mo_coeff_v_bse(1)%matrix, bse_lev_virt, bse_lev_virt, & + "bse_ab", blacs_env_sub, para_env_sub) - ! occ x occ matrices - ! We do not implement bse_lev_occ here, because the small number of occupied levels - ! does not critically influence the memory - CALL create_intermediate_matrices(intermed_mat_bse_ij(ispin), mo_coeff_o_bse(ispin)%matrix, & - homo(ispin), homo(ispin), & - "bse_ij_"//TRIM(ADJUSTL(cp_to_string(ispin))), blacs_env_sub, para_env_sub) + CALL create_group_dist(gd_B_virt_bse, para_env_sub%num_pe, bse_lev_virt) + CALL get_group_dist(gd_B_virt_bse, para_env_sub%mepos, my_B_virt_bse_start, my_B_virt_bse_end, my_B_virt_bse_size) - CALL create_group_dist(gd_B_occ_bse(ispin), para_env_sub%num_pe, homo(ispin)) - CALL get_group_dist(gd_B_occ_bse(ispin), para_env_sub%mepos, my_B_occ_bse_start(ispin), & - my_B_occ_bse_end(ispin), my_B_occ_bse_size(ispin)) - END DO + ! occ x occ matrices + ! We do not implement bse_lev_occ here, because the small number of occupied levels + ! does not critically influence the memory + CALL create_intermediate_matrices(intermed_mat_bse_ij, mo_coeff_o_bse(1)%matrix, homo(1), homo(1), & + "bse_ij", blacs_env_sub, para_env_sub) + + CALL create_group_dist(gd_B_occ_bse, para_env_sub%num_pe, homo(1)) + CALL get_group_dist(gd_B_occ_bse, para_env_sub%mepos, my_B_occ_bse_start, my_B_occ_bse_end, my_B_occ_bse_size) END IF END IF @@ -539,14 +529,11 @@ CONTAINS IF (do_bse) THEN - ALLOCATE (BIb_C_bse_ij(nspins), BIb_C_bse_ab(nspins)) - DO ispin = 1, nspins - ALLOCATE (BIb_C_bse_ij(ispin)%array(my_group_L_size, my_B_occ_bse_size(ispin), homo(ispin))) - BIb_C_bse_ij(ispin)%array = 0.0_dp + ALLOCATE (BIb_C_bse_ij(my_group_L_size, my_B_occ_bse_size, homo(1))) + BIb_C_bse_ij = 0.0_dp - ALLOCATE (BIb_C_bse_ab(ispin)%array(my_group_L_size, my_B_virt_bse_size(ispin), bse_lev_virt(ispin))) - BIb_C_bse_ab(ispin)%array = 0.0_dp - END DO + ALLOCATE (BIb_C_bse_ab(my_group_L_size, my_B_virt_bse_size, bse_lev_virt)) + BIb_C_bse_ab = 0.0_dp END IF @@ -609,27 +596,25 @@ CONTAINS IF (do_bse) THEN - DO ispin = 1, nspins - ! B^ab_P matrix elements for BSE - DO LLL = 1, my_group_L_size - CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ab(ispin), & - BIb_C_bse_ab(ispin)%array(LLL, :, :), & - mo_coeff_v_bse(ispin)%matrix, mo_coeff_v_bse(ispin)%matrix, eps_filter, & - my_B_all_end, my_B_all_start) - END DO - CALL contract_B_L(BIb_C_bse_ab(ispin)%array, my_Lrows, gd_B_virt_bse(ispin)%sizes, gd_array%sizes, & - qs_env%mp2_env%eri_blksize, ngroup, color_sub, para_env, para_env_sub) - - ! B^ij_P matrix elements for BSE - DO LLL = 1, my_group_L_size - CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ij(ispin), & - BIb_C_bse_ij(ispin)%array(LLL, :, :), & - mo_coeff_o(ispin)%matrix, mo_coeff_o(ispin)%matrix, eps_filter, & - my_B_occ_bse_end(ispin), my_B_occ_bse_start(ispin)) - END DO - CALL contract_B_L(BIb_C_bse_ij(ispin)%array, my_Lrows, gd_B_occ_bse(ispin)%sizes, gd_array%sizes, & - qs_env%mp2_env%eri_blksize, ngroup, color_sub, para_env, para_env_sub) + ! B^ab_P matrix elements for BSE + DO LLL = 1, my_group_L_size + CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ab, & + BIb_C_bse_ab(LLL, :, :), & + mo_coeff_v_bse(1)%matrix, mo_coeff_v_bse(1)%matrix, eps_filter, & + my_B_all_end, my_B_all_start) END DO + CALL contract_B_L(BIb_C_bse_ab, my_Lrows, gd_B_virt_bse%sizes, gd_array%sizes, qs_env%mp2_env%eri_blksize, & + ngroup, color_sub, para_env, para_env_sub) + + ! B^ij_P matrix elements for BSE + DO LLL = 1, my_group_L_size + CALL ao_to_mo_and_store_B(para_env_sub, mat_munu_local_L(LLL), intermed_mat_bse_ij, & + BIb_C_bse_ij(LLL, :, :), & + mo_coeff_o(1)%matrix, mo_coeff_o(1)%matrix, eps_filter, & + my_B_occ_bse_end, my_B_occ_bse_start) + END DO + CALL contract_B_L(BIb_C_bse_ij, my_Lrows, gd_B_occ_bse%sizes, gd_array%sizes, qs_env%mp2_env%eri_blksize, & + ngroup, color_sub, para_env, para_env_sub) END IF @@ -693,11 +678,8 @@ CONTAINS END IF IF (do_bse) THEN - DO ispin = 1, nspins - CALL release_intermediate_matrices(intermed_mat_bse_ab(ispin)) - CALL release_intermediate_matrices(intermed_mat_bse_ij(ispin)) - END DO - DEALLOCATE (intermed_mat_bse_ab, intermed_mat_bse_ij) + CALL release_intermediate_matrices(intermed_mat_bse_ab) + CALL release_intermediate_matrices(intermed_mat_bse_ij) END IF ! imag. time = low-scaling SOS-MP2, RPA, GW diff --git a/src/mp2_ri_2c.F b/src/mp2_ri_2c.F index 4ff515a0c1..33beee71d0 100644 --- a/src/mp2_ri_2c.F +++ b/src/mp2_ri_2c.F @@ -916,9 +916,9 @@ CONTAINS hab=L_local_col, first_b=my_group_L_start, last_b=my_group_L_end, & eri_method=eri_method) - ELSE IF (eri_method == do_eri_gpw .OR. & - (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & - .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN + ELSEIF (eri_method == do_eri_gpw .OR. & + (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & + .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN CALL mp2_eri_2c_integrate_gpw(qs_env, para_env_sub, my_group_L_start, my_group_L_end, & natom, potential, sab_orb_sub, L_local_col, kind_of) diff --git a/src/mp2_ri_gpw.F b/src/mp2_ri_gpw.F index 39ce98dfc8..93e6956add 100644 --- a/src/mp2_ri_gpw.F +++ b/src/mp2_ri_gpw.F @@ -384,8 +384,7 @@ CONTAINS END IF END DO IF (my_alpha_beta_case .AND. calc_forces) THEN - ! Is just an approximation, but the call does not allow it, - ! it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI + ! Is just an approximation, but the call does not allow it, it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(ispin) + my_B_size(jspin), dimen_RI) ELSE CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(jspin), dimen_RI) @@ -452,12 +451,11 @@ CONTAINS my_Emp2_Ex = my_Emp2_Ex + sym_fac*local_ab(a_global, b)*external_ab(b, a)/ & (Eigenval(homo(ispin) + a_global, ispin) + Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) - IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) THEN + IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) & t_ab(a_global, b) = -(amp_fac*local_ab(a_global, b) - mp2_env%scale_T*external_ab(b, a))/ & (Eigenval(homo(ispin) + a_global, ispin) + & Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) - END IF END DO END DO END DO @@ -675,9 +673,8 @@ CONTAINS ! We do not need this matrix later, so deallocate it here to safe memory IF (calc_forces) DEALLOCATE (mp2_env%ri_grad%PQ_half) - IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN + IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) & DEALLOCATE (mp2_env%ri_grad%operator_half) - END IF CALL dgemm_counter_write(dgemm_counter, para_env) @@ -1397,8 +1394,7 @@ CONTAINS ! 2*(NR/NG)+2*(1-(NR/NG))*(o/NB+NB-2)/NG = (NR/NG)*(1-(o/NB+NB-2)/NG)+(o/NB+NB-2)/NG ! We are looking for the minimum of the communication volume, ! thus, if the prefactor of (NR/NG) is smaller than zero, use the largest possible replication group size. - ! If the factor is larger than zero, set the replication group size to 1. - ! (For small systems and a large number of subgroups) + ! If the factor is larger than zero, set the replication group size to 1. (For small systems and a large number of subgroups) ! Replication group size = 1 implies that the integration group size equals the number of subgroups integ_group_size = ngroup @@ -2551,9 +2547,8 @@ CONTAINS DO iiB = 1, homo ! diagonal elements already updated DO jjB = iiB + 1, homo - IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) THEN + IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) & num_sing_ij = num_sing_ij + 1 - END IF END DO END DO diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 266f1edd5d..9c98de42df 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -331,7 +331,7 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(matrix_P_munu_local) CALL dbcsr_deallocate_matrix_set(mat_munu_local) - ELSE IF (eri_method == do_eri_gpw) THEN + ELSEIF (eri_method == do_eri_gpw) THEN CALL get_qs_env(qs_env, ks_env=ks_env) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) diff --git a/src/mpiwrap/message_passing.F b/src/mpiwrap/message_passing.F index 15f8d39d2c..3c62f4ee9b 100644 --- a/src/mpiwrap/message_passing.F +++ b/src/mpiwrap/message_passing.F @@ -33,8 +33,7 @@ MODULE message_passing #include "../base/base_uses.f90" -! To simplify the transition between the old MPI module and the F08-style module, -! we introduce these constants to switch between the required handle types +! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types ! Unfortunately, Fortran does not offer something like typedef in C++ #if defined(__parallel) && defined(__MPI_F08) #define MPI_DATA_TYPE TYPE(MPI_Datatype) @@ -61,11 +60,9 @@ MODULE message_passing #endif #if defined(__parallel) -! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines -! (problems with types and ranks explosion), +! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion), ! we do not quite know what is in the module, so we can not include any.... -! to nevertheless get checking for what is included, we use the mpi module -! without use clause, getting all there is +! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is #if defined(__MPI_F08) USE mpi_f08 #else diff --git a/src/mpiwrap/mp_perf_env.F b/src/mpiwrap/mp_perf_env.F index 7a28a50ebc..9c331367a6 100644 --- a/src/mpiwrap/mp_perf_env.F +++ b/src/mpiwrap/mp_perf_env.F @@ -13,8 +13,6 @@ MODULE mp_perf_env USE kinds, ONLY: dp #include "../base/base_uses.f90" - IMPLICIT NONE - PRIVATE PUBLIC :: mp_perf_env_type diff --git a/src/mpiwrap/mp_perf_test.F b/src/mpiwrap/mp_perf_test.F index 675e5b675d..3e9a701fbc 100644 --- a/src/mpiwrap/mp_perf_test.F +++ b/src/mpiwrap/mp_perf_test.F @@ -34,8 +34,6 @@ MODULE mp_perf_test #endif #endif - IMPLICIT NONE - PRIVATE PUBLIC :: mpi_perf_test @@ -336,9 +334,8 @@ CONTAINS END IF rcount = Nloc DO itests = 1, 3 - IF (ionode .AND. output_unit > 0) THEN + IF (ionode .AND. output_unit > 0) & WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------" - END IF ! *** reference *** DO j = 1, Nprocs DO i = 1, Nloc diff --git a/src/mscfg_methods.F b/src/mscfg_methods.F index 823de2c554..ee2a906e27 100644 --- a/src/mscfg_methods.F +++ b/src/mscfg_methods.F @@ -191,10 +191,8 @@ CONTAINS smear_almo_scf = qs_env%scf_control%smear%do_smear IF (smear_almo_scf) THEN scf_section => section_vals_get_subs_vals(dft_section, "SCF") - !! Get total number of added MOs - CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) - !! Get total number of atoms (assume consecutive atoms) - tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 + CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) !! Get total number of added MOs + tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 !! Get total number of atoms (assume consecutive atoms) !! Check that number of added MOs matches the number of atoms !! (to ensure compatibility, since each fragment will be computed with such parameters) IF (tot_isize /= tot_added_mos) THEN @@ -202,8 +200,7 @@ CONTAINS END IF !! Get total number of MOs CALL get_qs_env(qs_env, mos=mos) - !! Unrestricted ALMO is not implemented yet - IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") + IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") !! Unrestricted ALMO is not implemented yet CALL get_mo_set(mo_set=mos(1), nmo=nmo) !! Initialize storage of MO energies for ALMO smearing CPASSERT(ASSOCIATED(almo_scf_env)) diff --git a/src/mulliken.F b/src/mulliken.F index 0f77d12cf9..d1fe760821 100644 --- a/src/mulliken.F +++ b/src/mulliken.F @@ -726,7 +726,7 @@ CONTAINS charges(i) = charges(i) + p_block(i, j)*s_block(i, j) END DO END DO - ELSE IF (iblock_col == iatom) THEN + ELSEIF (iblock_col == iatom) THEN DO j = 1, SIZE(p_block, 2) DO i = 1, SIZE(p_block, 1) charges(j) = charges(j) + p_block(i, j)*s_block(i, j) diff --git a/src/negf_control_types.F b/src/negf_control_types.F index 0defb5e2e0..8d9c718239 100644 --- a/src/negf_control_types.F +++ b/src/negf_control_types.F @@ -183,19 +183,16 @@ CONTAINS IF (ALLOCATED(negf_control%contacts)) THEN DO i = SIZE(negf_control%contacts), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) THEN + IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) & DEALLOCATE (negf_control%contacts(i)%atomlist_bulk) - END IF - IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) THEN + IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) & DEALLOCATE (negf_control%contacts(i)%atomlist_screening) - END IF IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell)) THEN DO j = SIZE(negf_control%contacts(i)%atomlist_cell), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) THEN + IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) & DEALLOCATE (negf_control%contacts(i)%atomlist_cell(j)%vector) - END IF END DO DEALLOCATE (negf_control%contacts(i)%atomlist_cell) END IF @@ -368,9 +365,8 @@ CONTAINS CALL section_vals_val_get(negf_section, "INTEGRATION_MIN_POINTS", i_val=negf_control%integr_min_points) CALL section_vals_val_get(negf_section, "INTEGRATION_MAX_POINTS", i_val=negf_control%integr_max_points) - IF (negf_control%integr_max_points < negf_control%integr_min_points) THEN + IF (negf_control%integr_max_points < negf_control%integr_min_points) & negf_control%integr_max_points = negf_control%integr_min_points - END IF CALL section_vals_val_get(negf_section, "MAX_SCF", i_val=negf_control%max_scf) @@ -432,9 +428,8 @@ CONTAINS DO i_rep = 1, n_rep IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN - IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN + IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) & natoms_total = natoms_total + SIZE(negf_control%contacts(i_rep)%atomlist_screening) - END IF END IF END DO diff --git a/src/negf_env_types.F b/src/negf_env_types.F index f4d2564279..7ddea351b0 100644 --- a/src/negf_env_types.F +++ b/src/negf_env_types.F @@ -290,10 +290,9 @@ CONTAINS (icontact, sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, & para_env, negf_env, sub_env, negf_control, negf_section, log_unit, is_separate=.TRUE.) ELSE - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the separate bulk DFT calculation" - END IF + " from the separate bulk DFT calculation" CALL force_env_get(sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, qs_env=qs_env_contact) CALL qs_energies(qs_env_contact, consistent_energies=.FALSE., calc_forces=.FALSE.) CALL negf_env_contact_init_matrices(contact_env=negf_env%contacts(icontact), sub_env=sub_env, & @@ -315,10 +314,9 @@ CONTAINS CALL negf_env_contact_read_write_hs(icontact, force_env, para_env, negf_env, sub_env, negf_control, negf_section, & log_unit, is_separate=.FALSE., is_dft_entire=is_dft_entire) ELSE - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the entire system bulk DFT calculation" - END IF + " from the entire system bulk DFT calculation" IF (.NOT. is_dft_entire) CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) is_dft_entire = .TRUE. CALL negf_env_contact_init_matrices_gamma(contact_env=negf_env%contacts(icontact), & @@ -331,9 +329,8 @@ CONTAINS END DO ! stage 3: obtain an initial KS-matrix for the scattering region - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(/,T2,A,T70)') "NEGF| Construct the Kohn-Sham matrix for the scattering region" - END IF IF (negf_control%read_write_HS) THEN CALL negf_env_scatt_read_write_hs(force_env, para_env, negf_env, sub_env, negf_control, negf_section, log_unit, & is_dft_entire=is_dft_entire) @@ -918,22 +915,18 @@ CONTAINS CALL cp_abort(__LOCATION__, & "Primary and secondary bulk contact cells should not overlap ") ELSE IF (r2_origin_cell(1) < r2_origin_cell(2)) THEN - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(1)%vector))) - END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(1)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(2)%vector))) - END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(2)%vector(:) ELSE - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(2)%vector))) - END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(2)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(1)%vector))) - END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(1)%vector(:) END IF IF (.NOT. contact_control%read_write_HS) THEN @@ -1697,9 +1690,8 @@ CONTAINS natoms_cell0 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) THEN + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) & natoms_cell0 = natoms_cell0 + 1 - END IF END DO ALLOCATE (atomlist_cell0(natoms_cell0)) @@ -1779,9 +1771,8 @@ CONTAINS natoms_cell1 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) THEN + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) & natoms_cell1 = natoms_cell1 + 1 - END IF END DO ALLOCATE (atomlist_cell1(natoms_cell1)) diff --git a/src/negf_green_methods.F b/src/negf_green_methods.F index bc0d5076e0..f7ff34dbbf 100644 --- a/src/negf_green_methods.F +++ b/src/negf_green_methods.F @@ -363,9 +363,8 @@ CONTAINS ! omega * S_S - H_S - V_Hartree CALL cp_fm_to_cfm(msourcer=s_s, mtarget=g_ret_s) CALL cp_cfm_scale_and_add_fm(omega, g_ret_s, z_mone, h_s) - IF (PRESENT(v_hartree_s)) THEN + IF (PRESENT(v_hartree_s)) & CALL cp_cfm_scale_and_add_fm(z_one, g_ret_s, z_one, v_hartree_s) - END IF ! g_ret_s = [omega * S_S - H_S - \sum_{contact} self_energy_{contact}^{ret.} ]^-1 CALL cp_cfm_scale_and_add(z_one, g_ret_s, z_mone, self_energy_ret_sum) diff --git a/src/negf_integr_cc.F b/src/negf_integr_cc.F index 87d553d2c0..c4facd0f4f 100644 --- a/src/negf_integr_cc.F +++ b/src/negf_integr_cc.F @@ -173,9 +173,8 @@ CONTAINS ! rescale all but the end-points, as they are transformed into themselves (-1.0 -> -1.0; 0.0 -> 0.0). ! Moreover, by applying this rescaling transformation to the end-points we cannot guarantee the exact ! result due to rounding errors in evaluation of COS function. - IF (nnodes_half > 2) THEN + IF (nnodes_half > 2) & CALL rescale_nodes_cos(nnodes_half - 2, cc_env%tnodes(2:)) - END IF SELECT CASE (interval_id) CASE (cc_interval_full) diff --git a/src/negf_integr_simpson.F b/src/negf_integr_simpson.F index d732913bdf..9d57abd95c 100644 --- a/src/negf_integr_simpson.F +++ b/src/negf_integr_simpson.F @@ -312,9 +312,8 @@ CONTAINS END IF IF (nintervals > 0) THEN - IF (SIZE(xnodes_unity) < 4*nintervals) THEN + IF (SIZE(xnodes_unity) < 4*nintervals) & nintervals = SIZE(xnodes_unity)/4 - END IF DO interval = 1, nintervals xnodes_unity(4*interval - 3) = 0.125_dp* & @@ -554,16 +553,14 @@ CONTAINS DO interval = 1, nintervals_exist errors(interval) = subintervals(interval)%error - IF (subintervals(interval)%error > subintervals(interval)%conv) THEN + IF (subintervals(interval)%error > subintervals(interval)%conv) & nintervals = nintervals + 1 - END IF END DO CALL sort(errors, nintervals_exist, inds) - IF (nintervals > 0) THEN + IF (nintervals > 0) & ALLOCATE (sr_env%subintervals(nintervals)) - END IF nintervals = 0 DO ipoint = nintervals_exist, 1, -1 diff --git a/src/negf_integr_utils.F b/src/negf_integr_utils.F index 82651f58fa..4cb86ead5f 100644 --- a/src/negf_integr_utils.F +++ b/src/negf_integr_utils.F @@ -81,9 +81,11 @@ CONTAINS SELECT CASE (shape_id) CASE (contour_shape_linear) - IF (PRESENT(xnodes)) CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) + IF (PRESENT(xnodes)) & + CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) - IF (PRESENT(weights)) weights(:) = b - a + IF (PRESENT(weights)) & + weights(:) = b - a CASE (contour_shape_arc) ALLOCATE (tnodes_angle(nnodes)) @@ -91,7 +93,8 @@ CONTAINS tnodes_angle(:) = tnodes(:) CALL rescale_nodes_pi_phi(a, b, nnodes, tnodes_angle) - IF (PRESENT(xnodes)) CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) + IF (PRESENT(xnodes)) & + CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) IF (PRESENT(weights)) THEN rscale = (pi - get_arc_smallest_angle(a, b))*get_arc_radius(a, b) diff --git a/src/negf_matrix_utils.F b/src/negf_matrix_utils.F index 5e957b06c3..5b55feab07 100644 --- a/src/negf_matrix_utils.F +++ b/src/negf_matrix_utils.F @@ -342,9 +342,8 @@ CONTAINS DO ic = 1, ncell rep = i_to_c(direction_axis_abs, ic) - IF (ABS(rep) <= 2) THEN + IF (ABS(rep) <= 2) & CALL dbcsr_add(matrix_cells_raw(rep)%matrix, mat_nosym(ic)%matrix, 1.0_dp, 1.0_dp) - END IF END DO IF (direction_axis >= 0) THEN @@ -470,17 +469,15 @@ CONTAINS block=rblock, found=found) IF (found) THEN iproc = rank_contact(irow, icol) - IF (iproc > 0) THEN + IF (iproc > 0) & send_nelems(iproc) = send_nelems(iproc) + SIZE(rblock) - END IF END IF CALL dbcsr_get_block_p(matrix=matrix_contact, row=irow, col=icol, block=rblock, found=found) IF (found) THEN iproc = rank_device(irow, icol) - IF (iproc > 0) THEN + IF (iproc > 0) & recv_nelems(iproc) = recv_nelems(iproc) + SIZE(rblock) - END IF END IF END DO END DO @@ -488,16 +485,14 @@ CONTAINS ! pack blocks ALLOCATE (recv_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & ALLOCATE (recv_packed_blocks(iproc)%vector(recv_nelems(iproc))) - END IF END DO ALLOCATE (send_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (send_nelems(iproc) > 0) THEN + IF (send_nelems(iproc) > 0) & ALLOCATE (send_packed_blocks(iproc)%vector(send_nelems(iproc))) - END IF END DO send_nelems(:) = 0 @@ -561,17 +556,15 @@ CONTAINS CALL para_env%irecv(recv_packed_blocks(iproc)%vector, iproc - 1, recv_handlers(iproc), 1) END IF ELSE - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & CALL MOVE_ALLOC(send_packed_blocks(iproc)%vector, recv_packed_blocks(iproc)%vector) - END IF END IF END DO ! unpack blocks DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & CALL recv_handlers(iproc)%wait() - END IF END DO recv_nelems(:) = 0 @@ -608,25 +601,22 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) THEN + IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) & CALL send_handlers(iproc)%wait() - END IF END DO ! release memory DEALLOCATE (recv_handlers, send_handlers) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & DEALLOCATE (send_packed_blocks(iproc)%vector) - END IF END DO DEALLOCATE (send_packed_blocks) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) THEN + IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) & DEALLOCATE (recv_packed_blocks(iproc)%vector) - END IF END DO DEALLOCATE (recv_packed_blocks) @@ -754,9 +744,8 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & nomirror = nomirror + 1 - END IF END DO ! create the mirror imgs diff --git a/src/negf_methods.F b/src/negf_methods.F index 8487a70d82..8fda96399e 100644 --- a/src/negf_methods.F +++ b/src/negf_methods.F @@ -304,9 +304,8 @@ CONTAINS ! restart.hs ! ---------- - IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) THEN + IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) & CALL negf_write_restart(filename, negf_env, negf_control) - END IF ! current ! ------- @@ -966,9 +965,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_circular(ispin)) - END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_fm(ispin), & @@ -985,9 +983,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_linear(ispin)) - END IF END DO IF (nspins > 1) THEN @@ -1152,9 +1149,8 @@ CONTAINS END IF END IF - IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) THEN + IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) & CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) - END IF CALL get_qs_env(qs_env, blacs_env=blacs_env, do_kpoints=do_kpoints, dft_control=dft_control, & matrix_ks_kp=matrix_ks_qs_kp, para_env=para_env, rho=rho_struct, subsys=subsys) @@ -1399,9 +1395,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_circular(ispin)) - END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_new_fm(ispin), & @@ -1418,9 +1413,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_linear(ispin)) - END IF ! non-equilibrium part delta = 0.0_dp @@ -1445,9 +1439,8 @@ CONTAINS base_contact=base_contact, & matrix_s_global=matrix_s_fm, & g_surf_cache=g_surf_nonequiv(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_nonequiv(ispin)) - END IF END IF END DO @@ -2141,9 +2134,8 @@ CONTAINS DO ipoint = 1, npoints IF (ASSOCIATED(g_ret_s(ipoint)%matrix_struct)) THEN CALL cp_cfm_finish_copy_general(g_ret_s(ipoint), info1(ipoint)) - IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) THEN + IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) & CALL cp_cfm_cleanup_copy_general(info1(ipoint)) - END IF END IF END DO diff --git a/src/negf_subgroup_types.F b/src/negf_subgroup_types.F index 2eb0b3a5a6..e5efda48c6 100644 --- a/src/negf_subgroup_types.F +++ b/src/negf_subgroup_types.F @@ -137,9 +137,8 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) THEN + IF (ALLOCATED(sub_env%group_distribution)) & DEALLOCATE (sub_env%group_distribution) - END IF sub_env%ngroups = 0 diff --git a/src/offload/offload_api.F b/src/offload/offload_api.F index c9c4b8c48c..e9f508ee05 100644 --- a/src/offload/offload_api.F +++ b/src/offload/offload_api.F @@ -158,9 +158,8 @@ CONTAINS device_id = offload_get_chosen_device_c() - IF (device_id < 0) THEN + IF (device_id < 0) & CPABORT("No offload device has been chosen.") - END IF END FUNCTION offload_get_chosen_device diff --git a/src/openpmd_api.F b/src/openpmd_api.F index 00265196e0..82de3ca08c 100644 --- a/src/openpmd_api.F +++ b/src/openpmd_api.F @@ -24,14 +24,11 @@ MODULE openpmd_api USE kinds, ONLY: default_string_length, dp, sp USE message_passing, ONLY: mp_comm_type #include "./base/base_uses.f90" -#endif IMPLICIT NONE PRIVATE -#ifdef __OPENPMD - INTEGER, PARAMETER :: openpmd_access_create = 0 INTEGER, PARAMETER :: openpmd_access_read_only = 1 @@ -262,6 +259,7 @@ MODULE openpmd_api #:for dim in dimensions PUBLIC :: openpmd_dynamic_memory_view_type_${dim}$d #:endfor + #endif CONTAINS @@ -1216,5 +1214,6 @@ MODULE openpmd_api CALL openpmd_c_mesh_set_unit_dimension(this%c_ptr, unitDimension) END SUBROUTINE openpmd_mesh_set_unit_dimension + #endif END MODULE openpmd_api diff --git a/src/optimize_basis.F b/src/optimize_basis.F index 9fbbeb1eb1..813e9e52a9 100644 --- a/src/optimize_basis.F +++ b/src/optimize_basis.F @@ -196,9 +196,8 @@ CONTAINS DO iopt = 0, opt_bas%powell_param%maxfun CALL compute_residuum_vectors(opt_bas, f_env_id, matrix_S_inv, tot_time, & para_env_top, para_env, iopt) - IF (para_env_top%is_source()) THEN + IF (para_env_top%is_source()) & CALL powell_optimize(opt_bas%powell_param%nvar, opt_bas%x_opt, opt_bas%powell_param) - END IF CALL para_env_top%bcast(opt_bas%powell_param%state) CALL para_env_top%bcast(opt_bas%x_opt) CALL update_free_vars(opt_bas) @@ -363,10 +362,9 @@ CONTAINS icomb = MOD(icalc - 1, opt_bas%ncombinations) opt_bas%powell_param%f = opt_bas%powell_param%f + & (f_vec(icalc) + energy(icalc))*opt_bas%fval_weight(icomb) - IF (opt_bas%use_condition_number) THEN + IF (opt_bas%use_condition_number) & opt_bas%powell_param%f = opt_bas%powell_param%f + & LOG(cond_vec(icalc))*opt_bas%condition_weight(icomb) - END IF END DO ELSE f_vec = 0.0_dp; cond_vec = 0.0_dp; my_time = 0.0_dp; energy = 0.0_dp @@ -562,7 +560,8 @@ CONTAINS END DO DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & + SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) END DO CALL timestop(handle) @@ -668,9 +667,8 @@ CONTAINS tot_time = tot_time + my_time unit_nr = -1 - IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) THEN + IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) & unit_nr = cp_logger_get_default_unit_nr(logger) - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,I8)') "BASOPT| Information at iteration number:", iopt diff --git a/src/optimize_basis_types.F b/src/optimize_basis_types.F index de46ed724b..ec2b96dff3 100644 --- a/src/optimize_basis_types.F +++ b/src/optimize_basis_types.F @@ -177,9 +177,8 @@ CONTAINS IF (ALLOCATED(kind%deriv_info(iinfo)%in_use_set)) DEALLOCATE (kind%deriv_info(iinfo)%in_use_set) IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr)) THEN DO icont = 1, SIZE(kind%deriv_info(iinfo)%use_contr) - IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) THEN + IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) & DEALLOCATE (kind%deriv_info(iinfo)%use_contr(icont)%in_use) - END IF END DO DEALLOCATE (kind%deriv_info(iinfo)%use_contr) END IF @@ -191,30 +190,22 @@ CONTAINS DO ibasis = 0, SIZE(kind%flex_basis) - 1 IF (ALLOCATED(kind%flex_basis(ibasis)%subset)) THEN DO iset = 1, SIZE(kind%flex_basis(ibasis)%subset) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%l) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_coeff) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exps) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_exps) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_x_ind) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_const) - END IF END DO DEALLOCATE (kind%flex_basis(ibasis)%subset) END IF diff --git a/src/optimize_basis_utils.F b/src/optimize_basis_utils.F index 0646e2fe77..239226980e 100644 --- a/src/optimize_basis_utils.F +++ b/src/optimize_basis_utils.F @@ -83,9 +83,8 @@ CONTAINS CALL generate_initial_basis(kind_section, opt_bas, para_env) CALL section_vals_get(train_section, n_repetition=opt_bas%ntraining_sets) - IF (opt_bas%ntraining_sets == 0) THEN + IF (opt_bas%ntraining_sets == 0) & CPABORT("No training set was specified in the Input") - END IF ALLOCATE (opt_bas%training_input(opt_bas%ntraining_sets)) ALLOCATE (opt_bas%training_dir(opt_bas%ntraining_sets)) @@ -137,9 +136,8 @@ CONTAINS logger => cp_get_default_logger() unit_nr = -1 - IF (logger%para_env%is_source()) THEN + IF (logger%para_env%is_source()) & unit_nr = cp_logger_get_default_unit_nr(logger) - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,A)') "BASOPT| Total number of calculations ", & @@ -296,16 +294,14 @@ CONTAINS CALL section_vals_val_get(optbas_section, "GROUP_PARTITION", i_vals=i_vals) isize = SIZE(i_vals) nptot = SUM(i_vals) - IF (nptot /= nproc) THEN + IF (nptot /= nproc) & CALL cp_abort(__LOCATION__, & "Number of processors in group distribution does not match number of MPI tasks."// & " Please change input.") - END IF - IF (.NOT. isize <= ncalc) THEN + IF (.NOT. isize <= ncalc) & CALL cp_abort(__LOCATION__, & "Number of Groups larger than number of calculations"// & " Please change input.") - END IF CPASSERT(nptot == nproc) ALLOCATE (opt_bas%comp_group(isize)) ALLOCATE (opt_bas%group_partition(0:isize - 1)) @@ -745,14 +741,12 @@ CONTAINS CALL section_vals_val_get(const_section, "USE_EXP", i_vals=def_exp, i_rep_section=irep) CALL section_vals_val_get(const_section, "BOUNDARIES", explicit=is_bound, i_rep_section=irep) CALL section_vals_val_get(const_section, "MAX_VAR_FRACTION", explicit=is_varlim, i_rep_section=irep) - IF (is_bound .AND. is_varlim) THEN + IF (is_bound .AND. is_varlim) & CALL cp_abort(__LOCATION__, "Exponent has two constraints. "// & "This is not possible at the moment. Please change input.") - END IF - IF (.NOT. is_bound .AND. .NOT. is_varlim) THEN + IF (.NOT. is_bound .AND. .NOT. is_varlim) & CALL cp_abort(__LOCATION__, "Exponent is declared to be constraint but none is given"// & " Please change input.") - END IF IF (def_exp(1) == -1) THEN DO iset = 1, flex_basis%nsets IF (def_exp(2) == -1) THEN @@ -760,30 +754,27 @@ CONTAINS CALL set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (def_exp(2) <= flex_basis%subset(iset)%nexp) THEN + IF (def_exp(2) <= flex_basis%subset(iset)%nexp) & CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") - END IF CALL set_constraint(flex_basis, iset, def_exp(2), const_section, is_bound, is_varlim, irep) END IF END DO ELSE - IF (.NOT. def_exp(1) <= flex_basis%nsets) THEN + IF (.NOT. def_exp(1) <= flex_basis%nsets) & CALL cp_abort(__LOCATION__, & "Set number of constraint is larger than number of sets in the template basis set."// & " Please change input.") - END IF IF (def_exp(2) == -1) THEN DO ipgf = 1, flex_basis%subset(iset)%nexp CALL set_constraint(flex_basis, def_exp(1), ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) THEN + IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) & CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") - END IF CALL set_constraint(flex_basis, def_exp(1), def_exp(2), const_section, is_bound, is_varlim, irep) END IF END IF @@ -814,11 +805,10 @@ CONTAINS REAL(KIND=dp) :: r_val REAL(KIND=dp), DIMENSION(:), POINTER :: r_vals - IF (flex_basis%subset(iset)%exp_has_const(ipgf)) THEN + IF (flex_basis%subset(iset)%exp_has_const(ipgf)) & CALL cp_abort(__LOCATION__, & "Multiple constraints due to collision in CONSTRAIN_EXPONENTS."// & " Please change input.") - END IF flex_basis%subset(iset)%exp_has_const(ipgf) = .TRUE. IF (is_bound) THEN flex_basis%subset(iset)%exp_const(ipgf)%const_type = 0 @@ -826,13 +816,12 @@ CONTAINS flex_basis%subset(iset)%exp_const(ipgf)%llim = MINVAL(r_vals) flex_basis%subset(iset)%exp_const(ipgf)%ulim = MAXVAL(r_vals) r_val = flex_basis%subset(iset)%exps(ipgf) - IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) THEN + IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) & CALL cp_abort(__LOCATION__, & "Exponent "//cp_to_string(r_val)// & " declared in constraint is out of bounds of constraint"//cp_to_string(MINVAL(r_vals))// & " to"//cp_to_string(MAXVAL(r_vals))// & " Please change input.") - END IF flex_basis%subset(iset)%exp_const(ipgf)%init = SUM(r_vals)/2.0_dp flex_basis%subset(iset)%exp_const(ipgf)%var_fac = MAXVAL(r_vals)/flex_basis%subset(iset)%exp_const(ipgf)%init - 1.0_dp END IF @@ -1150,7 +1139,8 @@ CONTAINS ! just to get an understandable basis normalize coefficients DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & + SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) END DO DEALLOCATE (r_val) diff --git a/src/optimize_embedding_potential.F b/src/optimize_embedding_potential.F index 0c38b6568a..c36cbdd7aa 100644 --- a/src/optimize_embedding_potential.F +++ b/src/optimize_embedding_potential.F @@ -151,9 +151,8 @@ CONTAINS END DO ! Find out whether we need a spin-dependend embedding potential - IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) THEN + IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) & open_shell_embed = .TRUE. - END IF ! If it's open shell, we need to check spin states IF (open_shell_embed) THEN @@ -668,14 +667,12 @@ CONTAINS TYPE(opt_embed_pot_type) :: opt_embed ! Read the potential as a vector in the auxiliary basis - IF (opt_embed%read_embed_pot) THEN + IF (opt_embed%read_embed_pot) & CALL read_embed_pot_vector(qs_env, embed_pot, spin_embed_pot, section, & opt_embed%embed_pot_coef, opt_embed%open_shell_embed) - END IF ! Read the potential as a cube (two cubes for open shell) - IF (opt_embed%read_embed_pot_cube) THEN + IF (opt_embed%read_embed_pot_cube) & CALL read_embed_pot_cube(embed_pot, spin_embed_pot, section, opt_embed%open_shell_embed) - END IF END SUBROUTINE read_embed_pot @@ -698,9 +695,8 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CPABORT("Embedding cube file not found. ") - END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(embed_pot, filename, scaling_factor) @@ -710,9 +706,8 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_SPIN_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CPABORT("Embedding spin cube file not found. ") - END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(spin_embed_pot, filename, scaling_factor) @@ -789,9 +784,8 @@ CONTAINS READ (restart_unit) dimen_restart_basis ! Check the dimensions of the bases: the actual and the restart one - IF (.NOT. (dimen_restart_basis == dimen_aux)) THEN + IF (.NOT. (dimen_restart_basis == dimen_aux)) & CPABORT("Wrong dimension of the embedding basis in the restart file.") - END IF ALLOCATE (coef_read(dimen_var_aux)) coef_read = 0.0_dp @@ -850,9 +844,8 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_RESTART_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CPABORT("Embedding restart file not found. ") - END IF END SUBROUTINE embed_restart_file_name @@ -1512,16 +1505,14 @@ CONTAINS ELSE ! Finite basis optimization ! If the previous step has been rejected, we go back to the previous expansion coefficients - IF (.NOT. opt_embed%accept_step) THEN + IF (.NOT. opt_embed%accept_step) & CALL cp_fm_scale_and_add(1.0_dp, opt_embed%embed_pot_coef, -1.0_dp, opt_embed%step) - END IF ! Do a simple steepest descent IF (opt_embed%steep_desc) THEN - IF (opt_embed%i_iter > 2) THEN + IF (opt_embed%i_iter > 2) & opt_embed%trust_rad = Barzilai_Borwein(opt_embed%step, opt_embed%prev_step, & opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad) - END IF IF (ABS(opt_embed%trust_rad) > opt_embed%max_trad) THEN IF (opt_embed%trust_rad > 0.0_dp) THEN opt_embed%trust_rad = opt_embed%max_trad @@ -1539,11 +1530,9 @@ CONTAINS ! First, update the Hessian inverse if needed IF (opt_embed%i_iter > 1) THEN - IF (opt_embed%accept_step) THEN - ! We don't update Hessian if the step has been rejected + IF (opt_embed%accept_step) & ! We don't update Hessian if the step has been rejected CALL symm_rank_one_update(opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad, & opt_embed%step, opt_embed%prev_embed_pot_Hess, opt_embed%embed_pot_Hess) - END IF END IF ! Add regularization term to the Hessian @@ -2224,9 +2213,8 @@ CONTAINS ! If energy change is larger than the predicted one, increase trust radius twice ! Else (between 0 and 1) leave as it is, unless Newton step has been taken and if the step is less than max IF ((ener_ratio > 1.0_dp) .AND. (.NOT. opt_embed%newton_step) .AND. & - (opt_embed%trust_rad < opt_embed%max_trad)) THEN + (opt_embed%trust_rad < opt_embed%max_trad)) & opt_embed%trust_rad = 2.0_dp*opt_embed%trust_rad - END IF ELSE ! Energy decreases ! If the decrease is not too large we allow this step to be taken ! Otherwise, the step is rejected @@ -2234,9 +2222,8 @@ CONTAINS opt_embed%accept_step = .FALSE. END IF ! Trust radius is decreased 4 times unless it's smaller than the minimal allowed value - IF (opt_embed%trust_rad >= opt_embed%min_trad) THEN + IF (opt_embed%trust_rad >= opt_embed%min_trad) & opt_embed%trust_rad = 0.25_dp*opt_embed%trust_rad - END IF END IF IF (opt_embed%accept_step) opt_embed%last_accepted = opt_embed%i_iter diff --git a/src/optimize_input.F b/src/optimize_input.F index bf550ed1b4..318487e913 100644 --- a/src/optimize_input.F +++ b/src/optimize_input.F @@ -525,9 +525,8 @@ CONTAINS n_frames_current = 0 NULLIFY (pos_traj, energy_traj, force_traj) filename = oi_env%fm_env%ref_traj_file_name - IF (filename == "") THEN + IF (filename == "") & CPABORT("The reference trajectory file name is empty") - END IF CALL parser_create(local_parser, filename, para_env=para_env) DO CALL parser_read_line(local_parser, 1, at_end=at_end) @@ -560,9 +559,8 @@ CONTAINS ! now force reference trajectory filename = oi_env%fm_env%ref_force_file_name - IF (filename == "") THEN + IF (filename == "") & CPABORT("The reference force file name is empty") - END IF CALL parser_create(local_parser, filename, para_env=para_env) DO iframe = 1, n_frames CALL parser_read_line(local_parser, 1) diff --git a/src/pair_potential.F b/src/pair_potential.F index 3f56b1de2c..6e2d4af4f5 100644 --- a/src/pair_potential.F +++ b/src/pair_potential.F @@ -31,7 +31,7 @@ MODULE pair_potential USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, compare_pot, deepmd_type, ea_type, ft_type, & ftd_type, gal21_type, gal_type, gp_type, gw_type, ip_type, list_pot, lj_charmm_type, & - lj_type, mace_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & + lj_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & pair_potential_single_type, potential_single_allocation, siepmann_type, tab_type, & tersoff_type, wl_type USE pair_potential_util, ONLY: ener_pot,& @@ -188,8 +188,7 @@ CONTAINS DO k = 1, SIZE(pot%type) SELECT CASE (pot%type(k)) CASE (lj_type, lj_charmm_type, wl_type, gw_type, ft_type, ftd_type, ip_type, & - b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, mace_type, tab_type, & - deepmd_type, ace_type) + b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, tab_type, deepmd_type, ace_type) pot%no_pp = .FALSE. CASE (tersoff_type) pot%no_mb = .FALSE. @@ -207,7 +206,7 @@ CONTAINS END SELECT ! Special case for EAM SELECT CASE (pot%type(k)) - CASE (ea_type, nequip_type, allegro_type, mace_type, deepmd_type, ace_type) + CASE (ea_type, nequip_type, allegro_type, deepmd_type, ace_type) pot%no_mb = .FALSE. END SELECT END DO @@ -606,7 +605,7 @@ CONTAINS nvar = 5 + nvar CASE (ea_type) nvar = 4 + nvar - CASE (nequip_type, mace_type) + CASE (nequip_type) nvar = 1 + nvar CASE (allegro_type) nvar = 1 + nvar @@ -689,7 +688,7 @@ CONTAINS pot_par(nk, 2) = potparm%pot(i, j)%pot%set(1)%eam%drhoar pot_par(nk, 3) = potparm%pot(i, j)%pot%set(1)%eam%acutal pot_par(nk, 4) = potparm%pot(i, j)%pot%set(1)%eam%npoints - CASE (nequip_type, allegro_type, mace_type) + CASE (nequip_type, allegro_type) pot_par(nk, 1) = str2id( & TRIM(potparm%pot(i, j)%pot%set(1)%nequip%pot_file_name)) CASE (ace_type) diff --git a/src/pair_potential_types.F b/src/pair_potential_types.F index 23aacc5225..ec797ee3f5 100644 --- a/src/pair_potential_types.F +++ b/src/pair_potential_types.F @@ -54,10 +54,9 @@ MODULE pair_potential_types gal21_type = 18, & tab_type = 19, & deepmd_type = 20, & - ace_type = 21, & - mace_type = 22 + ace_type = 21 - INTEGER, PUBLIC, PARAMETER, DIMENSION(22) :: list_pot = [nn_type, & + INTEGER, PUBLIC, PARAMETER, DIMENSION(21) :: list_pot = [nn_type, & lj_type, & lj_charmm_type, & ft_type, & @@ -77,8 +76,7 @@ MODULE pair_potential_types gal21_type, & tab_type, & deepmd_type, & - ace_type, & - mace_type] + ace_type] ! Shell model INTEGER, PUBLIC, PARAMETER :: nosh_nosh = 0, & @@ -470,7 +468,7 @@ CONTAINS CASE (deepmd_type) IF ((pot1%set(i)%deepmd%deepmd_file_name == pot2%set(i)%deepmd%deepmd_file_name) .AND. & (pot1%set(i)%deepmd%atom_deepmd_type == pot2%set(i)%deepmd%atom_deepmd_type)) mycompare = .TRUE. - CASE (nequip_type, allegro_type, mace_type) + CASE (nequip_type, allegro_type) IF ((pot1%set(i)%nequip%pot_file_name == pot2%set(i)%nequip%pot_file_name) .AND. & (pot1%set(i)%nequip%unit_length == pot2%set(i)%nequip%unit_length) .AND. & (pot1%set(i)%nequip%unit_forces == pot2%set(i)%nequip%unit_forces) .AND. & @@ -643,12 +641,10 @@ CONTAINS potparm%at1 = 'NULL' potparm%at2 = 'NULL' potparm%rcutsq = 0.0_dp - IF (ASSOCIATED(potparm%pair_spline_data)) THEN + IF (ASSOCIATED(potparm%pair_spline_data)) & CALL spline_data_p_release(potparm%pair_spline_data) - END IF - IF (ASSOCIATED(potparm%spl_f)) THEN + IF (ASSOCIATED(potparm%spl_f)) & CALL spline_factor_release(potparm%spl_f) - END IF DO i = 1, SIZE(potparm%type) potparm%set(i)%rmin = not_initialized @@ -1053,9 +1049,8 @@ CONTAINS IF (PRESENT(istart)) l_start = istart IF (PRESENT(iend)) l_end = iend DO i = l_start, l_end - IF (.NOT. ASSOCIATED(source%pot(i)%pot)) THEN + IF (.NOT. ASSOCIATED(source%pot(i)%pot)) & CALL pair_potential_single_create(source%pot(i)%pot) - END IF CALL pair_potential_single_copy(source%pot(i)%pot, dest%pot(i)%pot) END DO END SUBROUTINE pair_potential_p_copy @@ -1291,7 +1286,7 @@ CONTAINS CALL pair_potential_goodwin_create(p%pot(i)%pot%set(std_dim)%goodwin) CASE (ea_type) CALL pair_potential_eam_create(p%pot(i)%pot%set(std_dim)%eam) - CASE (nequip_type, allegro_type, mace_type) + CASE (nequip_type, allegro_type) CALL pair_potential_nequip_create(p%pot(i)%pot%set(std_dim)%nequip) CASE (ace_type) CALL pair_potential_ace_create(p%pot(i)%pot%set(std_dim)%ace) diff --git a/src/pair_potential_util.F b/src/pair_potential_util.F index 9e77235b32..bb0163846f 100644 --- a/src/pair_potential_util.F +++ b/src/pair_potential_util.F @@ -109,7 +109,7 @@ CONTAINS index = INT(r/pot%set(j)%eam%drar) + 1 IF (index > pot%set(j)%eam%npoints) THEN index = pot%set(j)%eam%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = r - pot%set(j)%eam%rval(index) @@ -119,17 +119,17 @@ CONTAINS ELSE IF (pot%type(j) == b4_type) THEN IF (r <= pot%set(j)%buck4r%r1) THEN pp = pot%set(j)%buck4r%a*EXP(-pot%set(j)%buck4r%b*r) - ELSE IF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN + ELSEIF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly1 pp = pp + pot%set(j)%buck4r%poly1(n)*r**n END DO - ELSE IF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN + ELSEIF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly2 pp = pp + pot%set(j)%buck4r%poly2(n)*r**n END DO - ELSE IF (r > pot%set(j)%buck4r%r3) THEN + ELSEIF (r > pot%set(j)%buck4r%r3) THEN pp = -pot%set(j)%buck4r%c/r**6 END IF lvalue = pp @@ -139,7 +139,7 @@ CONTAINS IF (index2 > pot%set(j)%tab%npoints) THEN index2 = pot%set(j)%tab%npoints index1 = index2 - 1 - ELSE IF (index1 < 1) THEN + ELSEIF (index1 < 1) THEN index1 = 1 index2 = 2 END IF @@ -156,9 +156,8 @@ CONTAINS ELSE IF (pot%type(j) == gp_type) THEN pot%set(j)%gp%values(1) = r lvalue = evalf(pot%set(j)%gp%myid, pot%set(j)%gp%values) - IF (EvalErrType > 0) THEN + IF (EvalErrType > 0) & CPABORT("Error evaluating generic potential energy function") - END IF ELSE lvalue = 0.0_dp END IF @@ -190,7 +189,7 @@ CONTAINS fac = pot%z1*pot%z2/evolt ener_zbl = fac/r*(0.1818_dp*EXP(-3.2_dp*x) + 0.5099_dp*EXP(-0.9423_dp*x) + & 0.2802_dp*EXP(-0.4029_dp*x) + 0.02817_dp*EXP(-0.2016_dp*x)) - ELSE IF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN + ELSEIF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN ener_zbl = pot%zbl_poly(0) + pot%zbl_poly(1)*r + pot%zbl_poly(2)*r*r + pot%zbl_poly(3)*r*r*r + & pot%zbl_poly(4)*r*r*r*r + pot%zbl_poly(5)*r*r*r*r*r ELSE diff --git a/src/pao_io.F b/src/pao_io.F index ac4c035268..166da4d769 100644 --- a/src/pao_io.F +++ b/src/pao_io.F @@ -121,9 +121,8 @@ CONTAINS END IF ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & CPABORT("Restart PAO parametrization does not match") - END IF ! check kinds DO ikind = 1, SIZE(kinds) @@ -131,15 +130,13 @@ CONTAINS END DO ! check number of atoms - IF (SIZE(positions, 1) /= natoms) THEN + IF (SIZE(positions, 1) /= natoms) & CPABORT("Number of atoms do not match") - END IF ! check atom2kind DO iatom = 1, natoms - IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) THEN + IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) & CPABORT("Restart atomic kinds do not match.") - END IF END DO ! check positions, warning only @@ -163,9 +160,8 @@ CONTAINS END IF CALL para_env%bcast(buffer) CALL dbcsr_get_block_p(matrix=pao%matrix_X, row=iatom, col=iatom, block=block_X, found=found) - IF (ASSOCIATED(block_X)) THEN + IF (ASSOCIATED(block_X)) & block_X = buffer - END IF DEALLOCATE (buffer) END DO @@ -216,9 +212,8 @@ CONTAINS ! check if file starts with proper header !TODO: introduce a more unique header READ (unit_nr, fmt=*) label, i1 - IF (TRIM(label) /= "Version") THEN + IF (TRIM(label) /= "Version") & CPABORT("PAO restart file appears to be corrupted.") - END IF IF (i1 /= file_format_version) CPABORT("Restart PAO file format version is wrong") DO WHILE (.TRUE.) @@ -345,9 +340,8 @@ CONTAINS atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) - IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) THEN + IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) & CPABORT("Some kinds are missing.") - END IF CALL get_atomic_kind(atomic_kind_set(ikind), z=z, name=name) CALL get_qs_kind(qs_kind_set(ikind), & @@ -356,27 +350,20 @@ CONTAINS pao_potentials=pao_potentials) CALL pao_param_count(pao, qs_env, ikind=ikind, nparams=nparams) - IF (pao_kind%nparams /= nparams) THEN + IF (pao_kind%nparams /= nparams) & CPABORT("Number of parameters do not match") - END IF - IF (TRIM(pao_kind%name) /= TRIM(name)) THEN + IF (TRIM(pao_kind%name) /= TRIM(name)) & CPABORT("Kind names do not match") - END IF - IF (pao_kind%z /= z) THEN + IF (pao_kind%z /= z) & CPABORT("Atomic numbers do not match") - END IF - IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) THEN + IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) & CPABORT("Primary Basis-set name does not match") - END IF - IF (pao_kind%prim_basis_size /= basis_set%nsgf) THEN + IF (pao_kind%prim_basis_size /= basis_set%nsgf) & CPABORT("Primary Basis-set size does not match") - END IF - IF (pao_kind%pao_basis_size /= pao_basis_size) THEN + IF (pao_kind%pao_basis_size /= pao_basis_size) & CPABORT("PAO basis size does not match") - END IF - IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) THEN + IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) & CPABORT("Number of PAO_POTENTIALS does not match") - END IF DO ipot = 1, SIZE(pao_potentials) IF (pao_kind%pao_potentials(ipot)%maxl /= pao_potentials(ipot)%maxl) THEN @@ -434,9 +421,8 @@ CONTAINS CALL para_env%max(unit_max) IF (unit_max > 0) THEN IF (pao%iw > 0) WRITE (pao%iw, '(A,A)') " PAO| Writing restart file." - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL write_restart_header(pao, qs_env, energy, unit_nr) - END IF CALL pao_write_diagonal_blocks(para_env, pao%matrix_X, "Xblock", unit_nr) @@ -477,10 +463,8 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) THEN - ! catch corner-case + IF (SIZE(local_block) > 0) & ! catch corner-case mpi_buffer(:, :) = local_block(:, :) - END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/pao_linpot_rotinv.F b/src/pao_linpot_rotinv.F index 12698d45c1..91c735c395 100644 --- a/src/pao_linpot_rotinv.F +++ b/src/pao_linpot_rotinv.F @@ -83,12 +83,10 @@ CONTAINS ! terms sensing neighboring atoms DO ipot = 1, npots pot_maxl = pao_potentials(ipot)%maxl ! maxl is taken from central atom - IF (pot_maxl < 0) THEN + IF (pot_maxl < 0) & CPABORT("ROTINV parametrization requires non-negative PAO_POTENTIAL%MAXL") - END IF - IF (MOD(pot_maxl, 2) /= 0) THEN + IF (MOD(pot_maxl, 2) /= 0) & CPABORT("ROTINV parametrization requires even-numbered PAO_POTENTIAL%MAXL") - END IF DO max_shell = 1, nshells DO min_shell = 1, max_shell DO lpot = 0, pot_maxl, 2 @@ -205,9 +203,8 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) THEN + IF (SIZE(jpao_potentials) /= npots) & CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") - END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom @@ -451,9 +448,8 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) THEN + IF (SIZE(jpao_potentials) /= npots) & CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") - END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom diff --git a/src/pao_main.F b/src/pao_main.F index b4a61ce1ab..db6fcac257 100644 --- a/src/pao_main.F +++ b/src/pao_main.F @@ -279,9 +279,8 @@ CONTAINS EXIT END IF - IF (MOD(icycle, pao%write_cycles) == 0) THEN - CALL pao_write_restart(pao, qs_env, energy) - END IF ! write an intermediate restart file + IF (MOD(icycle, pao%write_cycles) == 0) & + CALL pao_write_restart(pao, qs_env, energy) ! write an intermediate restart file END IF ! check for early abort without convergence? diff --git a/src/pao_methods.F b/src/pao_methods.F index cdce9d2815..203df6946c 100644 --- a/src/pao_methods.F +++ b/src/pao_methods.F @@ -133,9 +133,8 @@ CONTAINS ! Load torch model. IF (LEN_TRIM(pao_model_file) > 0) THEN - IF (.NOT. ALLOCATED(pao%models)) THEN + IF (.NOT. ALLOCATED(pao%models)) & ALLOCATE (pao%models(SIZE(qs_kind_set))) - END IF CALL pao_model_load(pao, qs_env, ikind, pao_model_file, pao%models(ikind)) END IF @@ -291,9 +290,8 @@ CONTAINS CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind), pao_basis_size=M) CPASSERT(M > 0) - IF (blk_sizes_pri(iatom) < M) THEN + IF (blk_sizes_pri(iatom) < M) & CPABORT("PAO basis size exceeds primary basis size.") - END IF blk_sizes_aux(iatom) = M END DO @@ -556,9 +554,8 @@ CONTAINS CALL dbcsr_release(matrix_S_desym) - IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) THEN + IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) & CPABORT("Number of electrons wrong. Trace(PS) ="//cp_to_string(trace_PS)) - END IF CALL timestop(handle) END SUBROUTINE pao_check_trace_PS @@ -986,15 +983,12 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) "PAO| Adding forces." IF (pao%max_pao /= 0) THEN - IF (pao%penalty_strength /= 0.0_dp) THEN + IF (pao%penalty_strength /= 0.0_dp) & CPABORT("PAO forces require PENALTY_STRENGTH or MAX_PAO set to zero") - END IF - IF (pao%linpot_regu_strength /= 0.0_dp) THEN + IF (pao%linpot_regu_strength /= 0.0_dp) & CPABORT("PAO forces require LINPOT_REGULARIZATION_STRENGTH or MAX_PAO set to zero") - END IF - IF (pao%regularization /= 0.0_dp) THEN + IF (pao%regularization /= 0.0_dp) & CPABORT("PAO forces require REGULARIZATION or MAX_PAO set to zero") - END IF END IF CALL get_qs_env(qs_env, & @@ -1005,13 +999,11 @@ CONTAINS ALLOCATE (forces(natoms, 3)) CALL pao_calc_AB(pao, qs_env, ls_scf_env, gradient=.TRUE., forces=forces) ! without penalty terms - IF (SIZE(pao%ml_training_set) > 0) THEN + IF (SIZE(pao%ml_training_set) > 0) & CALL pao_ml_forces(pao, qs_env, pao%matrix_G, forces) - END IF - IF (ALLOCATED(pao%models)) THEN + IF (ALLOCATED(pao%models)) & CALL pao_model_forces(pao, qs_env, pao%matrix_G, forces) - END IF CALL para_env%sum(forces) DO iatom = 1, natoms diff --git a/src/pao_ml.F b/src/pao_ml.F index 95de014193..b711d54387 100644 --- a/src/pao_ml.F +++ b/src/pao_ml.F @@ -95,9 +95,8 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO|ML| Initializing maschine learning...' - IF (pao%parameterization /= pao_rotinv_param) THEN + IF (pao%parameterization /= pao_rotinv_param) & CPABORT("PAO maschine learning requires ROTINV parametrization") - END IF CALL get_qs_env(qs_env, para_env=para_env, atomic_kind_set=atomic_kind_set) @@ -167,9 +166,8 @@ CONTAINS CALL pao_read_raw(filename, param, hmat, kinds, atom2kind, positions, xblocks, ml_range) ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & CPABORT("Restart PAO parametrization does not match") - END IF ! map read-in kinds onto kinds of this run CALL match_kinds(pao, qs_env, kinds, kindsmap) @@ -279,9 +277,8 @@ CONTAINS END DO END DO - IF (ANY(kindsmap < 1)) THEN + IF (ANY(kindsmap < 1)) & CPABORT("PAO: Could not match all kinds from training set") - END IF END SUBROUTINE match_kinds ! ************************************************************************************************** @@ -304,10 +301,8 @@ CONTAINS training_list => training_lists(ikind) IF (training_list%npoints > 0) CYCLE ! it's ok CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) - IF (pao_basis_size /= basis_set%nsgf) THEN - ! if this kind has pao enabled... + IF (pao_basis_size /= basis_set%nsgf) & ! if this kind has pao enabled... CPABORT("Found no training-points for kind: "//TRIM(training_list%kindname)) - END IF END DO END SUBROUTINE sanity_check @@ -348,12 +343,10 @@ CONTAINS ! figure out size of input and output inp_size = 0; out_size = 0 - IF (ALLOCATED(training_list%head%input)) THEN + IF (ALLOCATED(training_list%head%input)) & inp_size = SIZE(training_list%head%input) - END IF - IF (ALLOCATED(training_list%head%output)) THEN + IF (ALLOCATED(training_list%head%output)) & out_size = SIZE(training_list%head%output) - END IF CALL para_env%sum(inp_size) CALL para_env%sum(out_size) @@ -581,9 +574,8 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, "(A,E20.10,A,T71,I10)") " PAO|ML| max prediction variance:", & MAXVAL(variances), " for atom:", MAXLOC(variances) - IF (MAXVAL(variances) > pao%ml_tolerance) THEN + IF (MAXVAL(variances) > pao%ml_tolerance) & CPABORT("Variance of prediction above ML_TOLERANCE.") - END IF DEALLOCATE (variances) diff --git a/src/pao_ml_descriptor.F b/src/pao_ml_descriptor.F index 2550b05021..a99b71053e 100644 --- a/src/pao_ml_descriptor.F +++ b/src/pao_ml_descriptor.F @@ -138,9 +138,8 @@ CONTAINS Rab = pbc(ra, rb, cell) CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=pao_descriptors) - IF (SIZE(pao_descriptors) /= ndesc) THEN + IF (SIZE(pao_descriptors) /= ndesc) & CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") - END IF weight = pao_descriptors(idesc)%weight beta = pao_descriptors(idesc)%beta CALL pao_calc_gaussian(basis_set, block_V=block_V, Rab=Rab, lpot=0, beta=beta, weight=weight) @@ -151,9 +150,8 @@ CONTAINS CALL diamat_all(V_evecs, V_evals) ! use eigenvalues of V_block as descriptor - IF (PRESENT(descriptor)) THEN + IF (PRESENT(descriptor)) & descriptor((idesc - 1)*N + 1:idesc*N) = V_evals(:) - END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN @@ -256,9 +254,8 @@ CONTAINS ! check if N was chosen large enough IF (natoms > N) THEN - IF (neighbor_dist(N + 1) < screening_radius) THEN + IF (neighbor_dist(N + 1) < screening_radius) & CPABORT("PAO heuristic for descriptor size broke down") - END IF END IF DO idesc = 1, ndesc @@ -276,9 +273,8 @@ CONTAINS CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=jpao_descriptors) CALL get_atomic_kind(particle_set(katom)%atomic_kind, kind_number=kkind) CALL get_qs_kind(qs_kind_set(kkind), pao_descriptors=kpao_descriptors) - IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) THEN + IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) & CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") - END IF jweight = jpao_descriptors(idesc)%weight jbeta = jpao_descriptors(idesc)%beta kweight = kpao_descriptors(idesc)%weight @@ -308,9 +304,8 @@ CONTAINS CALL diamat_all(S_evecs, S_evals) ! use eigenvalues of S_block as descriptor - IF (PRESENT(descriptor)) THEN + IF (PRESENT(descriptor)) & descriptor((idesc - 1)*N + 1:idesc*N) = S_evals(:) - END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN diff --git a/src/pao_ml_gaussprocess.F b/src/pao_ml_gaussprocess.F index c73c250c12..b97e60b661 100644 --- a/src/pao_ml_gaussprocess.F +++ b/src/pao_ml_gaussprocess.F @@ -112,9 +112,8 @@ CONTAINS ! calculate prediction's variance variance = kernel(pao%gp_scale, descriptor, descriptor) - DOT_PRODUCT(weights, cov) - IF (variance < 0.0_dp) THEN + IF (variance < 0.0_dp) & CPABORT("PAO gaussian process found negative variance") - END IF DEALLOCATE (cov, weights) END SUBROUTINE pao_ml_gp_predict diff --git a/src/pao_model.F b/src/pao_model.F index 1fb7d10fcd..01dc20903a 100644 --- a/src/pao_model.F +++ b/src/pao_model.F @@ -120,24 +120,18 @@ CONTAINS ! Check compatibility CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) CALL get_atomic_kind(atomic_kind_set(ikind), name=kind_name, z=z) - IF (model%version /= 2) THEN + IF (model%version /= 2) & CPABORT("Model version not supported.") - END IF - IF (TRIM(model%kind_name) /= TRIM(kind_name)) THEN + IF (TRIM(model%kind_name) /= TRIM(kind_name)) & CPABORT("Kind name does not match.") - END IF - IF (model%atomic_number /= z) THEN + IF (model%atomic_number /= z) & CPABORT("Atomic number does not match.") - END IF - IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) THEN + IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) & CPABORT("Primary basis set name does not match.") - END IF - IF (model%prim_basis_size /= basis_set%nsgf) THEN + IF (model%prim_basis_size /= basis_set%nsgf) & CPABORT("Primary basis set size does not match.") - END IF - IF (model%pao_basis_size /= pao_basis_size) THEN + IF (model%pao_basis_size /= pao_basis_size) & CPABORT("PAO basis size does not match.") - END IF CALL omp_init_lock(model%lock) CALL timestop(handle) diff --git a/src/pao_optimizer.F b/src/pao_optimizer.F index 63a5329dd7..6b5a46b663 100644 --- a/src/pao_optimizer.F +++ b/src/pao_optimizer.F @@ -48,9 +48,8 @@ CONTAINS CALL dbcsr_copy(pao%matrix_D_preconed, pao%matrix_D) END IF - IF (pao%optimizer == pao_opt_bfgs) THEN + IF (pao%optimizer == pao_opt_bfgs) & CALL pao_opt_init_bfgs(pao) - END IF END SUBROUTINE pao_opt_init @@ -86,13 +85,11 @@ CONTAINS CALL dbcsr_release(pao%matrix_D) CALL dbcsr_release(pao%matrix_G_prev) - IF (pao%precondition) THEN + IF (pao%precondition) & CALL dbcsr_release(pao%matrix_D_preconed) - END IF - IF (pao%optimizer == pao_opt_bfgs) THEN + IF (pao%optimizer == pao_opt_bfgs) & CALL dbcsr_release(pao%matrix_BFGS) - END IF END SUBROUTINE pao_opt_finalize diff --git a/src/pao_param_equi.F b/src/pao_param_equi.F index 4f81db62e7..d0c64c33b3 100644 --- a/src/pao_param_equi.F +++ b/src/pao_param_equi.F @@ -49,9 +49,8 @@ CONTAINS SUBROUTINE pao_param_init_equi(pao) TYPE(pao_env_type), POINTER :: pao - IF (pao%precondition) THEN + IF (pao%precondition) & CPABORT("PAO preconditioning not supported for selected parametrization.") - END IF END SUBROUTINE pao_param_init_equi diff --git a/src/pao_param_exp.F b/src/pao_param_exp.F index 1aba9e19ac..f8a4897ba3 100644 --- a/src/pao_param_exp.F +++ b/src/pao_param_exp.F @@ -104,9 +104,8 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) THEN + IF (pao%precondition) & CPABORT("PAO preconditioning not supported for selected parametrization.") - END IF CALL timestop(handle) END SUBROUTINE pao_param_init_exp diff --git a/src/pao_param_fock.F b/src/pao_param_fock.F index 9ffed6bbec..023bbaae5c 100644 --- a/src/pao_param_fock.F +++ b/src/pao_param_fock.F @@ -95,10 +95,8 @@ CONTAINS ! calculate homo-lumo gap (it's useful for detecting numerical issues) gap = HUGE(dp) - IF (m < n) THEN - ! catch special case n==m + IF (m < n) & ! catch special case n==m gap = H_evals(m + 1) - H_evals(m) - END IF IF (PRESENT(penalty)) THEN ! penalty terms: occupied and virtual eigenvalues repel each other @@ -166,9 +164,8 @@ CONTAINS M5 = MATMUL(MATMUL(block_N, M4), block_N) ! add regularization gradient - IF (PRESENT(penalty)) THEN + IF (PRESENT(penalty)) & M5 = M5 + 2.0_dp*pao%regularization*V - END IF ! symmetrize G = 0.5_dp*(M5 + TRANSPOSE(M5)) ! the final gradient diff --git a/src/pao_param_gth.F b/src/pao_param_gth.F index 51fa85e990..31a8a8eda1 100644 --- a/src/pao_param_gth.F +++ b/src/pao_param_gth.F @@ -123,9 +123,8 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) THEN + IF (pao%precondition) & CALL pao_param_gth_preconditioner(pao, qs_env, nterms) - END IF DEALLOCATE (row_blk_size, col_blk_size, nterms) CALL timestop(handle) @@ -209,9 +208,8 @@ CONTAINS CALL group%sum(block) CALL dbcsr_get_block_p(matrix=matrix_gth_overlap, row=iatom, col=jatom, block=block_overlap, found=found) - IF (ASSOCIATED(block_overlap)) THEN + IF (ASSOCIATED(block_overlap)) & block_overlap = block - END IF DEALLOCATE (block) END DO @@ -234,9 +232,8 @@ CONTAINS converged=converged) CALL dbcsr_release(matrix_gth_overlap) - IF (.NOT. converged) THEN + IF (.NOT. converged) & CPABORT("PAO: Sqrt of GTH-preconditioner did not converge.") - END IF CALL timestop(handle) END SUBROUTINE pao_param_gth_preconditioner @@ -384,9 +381,8 @@ CONTAINS DEALLOCATE (world_X, world_G) ! sum penalty energies across ranks - IF (PRESENT(penalty)) THEN + IF (PRESENT(penalty)) & CALL group%sum(penalty) - END IF ! print homo-lumo gap encountered by fock-layer CALL group%min(gaps) @@ -425,24 +421,20 @@ CONTAINS CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) CALL get_qs_kind(qs_kind_set(ikind), pao_potentials=pao_potentials) - IF (SIZE(pao_potentials) /= 1) THEN + IF (SIZE(pao_potentials) /= 1) & CPABORT("GTH parametrization requires exactly one PAO_POTENTIAL section per KIND") - END IF max_projector = pao_potentials(1)%max_projector maxl = pao_potentials(1)%maxl - IF (maxl < 0) THEN + IF (maxl < 0) & CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAXL") - END IF - IF (max_projector < 0) THEN + IF (max_projector < 0) & CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAX_PROJECTOR") - END IF - IF (MOD(maxl, 2) /= 0) THEN + IF (MOD(maxl, 2) /= 0) & CPABORT("GTH parametrization requires even-numbered PAO_POTENTIAL%MAXL") - END IF ncombis = (max_projector + 1)*(max_projector + 2)/2 nparams = ncombis*(maxl/2 + 1) diff --git a/src/pao_param_linpot.F b/src/pao_param_linpot.F index d32896a5ac..f4a1e21e2b 100644 --- a/src/pao_param_linpot.F +++ b/src/pao_param_linpot.F @@ -124,9 +124,8 @@ CONTAINS CALL pao_param_linpot_regularizer(pao) - IF (pao%precondition) THEN + IF (pao%precondition) & CALL pao_param_linpot_preconditioner(pao) - END IF CALL para_env%sync() ! ensure that timestop is not called too early @@ -446,23 +445,19 @@ CONTAINS CALL dbcsr_get_block_p(matrix=pao%matrix_V_terms, row=iatom, col=iatom, block=block_V_terms, found=found) CPASSERT(ASSOCIATED(block_V_terms)) nterms = SIZE(block_V_terms, 2) - IF (nterms > 0) THEN - ! protect against corner-case of zero pao parameters + IF (nterms > 0) & ! protect against corner-case of zero pao parameters vec_V = MATMUL(block_V_terms, block_X(:, 1)) - END IF block_V(1:n, 1:n) => vec_V(:) ! map vector into matrix ! symmetrize - IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) THEN + IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) & CPABORT("block_V not symmetric") - END IF block_V = 0.5_dp*(block_V + TRANSPOSE(block_V)) ! symmetrize exactly ! regularization energy ! protect against corner-case of zero pao parameters - IF (PRESENT(penalty) .AND. nterms > 0) THEN + IF (PRESENT(penalty) .AND. nterms > 0) & regu_energy = regu_energy + DOT_PRODUCT(block_X(:, 1), MATMUL(block_R, block_X(:, 1))) - END IF CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & gap=gaps(iatom), evals=evals(:, iatom)) @@ -478,18 +473,16 @@ CONTAINS !TODO: this 2nd call does double work. However, *sometimes* this branch is not taken. CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & M1=block_M1, G=block_M2, gap=gaps(iatom), evals=evals(:, iatom)) - IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) THEN + IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) & CPABORT("matrix not symmetric") - END IF ! gradient dE/dX IF (PRESENT(matrix_G)) THEN CALL dbcsr_get_block_p(matrix=matrix_G, row=iatom, col=iatom, block=block_G, found=found) CPASSERT(ASSOCIATED(block_G)) block_G(:, 1) = MATMUL(vec_M2, block_V_terms) - IF (PRESENT(penalty)) THEN - block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) - END IF ! regularization gradient + IF (PRESENT(penalty)) & + block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) ! regularization gradient END IF ! forced dE/dR diff --git a/src/pao_param_methods.F b/src/pao_param_methods.F index 37264fbec9..010af4c056 100644 --- a/src/pao_param_methods.F +++ b/src/pao_param_methods.F @@ -231,9 +231,8 @@ CONTAINS CALL group%max(delta_max) IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO| checked unitaryness, max delta:', delta_max - IF (delta_max > pao%check_unitary_tol) THEN + IF (delta_max > pao%check_unitary_tol) & CPABORT("Found bad unitaryness:"//cp_to_string(delta_max)) - END IF CALL timestop(handle) END SUBROUTINE pao_assert_unitary diff --git a/src/pao_types.F b/src/pao_types.F index 1cb794451a..242f6095c4 100644 --- a/src/pao_types.F +++ b/src/pao_types.F @@ -121,8 +121,7 @@ MODULE pao_types !> \var constants_ready set when stuff, which does not depend of atomic positions is ready !> \var need_initial_scf set when the initial density matrix is not self-consistend !> \var matrix_X parameters of pao basis, which eventually determine matrix_U. Uses diag_distribution. -!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. -!> Uses diag_distribution. +!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. Uses diag_distribution. !> \var matrix_H0 Diagonal blocks of core hamiltonian, uses diag_distribution !> \var matrix_Y selector matrix which translates between primary and pao basis. !> basically a block diagonal "rectangular identity matrix". Uses s_matrix-distribution. @@ -254,9 +253,8 @@ CONTAINS CALL dbcsr_release(pao%matrix_H0) DEALLOCATE (pao%ml_training_set) - IF (ALLOCATED(pao%ml_training_matrices)) THEN + IF (ALLOCATED(pao%ml_training_matrices)) & DEALLOCATE (pao%ml_training_matrices) - END IF IF (ALLOCATED(pao%models)) THEN DO i = 1, SIZE(pao%models) diff --git a/src/particle_methods.F b/src/particle_methods.F index 97a88055d6..e7336c66ad 100644 --- a/src/particle_methods.F +++ b/src/particle_methods.F @@ -1184,12 +1184,10 @@ CONTAINS count_list(elem_seen) = 1 END IF END IF - IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) THEN + IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) & w_cif_type_symbol = LEN_TRIM(cif_type_symbol(iatom)) - END IF - IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) THEN + IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) & w_cif_label = LEN_TRIM(cif_label(iatom)) - END IF END DO atom_loop ! Determine the format of each line in cif considering width of cif_type_symbol and cif_label @@ -1262,10 +1260,9 @@ CONTAINS file_unit = cp_print_key_unit_nr(logger, input_section, "PRINT%FINAL_STRUCTURE", & file_status="REPLACE", file_form="FORMATTED", & extension=".xyz") - IF (file_unit > 0) THEN + IF (file_unit > 0) & CALL write_particle_coordinates(particle_set, file_unit, dump_extxyz, "POS", title, & cell=cell, unit_conv=unit_conv, print_kind=print_kind) - END IF END IF ! Write CIF @@ -1433,10 +1430,9 @@ CONTAINS CALL section_release(tmp_cell_section) CALL cp_print_key_finished_output(file_unit, logger, input_section, & "PRINT%FINAL_STRUCTURE") - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" - END IF + routineN//": Done!" CALL timestop(handle) diff --git a/src/pexsi_interface.F b/src/pexsi_interface.F index e2d09937ab..fccdf461da 100644 --- a/src/pexsi_interface.F +++ b/src/pexsi_interface.F @@ -108,22 +108,17 @@ CONTAINS IF (PRESENT(muMin0)) pexsi_options%options%muMin0 = muMin0 IF (PRESENT(muMax0)) pexsi_options%options%muMax0 = muMax0 IF (PRESENT(mu0)) pexsi_options%options%mu0 = mu0 - IF (PRESENT(muInertiaTolerance)) THEN + IF (PRESENT(muInertiaTolerance)) & pexsi_options%options%muInertiaTolerance = muInertiaTolerance - END IF - IF (PRESENT(muInertiaExpansion)) THEN + IF (PRESENT(muInertiaExpansion)) & pexsi_options%options%muInertiaExpansion = muInertiaExpansion - END IF - IF (PRESENT(muPEXSISafeGuard)) THEN + IF (PRESENT(muPEXSISafeGuard)) & pexsi_options%options%muPEXSISafeGuard = muPEXSISafeGuard - END IF - IF (PRESENT(numElectronPEXSITolerance)) THEN + IF (PRESENT(numElectronPEXSITolerance)) & pexsi_options%options%numElectronPEXSITolerance = numElectronPEXSITolerance - END IF IF (PRESENT(matrixType)) pexsi_options%options%matrixType = matrixType - IF (PRESENT(isSymbolicFactorize)) THEN + IF (PRESENT(isSymbolicFactorize)) & pexsi_options%options%isSymbolicFactorize = isSymbolicFactorize - END IF IF (PRESENT(ordering)) pexsi_options%options%ordering = ordering IF (PRESENT(rowOrdering)) pexsi_options%options%rowOrdering = rowOrdering IF (PRESENT(npSymbFact)) pexsi_options%options%npSymbFact = npSymbFact @@ -210,22 +205,17 @@ CONTAINS IF (PRESENT(muMin0)) muMin0 = pexsi_options%options%muMin0 IF (PRESENT(muMax0)) muMax0 = pexsi_options%options%muMax0 IF (PRESENT(mu0)) mu0 = pexsi_options%options%mu0 - IF (PRESENT(muInertiaTolerance)) THEN + IF (PRESENT(muInertiaTolerance)) & muInertiaTolerance = pexsi_options%options%muInertiaTolerance - END IF - IF (PRESENT(muInertiaExpansion)) THEN + IF (PRESENT(muInertiaExpansion)) & muInertiaExpansion = pexsi_options%options%muInertiaExpansion - END IF - IF (PRESENT(muPEXSISafeGuard)) THEN + IF (PRESENT(muPEXSISafeGuard)) & muPEXSISafeGuard = pexsi_options%options%muPEXSISafeGuard - END IF - IF (PRESENT(numElectronPEXSITolerance)) THEN + IF (PRESENT(numElectronPEXSITolerance)) & numElectronPEXSITolerance = pexsi_options%options%numElectronPEXSITolerance - END IF IF (PRESENT(matrixType)) matrixType = pexsi_options%options%matrixType - IF (PRESENT(isSymbolicFactorize)) THEN + IF (PRESENT(isSymbolicFactorize)) & isSymbolicFactorize = pexsi_options%options%isSymbolicFactorize - END IF IF (PRESENT(ordering)) ordering = pexsi_options%options%ordering IF (PRESENT(rowOrdering)) rowOrdering = pexsi_options%options%rowOrdering IF (PRESENT(npSymbFact)) npSymbFact = pexsi_options%options%npSymbFact @@ -291,9 +281,8 @@ CONTAINS CALL timeset(routineN, handle) cp_pexsi_plan_initialize = f_ppexsi_plan_initialize(comm%get_handle(), numProcRow, & numProcCol, outputFileIndex, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(comm) @@ -340,9 +329,8 @@ CONTAINS CALL f_ppexsi_load_real_hs_matrix(plan, pexsi_options%options, nrows, nnz, nnzLocal, & numColLocal, colptrLocal, rowindLocal, & HnzvalLocal, isSIdentity, SnzvalLocal, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) @@ -355,11 +343,9 @@ CONTAINS CPABORT("Requires linking to the PEXSI library.") ! MARK_USED macro does not work on assumed shape variables - IF (.FALSE.) THEN - DO + IF (.FALSE.) THEN; DO IF (colptrLocal(1) > rowindLocal(1) .OR. HnzvalLocal(1) > SnzvalLocal(1)) EXIT - END DO - END IF + END DO; END IF #endif END SUBROUTINE cp_pexsi_load_real_hs_matrix @@ -410,9 +396,8 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) @@ -455,9 +440,8 @@ CONTAINS CALL f_ppexsi_retrieve_real_dft_matrix(plan, DMnzvalLocal, EDMnzvalLocal, & FDMnzvalLocal, totalEnergyH, & totalEnergyS, totalFreeEnergy, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) @@ -486,9 +470,8 @@ CONTAINS CALL timeset(routineN, handle) CALL f_ppexsi_plan_finalize(plan, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) diff --git a/src/pexsi_methods.F b/src/pexsi_methods.F index 3a8bb968b2..dc9c429e67 100644 --- a/src/pexsi_methods.F +++ b/src/pexsi_methods.F @@ -146,9 +146,8 @@ CONTAINS pexsi_env%num_ranks_per_pole = min_ranks_per_pole ! not a PEXSI option pexsi_env%csr_screening = csr_screening - IF (numElectronInitialTolerance < numElectronTargetTolerance) THEN + IF (numElectronInitialTolerance < numElectronTargetTolerance) & numElectronInitialTolerance = numElectronTargetTolerance - END IF pexsi_env%tol_nel_initial = numElectronInitialTolerance pexsi_env%tol_nel_target = numElectronTargetTolerance @@ -338,24 +337,20 @@ CONTAINS IF (first_call) THEN ! Assertion that matrices have the expected symmetry (both should be symmetric if no ! S preconditioning and no molecular clustering) - IF (.NOT. dbcsr_has_symmetry(matrix_ks)) THEN + IF (.NOT. dbcsr_has_symmetry(matrix_ks)) & CPABORT("PEXSI interface expects a non-symmetric DBCSR Kohn-Sham matrix") - END IF - IF (.NOT. dbcsr_has_symmetry(matrix_s)) THEN + IF (.NOT. dbcsr_has_symmetry(matrix_s)) & CPABORT("PEXSI interface expects a non-symmetric DBCSR overlap matrix") - END IF ! Assertion on datatype IF ((pexsi_env%csr_mat_s%nzval_local%data_type /= dbcsr_csr_type_real_8) & - .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) THEN + .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) & CPABORT("Complex data type not supported by PEXSI") - END IF ! Assertion on number of non-zero elements !(TODO: update when PEXSI changes to Long Int) - IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) THEN + IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) & CPABORT("Total number of non-zero elements of CSR matrix is too large to be handled by PEXSI") - END IF END IF CALL dbcsr_get_info(matrix_ks, distribution=dist) @@ -469,9 +464,8 @@ CONTAINS n_total_inertia_iter END IF - IF (.NOT. pexsi_convergence) THEN + IF (.NOT. pexsi_convergence) & CPABORT("PEXSI did not converge. Consider logPEXSI0 for more information.") - END IF ! Retrieve results from PEXSI IF (mynode < pexsi_env%mp_dims(1)*pexsi_env%mp_dims(2)) THEN diff --git a/src/pilaenv_hack.F b/src/pilaenv_hack.F index 89d89b4d54..4b59ed9474 100644 --- a/src/pilaenv_hack.F +++ b/src/pilaenv_hack.F @@ -18,8 +18,6 @@ !> \return ... ! ************************************************************************************************** INTEGER FUNCTION PILAENV(ICTXT, PREC) - IMPLICIT NONE - INTEGER :: ICTXT CHARACTER(LEN=1) :: PREC @@ -31,5 +29,5 @@ END FUNCTION PILAENV !> \brief ... ! ************************************************************************************************** SUBROUTINE NAG_dummy() - IMPLICIT NONE + END SUBROUTINE NAG_dummy diff --git a/src/pme.F b/src/pme.F index 6470a00c8b..d6703d8124 100644 --- a/src/pme.F +++ b/src/pme.F @@ -358,7 +358,7 @@ CONTAINS fgcore_coulomb(2, particle_set(p2)%shell_index) - fat(2)*dvols fgcore_coulomb(3, particle_set(p2)%shell_index) = & fgcore_coulomb(3, particle_set(p2)%shell_index) - fat(3)*dvols - ELSE IF (p2 /= 0) THEN + ELSEIF (p2 /= 0) THEN CALL dg_sum_patch_force_3d(drpot, rhos2, exp_igr%centre(:, p2), fat) fg_coulomb(1, p2) = fg_coulomb(1, p2) - fat(1)*dvols fg_coulomb(2, p2) = fg_coulomb(2, p2) - fat(2)*dvols @@ -505,7 +505,7 @@ CONTAINS ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) - ELSE IF (my_is1_core) THEN + ELSEIF (my_is1_core) THEN center1 => exp_igr%core_centre(:, particle_set(p1)%shell_index) ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) @@ -545,7 +545,7 @@ CONTAINS ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) - ELSE IF (my_is2_core) THEN + ELSEIF (my_is2_core) THEN center2 => exp_igr%core_centre(:, particle_set(p2)%shell_index) ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) @@ -633,7 +633,7 @@ CONTAINS ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) ez1 => exp_igr%core_ez(:, particle_set(p1)%shell_index) - ELSE IF (my_is1_shell) THEN + ELSEIF (my_is1_shell) THEN ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) @@ -659,7 +659,7 @@ CONTAINS ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) ez2 => exp_igr%core_ez(:, particle_set(p2)%shell_index) - ELSE IF (my_is2_shell) THEN + ELSEIF (my_is2_shell) THEN ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) diff --git a/src/population_analyses.F b/src/population_analyses.F index 715eeac5bf..2a0988a05a 100644 --- a/src/population_analyses.F +++ b/src/population_analyses.F @@ -187,11 +187,10 @@ CONTAINS ! Build full S^(1/2) matrix (computationally expensive) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) THEN + IF (ndep /= 0) & CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") - END IF ! Build Lowdin population matrix for each spin DO ispin = 1, nspin diff --git a/src/post_scf_bandstructure_types.F b/src/post_scf_bandstructure_types.F index 234c9af02f..db4c89bb24 100644 --- a/src/post_scf_bandstructure_types.F +++ b/src/post_scf_bandstructure_types.F @@ -23,7 +23,6 @@ MODULE post_scf_bandstructure_types USE dbt_api, ONLY: dbt_destroy,& dbt_type USE input_constants, ONLY: rtp_method_bse,& - rtp_method_bse_linearized,& small_cell_full_kp USE kinds, ONLY: default_path_length,& default_string_length,& @@ -45,14 +44,6 @@ MODULE post_scf_bandstructure_types PUBLIC :: post_scf_bandstructure_type, band_edges_type, data_3_type, bs_env_release - ! Sanity bounds on a fundamental quasiparticle gap, in Hartree: below -eps_qp_gap the spectrum is - ! inverted, above max_qp_gap the quasiparticle solve has diverged. eps_qp_gap is a noise tolerance, - ! low enough that a metal or a near-degenerate system does not trip the inversion test; max_qp_gap - ! sits far above any real valence gap (a few tens of eV) but is not derived from the all-electron - ! KS spread (~1000 eV), which would defeat the test. - REAL(KIND=dp), PARAMETER, PUBLIC :: eps_qp_gap = 0.01_dp/evolt, & - max_qp_gap = 200.0_dp/evolt - ! valence band maximum (VBM), conduction band minimum (CBM), direct band gap (DBG), ! indirect band gap (IDBG) TYPE band_edges_type @@ -78,20 +69,15 @@ MODULE post_scf_bandstructure_types ! Input parameters for RI-RS INTEGER :: grid_select = 1 REAL(KIND=dp) :: tikhonov = 1.0E-08_dp - REAL(KIND=dp) :: cutoff_radius_ri_rs = -1.0_dp - REAL(KIND=dp) :: cutoff_radius_ri_ao = -1.0_dp - INTEGER :: n_procs_per_atom_z_lp = -1 - INTEGER :: n_panels = 1 - LOGICAL :: keep_sparsity_rirs = .TRUE. - REAL(KIND=dp) :: cutoff_radius_v_w = -1.0_dp - REAL(KIND=dp) :: cutoff_radius_g_w = -1.0_dp - CHARACTER(LEN=default_string_length) :: grid_file_suffix = "" + REAL(KIND=dp) :: cutoff_radius_ri_rs = 30.0_dp - ! Data types for cutoffs based DBCSR matrices - REAL(KIND=dp), ALLOCATABLE :: chunk_centroids(:, :) - REAL(KIND=dp), ALLOCATABLE :: atom_centers(:, :) - INTEGER, ALLOCATABLE :: grid_atom_boundaries(:) - INTEGER, ALLOCATABLE :: pan_first(:), pan_last(:) + ! Number of MPI ranks that cooperate on one atom's Cholesky solve via + ! distributed pdpotrf. Default 1 = single-rank dpotrf path (BLAS, fastest + ! when D_local fits per rank). > 1 enables ScaLAPACK: ranks are split into + ! atom-groups of this size, D_local is block-cyclic distributed across + ! each group (memory ~1/G per rank), and compute_d_lp is also split across + ! the subgroup so wall time matches the BLAS path. + INTEGER :: n_procs_per_atom_z_lp = 1 ! Data types for building grid points TYPE(rirs_grid_type), ALLOCATABLE :: grid_cache(:) @@ -106,20 +92,6 @@ MODULE post_scf_bandstructure_types REAL(KIND=dp), ALLOCATABLE :: radius_ao_per_atom(:) REAL(KIND=dp), ALLOCATABLE :: radius_ri_per_atom(:) - ! Precomputed grid-basis kernels for RT-BSE - ! mat_V_aux_rtbse(P, Q) = truncated-Coulomb V_PQ with M^-1 sandwich (RI x RI); - ! the Hartree grid kernel Z V Z^T is applied factorized, never materialized - ! mat_W0_grid_rtbse(l, l') = sum_PQ Z_lP W^{w=0}_PQ Z_l'Q - TYPE(dbcsr_type) :: mat_V_aux_rtbse - TYPE(dbcsr_type) :: mat_W0_grid_rtbse - LOGICAL :: rtbse_kernels_ready = .FALSE. - ! Set TRUE once mat_phi_mu_l and mat_Z_lP have been populated in memory (by GW RI-RS - ! or on-demand by the RT-BSE RI-RS kernel path). - LOGICAL :: grid_built = .FALSE. - ! Independent toggles for V_grid / W0_grid availability - LOGICAL :: V_grid_built = .FALSE. - LOGICAL :: W0_grid_built = .FALSE. - END TYPE ri_rs_env TYPE post_scf_bandstructure_type @@ -304,7 +276,7 @@ MODULE post_scf_bandstructure_types skip_Sigma_vir, & skip_chi ! Marek : rtbse_method - INTEGER :: rtp_method = -1 + INTEGER :: rtp_method = rtp_method_bse ! check-arrays and names for restarting LOGICAL, DIMENSION(:), ALLOCATABLE :: read_chi, & @@ -499,9 +471,7 @@ CONTAINS CALL cp_fm_release(bs_env%fm_RI_RI) CALL cp_fm_release(bs_env%fm_chi_Gamma_freq) CALL cp_fm_release(bs_env%fm_W_MIC_freq) - IF (bs_env%rtp_method == rtp_method_bse .OR. bs_env%rtp_method == rtp_method_bse_linearized) THEN - CALL cp_fm_release(bs_env%fm_W_MIC_freq_zero) - END IF + IF (bs_env%rtp_method == rtp_method_bse) CALL cp_fm_release(bs_env%fm_W_MIC_freq_zero) CALL cp_fm_release(bs_env%fm_W_MIC_freq_1_extra) CALL cp_fm_release(bs_env%fm_W_MIC_freq_1_no_extra) CALL cp_cfm_release(bs_env%cfm_work_mo) @@ -548,19 +518,12 @@ CONTAINS CALL safe_cfm_destroy_1d(bs_env%cfm_SOC_spinor_ao) ! Deallocate RI-RS matrices - IF (bs_env%ri_rs%grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_phi_mu_l) - IF (bs_env%ri_rs%grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_Z_lP) - IF (bs_env%ri_rs%V_grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_V_aux_rtbse) - IF (bs_env%ri_rs%W0_grid_built) CALL dbcsr_release(bs_env%ri_rs%mat_W0_grid_rtbse) + IF (bs_env%do_gw_ri_rs) CALL dbcsr_release(bs_env%ri_rs%mat_phi_mu_l) + IF (bs_env%do_gw_ri_rs) CALL dbcsr_release(bs_env%ri_rs%mat_Z_lP) IF (ALLOCATED(bs_env%ri_rs%grid_points)) DEALLOCATE (bs_env%ri_rs%grid_points) IF (ALLOCATED(bs_env%ri_rs%grid_cache)) DEALLOCATE (bs_env%ri_rs%grid_cache) IF (ALLOCATED(bs_env%ri_rs%radius_ao_per_atom)) DEALLOCATE (bs_env%ri_rs%radius_ao_per_atom) IF (ALLOCATED(bs_env%ri_rs%radius_ri_per_atom)) DEALLOCATE (bs_env%ri_rs%radius_ri_per_atom) - IF (ALLOCATED(bs_env%ri_rs%chunk_centroids)) DEALLOCATE (bs_env%ri_rs%chunk_centroids) - IF (ALLOCATED(bs_env%ri_rs%atom_centers)) DEALLOCATE (bs_env%ri_rs%atom_centers) - IF (ALLOCATED(bs_env%ri_rs%grid_atom_boundaries)) DEALLOCATE (bs_env%ri_rs%grid_atom_boundaries) - IF (ALLOCATED(bs_env%ri_rs%pan_first)) DEALLOCATE (bs_env%ri_rs%pan_first) - IF (ALLOCATED(bs_env%ri_rs%pan_last)) DEALLOCATE (bs_env%ri_rs%pan_last) DEALLOCATE (bs_env) diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index 770484b407..2a0cc28187 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -53,8 +53,7 @@ MODULE post_scf_bandstructure_utils cp_fm_set_all,& cp_fm_to_fm,& cp_fm_type - USE cp_log_handling, ONLY: cp_logger_get_default_io_unit,& - cp_to_string + USE cp_log_handling, ONLY: cp_logger_get_default_io_unit USE cp_parser_methods, ONLY: read_float_object USE input_constants, ONLY: int_ldos_z,& large_cell_Gamma,& @@ -84,8 +83,6 @@ MODULE post_scf_bandstructure_utils USE physcon, ONLY: angstrom,& evolt USE post_scf_bandstructure_types, ONLY: band_edges_type,& - eps_qp_gap,& - max_qp_gap,& post_scf_bandstructure_type USE pw_env_types, ONLY: pw_env_get,& pw_env_type @@ -1941,9 +1938,8 @@ CONTAINS CALL bs_env%para_env%max(z_end_global) n_z = z_end_global - z_start_global + 1 - IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) THEN + IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) & CPABORT("Please choose a cell that has 90° angles to the z-direction.") - END IF ! for integration, we need the dz and the conversion from H -> eV and a_Bohr -> Å bs_env%unit_ldos_int_z_inv_Ang2_eV = bs_env%hmat(3, 3)/REAL(n_z, KIND=dp)/evolt/angstrom**2 @@ -2973,41 +2969,10 @@ CONTAINS CALL get_VBM_CBM_bandgaps(bs_env%band_edges_G0W0, bs_env%eigenval_G0W0, bs_env) CALL get_VBM_CBM_bandgaps(bs_env%band_edges_HF, bs_env%eigenval_HF, bs_env) - CALL check_qp_gap_sanity(bs_env) - CALL timestop(handle) END SUBROUTINE get_all_VBM_CBM_bandgaps -! ************************************************************************************************** -!> \brief Warn if the G0W0 fundamental band gap is inverted or implausibly large, i.e. if the -!> quasiparticle solve has produced a spectrum that cannot be physical. -!> \param bs_env ... -! ************************************************************************************************** - SUBROUTINE check_qp_gap_sanity(bs_env) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - REAL(KIND=dp) :: gap, gap_scf - - gap = bs_env%band_edges_G0W0%IDBG - gap_scf = bs_env%band_edges_scf%IDBG - - ! requiring a healthy SCF gap keeps the inversion test from firing on a genuine metal - IF (gap < -eps_qp_gap .AND. gap_scf > eps_qp_gap) THEN - CALL cp_warn(__LOCATION__, & - "G0W0 band gap is negative ("// & - TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))//" eV): the quasiparticle "// & - "spectrum is inverted. Check numerical parameters.") - ELSE IF (ABS(gap) > max_qp_gap) THEN - CALL cp_warn(__LOCATION__, & - "G0W0 band gap is implausibly large ("// & - TRIM(ADJUSTL(cp_to_string(gap*evolt, '(F12.3)')))//" eV): the quasiparticle "// & - "solve has likely diverged. Check numerical parameters.") - END IF - - END SUBROUTINE check_qp_gap_sanity - ! ************************************************************************************************** !> \brief ... !> \param band_edges ... diff --git a/src/preconditioner.F b/src/preconditioner.F index 15bbe74ebe..69d1ad3509 100644 --- a/src/preconditioner.F +++ b/src/preconditioner.F @@ -137,9 +137,8 @@ CONTAINS ! Thanks to the mess with the matrices we need to make sure in this case that the ! Previous inverse is properly stored as a sparse matrix, fm gets deallocated here ! if it wasn't anyway - IF (preconditioner_env%solver == ot_precond_solver_update) THEN + IF (preconditioner_env%solver == ot_precond_solver_update) & CALL transfer_fm_to_dbcsr(preconditioner_env%fm, preconditioner_env%dbcsr_matrix, matrix_h) - END IF needs_full_spectrum = .FALSE. needs_homo = .FALSE. @@ -262,8 +261,7 @@ CONTAINS DEALLOCATE (preconditioner(ispin)%preconditioner) END DO DEALLOCATE (preconditioner) - CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, & - ot_precond_full_single_inverse) ! these are 'independent' + CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, ot_precond_full_single_inverse) ! these are 'independent' ! do nothing CASE DEFAULT CPABORT("Unknown preconditioner type") @@ -390,7 +388,7 @@ CONTAINS co_rotate=qs_env%mo_derivs(ispin)%matrix, & para_env=para_env, & blacs_env=blacs_env) - ELSE IF (use_mo_coeff_b) THEN + ELSEIF (use_mo_coeff_b) THEN CALL calculate_subspace_eigenvalues(mo_coeff_b, matrix_ks(ispin)%matrix, & do_rotation=.TRUE., & para_env=para_env, & diff --git a/src/preconditioner_apply.F b/src/preconditioner_apply.F index e567636e74..0316f37bc9 100644 --- a/src/preconditioner_apply.F +++ b/src/preconditioner_apply.F @@ -167,9 +167,8 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) THEN + IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) & CPABORT("NOT ASSOCIATED preconditioner_env%dbcsr_matrix") - END IF CALL dbcsr_multiply('N', 'N', 1.0_dp, preconditioner_env%dbcsr_matrix, matrix_in, & 0.0_dp, matrix_out) diff --git a/src/preconditioner_makes.F b/src/preconditioner_makes.F index 4dae5616cb..c83f6ce23e 100644 --- a/src/preconditioner_makes.F +++ b/src/preconditioner_makes.F @@ -93,9 +93,8 @@ CONTAINS precon_type = preconditioner_env%in_use SELECT CASE (precon_type) CASE (ot_precond_full_single) - IF (my_solver_type /= ot_precond_solver_default) THEN + IF (my_solver_type /= ot_precond_solver_default) & CPABORT("Only PRECOND_SOLVER DEFAULT for the moment") - END IF IF (PRESENT(matrix_s)) THEN CALL make_full_single(preconditioner_env, preconditioner_env%fm, & matrix_h, matrix_s, energy_homo, energy_gap) @@ -106,16 +105,14 @@ CONTAINS CASE (ot_precond_s_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. PRESENT(matrix_s)) THEN + IF (.NOT. PRESENT(matrix_s)) & CPABORT("Type for S=1 not implemented") - END IF CALL make_full_s_inverse(preconditioner_env, matrix_s) CASE (ot_precond_full_kinetic) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) THEN + IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) & CPABORT("Type for S=1 not implemented") - END IF CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap) CASE (ot_precond_full_single_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol @@ -748,9 +745,8 @@ CONTAINS matrices(1)%matrix => dbcsr_cThc CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=1.0E-3_dp, selection_crit=2, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) - IF (ASSOCIATED(preconditioner_env%max_ev_vector)) THEN + IF (ASSOCIATED(preconditioner_env%max_ev_vector)) & CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%max_ev_vector) - END IF CALL arnoldi_ev(matrices, arnoldi_env) max_ev = REAL(get_selected_ritz_val(arnoldi_env, 1), dp) @@ -780,9 +776,8 @@ CONTAINS CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=2.0E-2_dp, selection_crit=3, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) END IF - IF (ASSOCIATED(preconditioner_env%min_ev_vector)) THEN + IF (ASSOCIATED(preconditioner_env%min_ev_vector)) & CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%min_ev_vector) - END IF ! compute the LUMO energy CALL arnoldi_ev(matrices, arnoldi_env) diff --git a/src/preconditioner_solvers.F b/src/preconditioner_solvers.F index 92670b6114..21834c0f22 100644 --- a/src/preconditioner_solvers.F +++ b/src/preconditioner_solvers.F @@ -91,9 +91,8 @@ CONTAINS ! make sure preconditioner_env is not destroyed in between occ_matrix = 1.0_dp IF (ASSOCIATED(preconditioner_env%sparse_matrix)) THEN - IF (preconditioner_env%condition_num < 0.0_dp) THEN + IF (preconditioner_env%condition_num < 0.0_dp) & CALL estimate_cond_num(preconditioner_env%sparse_matrix, preconditioner_env%condition_num) - END IF CALL dbcsr_filter(preconditioner_env%sparse_matrix, & 1.0_dp/preconditioner_env%condition_num*0.01_dp) occ_matrix = dbcsr_get_occupation(preconditioner_env%sparse_matrix) diff --git a/src/pw/dgs.F b/src/pw/dgs.F index 3124a68eb4..6f47d09e24 100644 --- a/src/pw/dgs.F +++ b/src/pw/dgs.F @@ -420,7 +420,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(1)) THEN + ELSEIF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -433,7 +433,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(2)) THEN + ELSEIF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -446,7 +446,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(3)) THEN + ELSEIF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -495,7 +495,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(1)) THEN + ELSEIF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -508,7 +508,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(2)) THEN + ELSEIF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -521,7 +521,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(3)) THEN + ELSEIF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -572,7 +572,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%npts_local(1)) THEN + ELSEIF (ii >= drpot(1)%npts_local(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%npts_local(1) + 1 folded = .TRUE. ELSE @@ -585,7 +585,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%npts_local(2)) THEN + ELSEIF (ii >= drpot(1)%npts_local(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%npts_local(2) + 1 folded = .TRUE. ELSE @@ -598,7 +598,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%npts_local(3)) THEN + ELSEIF (ii >= drpot(1)%npts_local(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%npts_local(3) + 1 folded = .TRUE. ELSE @@ -651,7 +651,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(1)) THEN + ELSEIF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%npts_local(1) + 1 folded = .TRUE. ELSE @@ -664,7 +664,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(2)) THEN + ELSEIF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%npts_local(2) + 1 folded = .TRUE. ELSE @@ -677,7 +677,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(3)) THEN + ELSEIF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%npts_local(3) + 1 folded = .TRUE. ELSE @@ -724,7 +724,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%desc%npts(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%desc%npts(1)) THEN + ELSEIF (ii >= drpot(1)%desc%npts(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -737,7 +737,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%desc%npts(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%desc%npts(2)) THEN + ELSEIF (ii >= drpot(1)%desc%npts(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -750,7 +750,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%desc%npts(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%desc%npts(3)) THEN + ELSEIF (ii >= drpot(1)%desc%npts(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%desc%npts(3) + 1 folded = .TRUE. ELSE @@ -798,7 +798,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%desc%npts(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(1)) THEN + ELSEIF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -811,7 +811,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%desc%npts(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(2)) THEN + ELSEIF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -824,7 +824,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%desc%npts(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(3)) THEN + ELSEIF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%desc%npts(3) + 1 folded = .TRUE. ELSE diff --git a/src/pw/dirichlet_bc_methods.F b/src/pw/dirichlet_bc_methods.F index 69499538b4..6dc8e30b92 100644 --- a/src/pw/dirichlet_bc_methods.F +++ b/src/pw/dirichlet_bc_methods.F @@ -905,7 +905,7 @@ CONTAINS END SELECT alpha = linspace(0.0_dp, 2*pi, n_dbcs + 1) - alpha_rotd = alpha + delta_alpha + alpha_rotd = alpha + delta_alpha; SELECT CASE (parallel_axis) CASE (x_axis) DO j = 1, n_dbcs @@ -1180,7 +1180,7 @@ CONTAINS IF (direction == FWROT) THEN vec_tmp = MATMUL(Rmat, vec) vec_transfd = vec_tmp + Tp - ELSE IF (direction == BWROT) THEN + ELSEIF (direction == BWROT) THEN Rmat_inv = inv_3x3(Rmat) Tpoint(1) = Rmat_inv(1, 1)*Tp(1) + Rmat_inv(1, 2)*Tp(2) + Rmat_inv(1, 3)*Tp(3) Tpoint(2) = Rmat_inv(2, 1)*Tp(1) + Rmat_inv(2, 2)*Tp(2) + Rmat_inv(2, 3)*Tp(3) diff --git a/src/pw/fft/fftw3_lib.F b/src/pw/fft/fftw3_lib.F index 08de4d3143..b71f789160 100644 --- a/src/pw/fft/fftw3_lib.F +++ b/src/pw/fft/fftw3_lib.F @@ -162,10 +162,9 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_export_wisdom_to_filename(wisdom_file_name_c) - IF (isuccess == 0) THEN + IF (isuccess == 0) & CALL cp_warn(__LOCATION__, "Error exporting wisdom to file "//TRIM(wisdom_file)//". "// & "Wisdom was not exported.") - END IF END IF END IF @@ -192,9 +191,8 @@ CONTAINS LOGICAL :: file_exists isuccess = fftw_init_threads() - IF (isuccess == 0) THEN + IF (isuccess == 0) & CPABORT("Error initializing FFTW with threads") - END IF ! Read FFTW wisdom (if available) ! all nodes are opening the file here... @@ -214,11 +212,10 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_import_wisdom_from_filename(wisdom_file_name_c) - IF (isuccess == 0) THEN + IF (isuccess == 0) & CALL cp_warn(__LOCATION__, "Error importing wisdom from file "//TRIM(wisdom_file)//". "// & "Maybe the file was created with a different configuration than CP2K is run with. "// & "CP2K continues without importing wisdom.") - END IF END IF END IF #else @@ -1042,7 +1039,7 @@ CONTAINS IF (plan%fsign == +1 .AND. plan%trans) THEN istride = plan%m idist = 1 - ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN + ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN ostride = plan%m odist = 1 END IF @@ -1164,7 +1161,7 @@ CONTAINS !$ out_offset = 1 + plan%num_rows*my_id*plan%n !$ IF (plan%fsign == +1 .AND. plan%trans) THEN !$ in_offset = 1 + plan%num_rows*my_id -!$ ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN +!$ ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN !$ out_offset = 1 + plan%num_rows*my_id !$ END IF !$ scal_offset = 1 + plan%n*plan%num_rows*my_id diff --git a/src/pw/fft/mltfftsg_tools.F b/src/pw/fft/mltfftsg_tools.F index c1a5b01d5b..a81b903ac7 100644 --- a/src/pw/fft/mltfftsg_tools.F +++ b/src/pw/fft/mltfftsg_tools.F @@ -15,10 +15,7 @@ MODULE mltfftsg_tools #include "../../base/base_uses.f90" - IMPLICIT NONE - PRIVATE - INTEGER, PARAMETER :: ctrig_length = 1024 INTEGER, PARAMETER :: cache_size = 2048 PUBLIC :: mltfftsg diff --git a/src/pw/fft_tools.F b/src/pw/fft_tools.F index 0c0940b882..3f05511557 100644 --- a/src/pw/fft_tools.F +++ b/src/pw/fft_tools.F @@ -1135,7 +1135,7 @@ CONTAINS END IF END IF - ELSE IF (sign == BWFFT) THEN + ELSEIF (sign == BWFFT) THEN ! Stage 3 -> 1 bbuf => fft_scratch%a5buf @@ -1217,7 +1217,7 @@ CONTAINS CALL release_fft_scratch(fft_scratch) - ELSE IF (DIM(2) == 1) THEN + ELSEIF (DIM(2) == 1) THEN ! ! Second case; one stage of communication @@ -1277,7 +1277,7 @@ CONTAINS END IF END IF - ELSE IF (sign == BWFFT) THEN + ELSEIF (sign == BWFFT) THEN ! Stage 3 -> 1 IF (test) THEN diff --git a/src/pw/mt_util.F b/src/pw/mt_util.F index 365f65c469..148c8f3b92 100644 --- a/src/pw/mt_util.F +++ b/src/pw/mt_util.F @@ -110,9 +110,8 @@ CONTAINS g3d = fourpi/g2 screen_function%array(ig) = screen_function%array(ig) - g3d*EXP(-g2/(4.0E0_dp*alpha2)) END DO - IF (screen_function%pw_grid%have_g0) THEN + IF (screen_function%pw_grid%have_g0) & screen_function%array(1) = screen_function%array(1) + fourpi/(4.0E0_dp*alpha2) - END IF CASE (MT2D) iz = special_dimension ! iz is the direction with NO PBC zlength = slab_size ! zlength is the thickness of the cell diff --git a/src/pw/ps_implicit_methods.F b/src/pw/ps_implicit_methods.F index ba575985e8..705f5bbde2 100644 --- a/src/pw/ps_implicit_methods.F +++ b/src/pw/ps_implicit_methods.F @@ -274,9 +274,8 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -287,9 +286,8 @@ CONTAINS END DO CALL ps_implicit_print_convergence_msg(iter, max_iter, outp_unit) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & CALL pw_copy(v_new, ps_implicit_env%initial_guess) - END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -441,9 +439,8 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -457,9 +454,8 @@ CONTAINS CALL pw_shrink(neumann_directions, dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_local_shftd, v_new_xpndd, v_new) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & CALL pw_copy(v_new_xpndd, ps_implicit_env%initial_guess) - END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -709,9 +705,8 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -999,9 +994,8 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -1255,15 +1249,13 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) THEN + IF (info /= 0) & CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") - END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Inversion of R failed!") - END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) CALL pw_pool_release(pw_pool_xpndd) @@ -1386,15 +1378,13 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) THEN + IF (info /= 0) & CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") - END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Inversion of R failed!") - END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) diff --git a/src/pw/ps_wavelet_base.F b/src/pw/ps_wavelet_base.F index ad7d3efa69..2a9fc0f9b0 100644 --- a/src/pw/ps_wavelet_base.F +++ b/src/pw/ps_wavelet_base.F @@ -12,7 +12,6 @@ MODULE ps_wavelet_base USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_fft3d, ONLY: ctrig,& ctrig_length,& @@ -706,8 +705,9 @@ CONTAINS REAL(KIND=dp), INTENT(in) :: hx, hy, hz INTEGER :: i1, i2, j1, j2, j3 - REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2 + REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2, pi + pi = 4._dp*ATAN(1._dp) fourpi2 = 4._dp*pi**2 j3 = i3 !n3/2+1-abs(n3/2+2-i3) mu3 = REAL(j3 - 1, KIND=dp)/REAL(n3, KIND=dp) diff --git a/src/pw/ps_wavelet_fft3d.F b/src/pw/ps_wavelet_fft3d.F index cf470a0206..2381556718 100644 --- a/src/pw/ps_wavelet_fft3d.F +++ b/src/pw/ps_wavelet_fft3d.F @@ -112,14 +112,15 @@ CONTAINS ! Different factorizations affect the performance ! Factoring 64 as 4*4*4 might for example be faster on some machines than 8*8. INTEGER :: n - REAL(KIND=dp) :: trig(2, ctrig_length) - INTEGER :: after(7), before(7), now(7), isign, ic + REAL(KIND=dp) :: trig + INTEGER :: after, before, now, isign, ic CHARACTER(LEN=888) :: err INTEGER :: i, itt, j, nh - INTEGER, DIMENSION(7, 149) :: idata REAL(KIND=dp) :: angle, trigc, trigs, twopi + DIMENSION now(7), after(7), before(7), trig(2, ctrig_length) + INTEGER, DIMENSION(7, 149) :: idata ! The factor 6 is only allowed in the first place! DATA((idata(i, j), i=1, 7), j=1, 76)/ & 3, 3, 1, 1, 1, 1, 1, 4, 4, 1, 1, 1, 1, 1, & @@ -284,8 +285,7 @@ CONTAINS ! GNU General Public License, see http://www.gnu.org/copyleft/gpl.txt . INTEGER :: mm, nfft, m, nn, n - REAL(KIND=dp) :: zin(2, mm, m), zout(2, nn, n), & - trig(2, ctrig_length) + REAL(KIND=dp) :: zin, zout, trig INTEGER :: after, now, before, isign INTEGER :: atb, atn, ia, ias, ib, itrig, itt, j, & @@ -297,6 +297,7 @@ CONTAINS rt2i, s, s1, s2, s25, s3, s34, s4, s5, s6, s7, s8, sin2, sin4, ui1, ui2, ui3, ur1, ur2, & ur3, vi1, vi2, vi3, vr1, vr2, vr3 + DIMENSION trig(2, ctrig_length), zin(2, mm, m), zout(2, nn, n) atn = after*now atb = after*before @@ -320,8 +321,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO DO 2000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -342,8 +342,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -361,8 +360,7 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO - END DO + END DO; END DO END IF ELSE IF (4*ias == after) THEN IF (isign == 1) THEN @@ -384,8 +382,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -405,8 +402,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO END IF ELSE IF (4*ias == 3*after) THEN IF (isign == 1) THEN @@ -428,8 +424,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -449,8 +444,7 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO - END DO + END DO; END DO END IF ELSE itrig = ias*before + 1 @@ -474,8 +468,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO END IF 2000 CONTINUE ELSE IF (now == 4) THEN @@ -517,8 +510,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO DO 4000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -562,8 +554,7 @@ CONTAINS s = r2 + r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO ELSE itt = ias*before itrig = itt + 1 @@ -617,8 +608,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO END IF 4000 CONTINUE ELSE @@ -659,8 +649,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO - END DO + END DO; END DO DO 4100, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -704,8 +693,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO - END DO + END DO; END DO ELSE itt = ias*before itrig = itt + 1 @@ -759,8 +747,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO - END DO + END DO; END DO END IF 4100 CONTINUE END IF @@ -855,8 +842,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO DO 8000, ia = 2, after ias = ia - 1 itt = ias*before @@ -983,8 +969,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO 8000 CONTINUE ELSE @@ -1077,8 +1062,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO DO 8001, ia = 2, after ias = ia - 1 @@ -1206,8 +1190,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO 8001 CONTINUE END IF @@ -1243,8 +1226,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO DO 3000, ia = 2, after ias = ia - 1 IF (4*ias == 3*after) THEN @@ -1277,8 +1259,7 @@ CONTAINS zout(2, j, nout2) = s1 - r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 + r2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1308,8 +1289,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 - s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO END IF ELSE IF (8*ias == 3*after) THEN IF (isign == 1) THEN @@ -1343,8 +1323,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1376,8 +1355,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO END IF ELSE itt = ias*before @@ -1419,8 +1397,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO END IF 3000 CONTINUE ELSE IF (now == 5) THEN @@ -1483,8 +1460,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO DO 5000, ia = 2, after ias = ia - 1 IF (8*ias == 5*after) THEN @@ -1543,8 +1519,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1600,8 +1575,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO END IF ELSE ias = ia - 1 @@ -1676,8 +1650,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO END IF 5000 CONTINUE ELSE IF (now == 6) THEN @@ -1751,8 +1724,7 @@ CONTAINS zout(2, j, nout2) = ui2 - vi2 zout(1, j, nout6) = ur3 - vr3 zout(2, j, nout6) = ui3 - vi3 - END DO - END DO + END DO; END DO ELSE CPABORT("error fftstp") END IF diff --git a/src/pw/ps_wavelet_kernel.F b/src/pw/ps_wavelet_kernel.F index b39df92602..c535a1fa43 100644 --- a/src/pw/ps_wavelet_kernel.F +++ b/src/pw/ps_wavelet_kernel.F @@ -12,7 +12,6 @@ MODULE ps_wavelet_kernel USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_base, ONLY: scramble_unpack USE ps_wavelet_fft3d, ONLY: ctrig,& @@ -236,8 +235,8 @@ CONTAINS shift INTEGER, ALLOCATABLE, DIMENSION(:) :: after, before, now REAL(kind=dp) :: a, b, c, cp, d, diff, dx, feI, feR, foI, & - foR, fR, mu1, pion, ponx, pony, sp, & - value, x + foR, fR, mu1, pi, pion, ponx, pony, & + sp, value, x REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: kernel_scf, x_scf, y_scf REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: btrig, cossinarr REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: halfft_cache, kernel @@ -356,6 +355,9 @@ CONTAINS ALLOCATE (now(7)) ALLOCATE (before(7)) + !constants + pi = 4._dp*ATAN(1._dp) + !arrays for the halFFT CALL ctrig(n3/2, btrig, after, before, now, 1, ic) diff --git a/src/pw/ps_wavelet_methods.F b/src/pw/ps_wavelet_methods.F index 624bae7120..7ca3a4c95d 100644 --- a/src/pw/ps_wavelet_methods.F +++ b/src/pw/ps_wavelet_methods.F @@ -90,12 +90,10 @@ CONTAINS hz = pw_grid%dr(wavelet%axis(3)) IF (poisson_params%wavelet_method == WAVELET0D) THEN - IF (hx /= hy) THEN + IF (hx /= hy) & CPABORT("Poisson solver for non cubic cells not yet implemented") - END IF - IF (hz /= hy) THEN + IF (hz /= hy) & CPABORT("Poisson solver for non cubic cells not yet implemented") - END IF END IF CALL RS_z_slice_distribution(wavelet, pw_grid) diff --git a/src/pw/ps_wavelet_scaling_function.F b/src/pw/ps_wavelet_scaling_function.F index 6352c34555..1eed8a8d73 100644 --- a/src/pw/ps_wavelet_scaling_function.F +++ b/src/pw/ps_wavelet_scaling_function.F @@ -74,7 +74,9 @@ CONTAINS !open (unit=1,file='scfunction',status='unknown') DO i = 0, nd a(i) = 1._dp*i*ni/nd - (.5_dp*ni - 1._dp) + !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-1._dp),x(i) END DO + !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) END SUBROUTINE scaling_function @@ -126,7 +128,9 @@ CONTAINS !open (unit=1,file='wavelet',status='unknown') DO i = 0, nd - 1 a(i) = 1._dp*i*ni/nd - (.5_dp*ni - .5_dp) + !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-.5_dp),x(i) END DO + !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) @@ -162,7 +166,7 @@ CONTAINS !> \param n ... !> \param x ... ! ************************************************************************************************** - PURE SUBROUTINE zero(n, x) + SUBROUTINE zero(n, x) INTEGER, INTENT(in) :: n REAL(KIND=dp), INTENT(out) :: x(n) diff --git a/src/pw/ps_wavelet_types.F b/src/pw/ps_wavelet_types.F index 464697a8d0..dfbfceb2db 100644 --- a/src/pw/ps_wavelet_types.F +++ b/src/pw/ps_wavelet_types.F @@ -55,12 +55,10 @@ CONTAINS TYPE(ps_wavelet_type), POINTER :: wavelet IF (ASSOCIATED(wavelet)) THEN - IF (ASSOCIATED(wavelet%karray)) THEN + IF (ASSOCIATED(wavelet%karray)) & DEALLOCATE (wavelet%karray) - END IF - IF (ASSOCIATED(wavelet%rho_z_sliced)) THEN + IF (ASSOCIATED(wavelet%rho_z_sliced)) & DEALLOCATE (wavelet%rho_z_sliced) - END IF DEALLOCATE (wavelet) END IF END SUBROUTINE ps_wavelet_release diff --git a/src/pw/pw_fpga.F b/src/pw/pw_fpga.F index 3819cd0749..3d26adb66c 100644 --- a/src/pw/pw_fpga.F +++ b/src/pw/pw_fpga.F @@ -117,9 +117,8 @@ CONTAINS CPABORT("OFFLOAD and FPGA cannot be configured concurrently! Recompile with -D__NO_OFFLOAD_PW.") #endif stat = pw_fpga_initialize() - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("pw_fpga_init: failed") - END IF #endif #if (__PW_FPGA_SP && !(__PW_FPGA)) diff --git a/src/pw/pw_gpu.F b/src/pw/pw_gpu.F index 3e752e77da..2f6a055c4d 100644 --- a/src/pw/pw_gpu.F +++ b/src/pw/pw_gpu.F @@ -301,9 +301,8 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) THEN + IF (r_dim(1) == 1) & CPABORT("This processor distribution is not supported.") - END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) @@ -464,9 +463,8 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) THEN + IF (r_dim(1) == 1) & CPABORT("This processor distribution is not supported.") - END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) diff --git a/src/pw/pw_grid_types.F b/src/pw/pw_grid_types.F index 62a9f61387..b5c6024351 100644 --- a/src/pw/pw_grid_types.F +++ b/src/pw/pw_grid_types.F @@ -44,8 +44,7 @@ MODULE pw_grid_types INTEGER, DIMENSION(:), ALLOCATABLE :: nyzray ! number of g-space rays (pe) TYPE(mp_cart_type) :: group = mp_cart_type() ! real space group (2-dim cart) INTEGER, DIMENSION(:, :, :, :), ALLOCATABLE :: bo ! list of axis distribution - INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane - ! should go: hard-codes to plane distributed + INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane....should go: hard-codes to plane distributed END TYPE pw_para_type ! all you always wanted to know about grids, but were... diff --git a/src/pw/pw_poisson_methods.F b/src/pw/pw_poisson_methods.F index 04910df1ab..89f8f65c32 100644 --- a/src/pw/pw_poisson_methods.F +++ b/src/pw/pw_poisson_methods.F @@ -537,9 +537,8 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & CPABORT("vhartree has a different grid than the poisson solver") - END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -949,9 +948,8 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & CPABORT("vhartree has a different grid than the poisson solver") - END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -1294,12 +1292,12 @@ CONTAINS CALL timeset(routineN, handle) - IF (PRESENT(parameters)) poisson_env%parameters = parameters + IF (PRESENT(parameters)) & + poisson_env%parameters = parameters IF (PRESENT(cell_hmat)) THEN - IF (ANY(poisson_env%cell_hmat /= cell_hmat)) THEN + IF (ANY(poisson_env%cell_hmat /= cell_hmat)) & CALL pw_poisson_cleanup(poisson_env) - END IF poisson_env%cell_hmat(:, :) = cell_hmat(:, :) poisson_env%rebuild = .TRUE. END IF diff --git a/src/pw/pw_poisson_types.F b/src/pw/pw_poisson_types.F index 624cadd4c0..b73b8423cb 100644 --- a/src/pw/pw_poisson_types.F +++ b/src/pw/pw_poisson_types.F @@ -367,9 +367,8 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d*(1.0_dp - COS(rlength*gg)) END DO - IF (grid%have_g0) THEN + IF (grid%have_g0) & gf%array(1) = 0.5_dp*fourpi*rlength*rlength - END IF CASE (MT2D, MT1D, MT0D) @@ -378,9 +377,8 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d + green%screen_fn%array(ig) END DO - IF (grid%have_g0) THEN + IF (grid%have_g0) & gf%array(1) = green%screen_fn%array(1) - END IF CASE (PS_IMPLICIT) @@ -454,12 +452,10 @@ CONTAINS DEALLOCATE (gftype%p3m_charge) END IF END IF - IF (ALLOCATED(gftype%p3m_bm2)) THEN + IF (ALLOCATED(gftype%p3m_bm2)) & DEALLOCATE (gftype%p3m_bm2) - END IF - IF (ALLOCATED(gftype%p3m_coeff)) THEN + IF (ALLOCATED(gftype%p3m_coeff)) & DEALLOCATE (gftype%p3m_coeff) - END IF END SUBROUTINE pw_green_release ! ************************************************************************************************** diff --git a/src/pw/pw_spline_utils.F b/src/pw/pw_spline_utils.F index 8459f07cb6..4e708be0a3 100644 --- a/src/pw/pw_spline_utils.F +++ b/src/pw/pw_spline_utils.F @@ -2116,7 +2116,7 @@ CONTAINS + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 + ww0(2)*vv7 + vv0*ww1(2) coarse_coeffs(i + 3, j, k) = coarse_coeffs(i + 3, j, k) & + ww1(4)*vv6 + ww0(3)*vv7 + vv0*ww1(3) - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv0 = fine_values(fi, fj, fk) vv1 = fine_values(fine_bo(1, 1), fj, fk) @@ -2158,7 +2158,7 @@ CONTAINS + ww1(3)*vv4 + ww0(2)*vv5 + ww1(2)*vv6 coarse_coeffs(i + 2, j, k) = coarse_coeffs(i + 2, j, k) & + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv6 = fine_values(fi, fj, fk) vv7 = fine_values(fine_bo(1, 1), fj, fk) @@ -2202,7 +2202,7 @@ CONTAINS + ww1(3)*vv2 + ww0(2)*vv3 + ww1(2)*vv4 coarse_coeffs(i + 1, j, k) = coarse_coeffs(i + 1, j, k) & + ww1(4)*vv2 + ww0(3)*vv3 + ww1(3)*vv4 - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv4 = fine_values(fi, fj, fk) vv5 = fine_values(fine_bo(1, 1), fj, fk) @@ -2244,7 +2244,7 @@ CONTAINS + ww1(3)*vv0 + ww0(2)*vv1 + ww1(2)*vv2 coarse_coeffs(i, j, k) = coarse_coeffs(i, j, k) & + ww1(4)*vv0 + ww0(3)*vv1 + ww1(3)*vv2 - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv2 = fine_values(fi, fj, fk) vv3 = fine_values(fine_bo(1, 1), fk, fk) @@ -2348,9 +2348,8 @@ CONTAINS send_offset(ip) = send_tot_size send_tot_size = send_tot_size + send_size(ip) END DO - IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) THEN + IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) & CPABORT("Error calculating send_tot_size") - END IF ALLOCATE (send_buf(0:send_tot_size - 1)) rcv_tot_size = 0 @@ -2375,12 +2374,10 @@ CONTAINS sent_size(p) = sent_size(p) + coarse_slice_size END DO - IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) THEN + IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) & CPABORT("error 1 filling send buffer") - END IF - IF (sent_size(n_procs - 1) /= send_tot_size) THEN + IF (sent_size(n_procs - 1) /= send_tot_size) & CPABORT("error 2 filling send buffer") - END IF IF (local_data) THEN DEALLOCATE (coarse_coeffs) @@ -2444,12 +2441,10 @@ CONTAINS END DO - IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) THEN + IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) & CPABORT("error 1 handling the rcv buffer") - END IF - IF (sent_size(n_procs - 1) /= rcv_tot_size) THEN + IF (sent_size(n_procs - 1) /= rcv_tot_size) & CPABORT("error 2 handling the rcv buffer") - END IF ! dealloc DEALLOCATE (send_size, send_offset, rcv_size, rcv_offset) diff --git a/src/pw/realspace_grid_cube.F b/src/pw/realspace_grid_cube.F index 05af7923fa..c470d2ac77 100644 --- a/src/pw/realspace_grid_cube.F +++ b/src/pw/realspace_grid_cube.F @@ -121,10 +121,9 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") - END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) @@ -269,9 +268,8 @@ CONTAINS ELSE size_of_z = CEILING(REAL(pw%pw_grid%bounds(2, 3) - pw%pw_grid%bounds(1, 3) + 1, dp)/REAL(my_stride(3), dp)) num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) THEN + IF (MODULO(size_of_z, num_entries_line) /= 0) & num_linebreak = num_linebreak + 1 - END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL mp_unit%set_handle(unit_nr) CALL pw_to_cube_parallel(pw, mp_unit, title, particles_r, particles_z, particles_zeff, & @@ -411,9 +409,8 @@ CONTAINS ! Each data line of a Gaussian cube contains max 6 entries with last line potentially containing less if nz % 6 /= 0 ! Thus, this size is simply the number of entries multiplied by the entry size + the number of line breaks num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) THEN + IF (MODULO(size_of_z, num_entries_line) /= 0) & num_linebreak = num_linebreak + 1 - END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL cube_to_pw_parallel(grid, filename, scaling, msglen, silent=silent) END IF @@ -633,10 +630,9 @@ CONTAINS IF ((lbounds_local(1) <= i) .AND. (i <= ubounds_local(1)) .AND. (lbounds_local(2) <= j) & .AND. (j <= ubounds_local(2))) THEN !allow scaling of external potential values by factor 'scaling' (SCALING_FACTOR in input file) - IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) THEN + IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) & CALL cp_abort(__LOCATION__, & "Error in parallel read of input cube file.") - END IF END IF END DO @@ -828,9 +824,8 @@ CONTAINS END IF tmp = TRIM(tmp)//TRIM(value) counter = counter + 1 - IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) THEN + IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) & tmp = TRIM(tmp)//NEW_LINE('C') - END IF END DO writebuffer(islice) = tmp islice = islice + 1 @@ -894,10 +889,9 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") - END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_cube_unittest.F b/src/pw/realspace_grid_cube_unittest.F index b1685dc56b..7732cea3ea 100644 --- a/src/pw/realspace_grid_cube_unittest.F +++ b/src/pw/realspace_grid_cube_unittest.F @@ -19,24 +19,20 @@ PROGRAM realspace_grid_cube_unittest REAL(KIND=dp), DIMENSION(7) :: slice_buffer, slice_reference WRITE (value, cube_value_format) 0.33004E-101_dp - IF (INDEX(value, "E-101") <= 0) THEN + IF (INDEX(value, "E-101") <= 0) & ERROR STOP "Cube value format must preserve three-digit negative exponents." - END IF reference = [0.0_dp, -0.91458E-35_dp, 0.33004E-101_dp, & -0.32487E-103_dp, 1.0_dp, -1.0_dp] WRITE (values(1:78), cube_values_format) reference values(79:79) = NEW_LINE("C") - IF (INDEX(values, "E-101") <= 0) THEN + IF (INDEX(values, "E-101") <= 0) & ERROR STOP "Cube line format must preserve E-101." - END IF - IF (INDEX(values, "E-103") <= 0) THEN + IF (INDEX(values, "E-103") <= 0) & ERROR STOP "Cube line format must preserve E-103." - END IF CALL cube_read_values(values, buffer) - IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) THEN + IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) & ERROR STOP "Cube reader must parse adjacent explicit-exponent values." - END IF slice_reference(1:6) = reference slice_reference(7) = 0.27183E-123_dp @@ -44,8 +40,7 @@ PROGRAM realspace_grid_cube_unittest slice_values(79:79) = NEW_LINE("C") WRITE (slice_values(80:92), cube_value_format) slice_reference(7) CALL cube_read_values(slice_values, slice_buffer) - IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) THEN + IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) & ERROR STOP "Cube reader must parse multi-line z-slices." - END IF END PROGRAM realspace_grid_cube_unittest diff --git a/src/pw/realspace_grid_openpmd.F b/src/pw/realspace_grid_openpmd.F index 131d0344ff..b64caaa0e6 100644 --- a/src/pw/realspace_grid_openpmd.F +++ b/src/pw/realspace_grid_openpmd.F @@ -340,10 +340,9 @@ CONTAINS IF (PRESENT(mpi_io)) parallel_write = mpi_io my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") - END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_types.F b/src/pw/realspace_grid_types.F index 57ac9540a9..b54f99a6ee 100644 --- a/src/pw/realspace_grid_types.F +++ b/src/pw/realspace_grid_types.F @@ -659,9 +659,8 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & CPABORT("Different rs and pw indentifiers") - END IF IF (rs%desc%distributed) THEN CALL transfer_rs2pw_distributed(rs, pw) @@ -703,9 +702,8 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & CPABORT("Different rs and pw indentifiers") - END IF IF (rs%desc%distributed) THEN CALL transfer_pw2rs_distributed(rs, pw) diff --git a/src/qcschema.F b/src/qcschema.F index 23ce8e1b05..a4eae93faf 100644 --- a/src/qcschema.F +++ b/src/qcschema.F @@ -407,12 +407,10 @@ CONTAINS IF (dft_control%dft_plus_u) CPABORT('WARNING: DFT+U not supported in QCSchema') IF (dft_control%do_sccs) CPABORT('WARNING: SCCS not supported in QCSchema') IF (qs_env%qmmm) CPABORT('WARNING: QM/MM not supported in QCSchema') - IF (dft_control%qs_control%mulliken_restraint) THEN + IF (dft_control%qs_control%mulliken_restraint) & CPABORT('WARNING: Mulliken restrains not supported in QCSchema') - END IF - IF (dft_control%qs_control%semi_empirical) THEN + IF (dft_control%qs_control%semi_empirical) & CPABORT('WARNING: semi_empirical methods not supported in QCSchema') - END IF IF (dft_control%qs_control%dftb) CPABORT('WARNING: DFTB not supported in QCSchema') IF (dft_control%qs_control%xtb) CPABORT('WARNING: xTB not supported in QCSchema') diff --git a/src/qmmm_create.F b/src/qmmm_create.F index 1cbe80ccf4..f15dd5d2f0 100644 --- a/src/qmmm_create.F +++ b/src/qmmm_create.F @@ -228,12 +228,11 @@ CONTAINS IF (explicit .AND. use_multipole == do_multipole_section_on) qmmm_env_qm%multipole = .TRUE. IF (qmmm_env_qm%periodic .AND. qmmm_env_qm%multipole) CALL cite_reference(Laino2006) IF (qmmm_coupl_type == do_qmmm_none) THEN - IF (qmmm_env_qm%periodic) THEN + IF (qmmm_env_qm%periodic) & CALL cp_warn(__LOCATION__, & "QMMM periodic calculation with coupling NONE was requested! "// & "Switching off the periodic keyword since periodic and non-periodic "// & "calculation with coupling NONE represent the same method! ") - END IF qmmm_env_qm%periodic = .FALSE. END IF @@ -299,9 +298,8 @@ CONTAINS CALL get_cell(mm_cell, abc=abc_mm) IF (qmmm_env_qm%image_charge) THEN - IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) THEN + IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) & CPABORT("QM and MM box need to have the same size when using image charges") - END IF END IF ! Assign charges and mm_el_pot_radius from fist_topology diff --git a/src/qmmm_elpot.F b/src/qmmm_elpot.F index da89a5d1a5..9774d16564 100644 --- a/src/qmmm_elpot.F +++ b/src/qmmm_elpot.F @@ -145,7 +145,7 @@ CONTAINS t = 2._dp/(rootpi*x*rc)*EXP(-(x/rc)**2) pot0_2(2, i) = (t - pot0_2(1, i)/x)*dx END DO - ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN ! S-wave expansion :: 1/x - exp(-2*x/rc) * ( 1/x - 1/rc ) pot0_2(1, 1) = 1.0_dp/rc pot0_2(2, 1) = 0.0_dp diff --git a/src/qmmm_force.F b/src/qmmm_force.F index a892769aff..4b4b876627 100644 --- a/src/qmmm_force.F +++ b/src/qmmm_force.F @@ -135,11 +135,10 @@ CONTAINS WRITE (unit=output_unit, fmt='("ip, j, pos, lat_pos ",2I6,6F12.5)') ip, j, & particles_qm(ip)%r, DOT_PRODUCT(qm_cell%h_inv(j, :), particles_qm(ip)%r) END IF - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "QM/MM QM atoms must be fully contained in the same image of the QM box "// & "- No wrapping of coordinates is allowed! ") - END IF END DO END DO diff --git a/src/qmmm_gaussian_init.F b/src/qmmm_gaussian_init.F index 7885a7c400..c588591b9e 100644 --- a/src/qmmm_gaussian_init.F +++ b/src/qmmm_gaussian_init.F @@ -163,7 +163,7 @@ CONTAINS IF (qmmm_coupl_type == do_qmmm_gauss) THEN CALL set_mm_potential_erf(qmmm_gaussian_fns, & compatibility, num_geep_gauss) - ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN CALL set_mm_potential_swave(qmmm_gaussian_fns, & num_geep_gauss) END IF diff --git a/src/qmmm_gpw_energy.F b/src/qmmm_gpw_energy.F index d62e251621..af8d7d34af 100644 --- a/src/qmmm_gpw_energy.F +++ b/src/qmmm_gpw_energy.F @@ -126,9 +126,8 @@ CONTAINS print_section => section_vals_get_subs_vals(input_section, "QMMM%PRINT") iw = cp_print_key_unit_nr(logger, print_section, "PROGRAM_RUN_INFO", & extension=".qmmmLog") - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(T2,"QMMM|",1X,A)') "Information on the QM/MM Electrostatic Potential:" - END IF ! ! Initializing vectors: ! Zeroing v_qmmm_rspace @@ -149,7 +148,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -173,10 +172,9 @@ CONTAINS CASE (do_qmmm_pcharge) CPABORT("Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.") CASE (do_qmmm_gauss, do_qmmm_swave) - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(T2,"QMMM|",1X,A)') & - "QM/MM Coupling computed collocating the Gaussian Potential Functions." - END IF + "QM/MM Coupling computed collocating the Gaussian Potential Functions." interp_section => section_vals_get_subs_vals(input_section, & "QMMM%INTERPOLATOR") CALL qmmm_elec_with_gaussian(qmmm_env=qmmm_env, & @@ -809,9 +807,8 @@ CONTAINS IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm qt = mm_charges(LIndMM) - IF (shells) THEN + IF (shells) & ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - END IF ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) diff --git a/src/qmmm_gpw_forces.F b/src/qmmm_gpw_forces.F index a4246fdc39..f2ecb1a293 100644 --- a/src/qmmm_gpw_forces.F +++ b/src/qmmm_gpw_forces.F @@ -176,7 +176,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -1212,9 +1212,8 @@ CONTAINS LIndMM = pot%mm_atom_index(Imm) IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - IF (shells) THEN + IF (shells) & ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - END IF qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN @@ -1422,11 +1421,10 @@ CONTAINS Err(K) = (Analytical_Forces(K, I) - Num_Forces(K, I))/Num_Forces(K, I)*100.0_dp END IF END DO - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) IndMM, Analytical_Forces(1, I), Num_Forces(1, I), Err(1), & - Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & - Analytical_Forces(3, I), Num_Forces(3, I), Err(3) - END IF + Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & + Analytical_Forces(3, I), Num_Forces(3, I), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1534,11 +1532,10 @@ CONTAINS Err(2) = (debug_force(2) - force(2))/force(2)*100.0_dp Err(3) = (debug_force(3) - force(3))/force(3)*100.0_dp END IF - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) Icount, debug_force(1), force(1), Err(1), & - debug_force(2), force(2), Err(2), & - debug_force(3), force(3), Err(3) - END IF + debug_force(2), force(2), Err(2), & + debug_force(3), force(3), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1641,10 +1638,9 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) - END IF + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1658,11 +1654,10 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) - END IF + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1757,10 +1752,9 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) - END IF + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1774,11 +1768,10 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) - END IF + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) diff --git a/src/qmmm_image_charge.F b/src/qmmm_image_charge.F index f721612be5..607d4db02f 100644 --- a/src/qmmm_image_charge.F +++ b/src/qmmm_image_charge.F @@ -587,12 +587,11 @@ CONTAINS CALL calculate_image_matrix(image_matrix=qs_env%image_matrix, & ipiv=qs_env%ipiv, qs_env=qs_env, qmmm_env=qmmm_env) qmmm_env%image_charge_pot%state_image_matrix = calc_once_done - IF (qmmm_env%center_qm_subsys0) THEN + IF (qmmm_env%center_qm_subsys0) & CALL cp_warn(__LOCATION__, & "The image atoms are fully "// & "constrained and the image matrix is only calculated once. "// & "To be safe, set CENTER to NEVER ") - END IF CASE (calc_once_done) ! do nothing image matrix is stored CASE DEFAULT diff --git a/src/qmmm_init.F b/src/qmmm_init.F index 3655e31cd0..a2499ee7c9 100644 --- a/src/qmmm_init.F +++ b/src/qmmm_init.F @@ -667,11 +667,10 @@ CONTAINS ELSE IF (qmmm_env%spherical_cutoff(2) <= 0.0_dp) qmmm_env%spherical_cutoff(2) = EPSILON(0.0_dp) tmp_radius = qmmm_env%spherical_cutoff(1) - 20.0_dp*qmmm_env%spherical_cutoff(2) - IF (tmp_radius <= 0.0_dp) THEN + IF (tmp_radius <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "SPHERICAL_CUTOFF(1) > 20*SPHERICAL_CUTOFF(1)! Please correct parameters for "// & "the Spherical Cutoff in order to satisfy the previous condition!") - END IF END IF ! ! Initialization of arrays and core_charge_radius... @@ -1033,15 +1032,12 @@ CONTAINS END SELECT END DO END IF - IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) THEN + IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) & ALLOCATE (mm_link_scale_factor(link_involv_mm)) - END IF - IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) THEN + IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) & ALLOCATE (fist_scale_charge_link(link_involv_mm)) - END IF - IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) THEN + IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) & ALLOCATE (mm_link_atoms(link_involv_mm)) - END IF IF (PRESENT(qm_atom_index)) ALLOCATE (qm_atom_index(num_qm_atom_tot)) IF (PRESENT(qm_atom_type)) ALLOCATE (qm_atom_type(num_qm_atom_tot)) IF (PRESENT(qm_atom_index)) qm_atom_index = 0 @@ -1290,9 +1286,8 @@ CONTAINS CALL section_vals_val_get(move_section, "RADIUS", r_val=radius, i_rep_section=i_add) CALL section_vals_val_get(move_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) THEN + IF (n_rep_val == 1) & CALL section_vals_val_get(move_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) - END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1318,9 +1313,8 @@ CONTAINS CALL section_vals_val_get(add_section, "CHARGE", r_val=charge, i_rep_section=i_add) CALL section_vals_val_get(add_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) THEN + IF (n_rep_val == 1) & CALL section_vals_val_get(add_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) - END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, charge, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1502,9 +1496,8 @@ CONTAINS END IF DO j = i + 1, num_image_mm_atom atom_b = qmmm_env%image_charge_pot%image_mm_list(j) - IF (atom_a == atom_b) THEN + IF (atom_a == atom_b) & CPABORT("There are atoms doubled in image list.") - END IF END DO END DO diff --git a/src/qmmm_links_methods.F b/src/qmmm_links_methods.F index 671195819f..c7ca6d962e 100644 --- a/src/qmmm_links_methods.F +++ b/src/qmmm_links_methods.F @@ -63,20 +63,18 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") - END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") - END IF ip_mm = ip particles(ip_mm)%r = alpha*particles(ip_mm)%r + (1.0_dp - alpha)*particles(ip_qm)%r END DO @@ -112,20 +110,18 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") - END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") - END IF ip_mm = ip particles_qm(ip_qm)%f = particles_qm(ip_qm)%f + particles_qm(ip_mm)%f*(1.0_dp - alpha) particles_qm(ip_mm)%f = particles_qm(ip_mm)%f*alpha diff --git a/src/qmmm_per_elpot.F b/src/qmmm_per_elpot.F index 1d46ede77e..c13f0ff4fe 100644 --- a/src/qmmm_per_elpot.F +++ b/src/qmmm_per_elpot.F @@ -173,7 +173,7 @@ CONTAINS g = SQRT(g2) IF (qmmm_coupl_type == do_qmmm_gauss) THEN LG(idim) = 4.0_dp*Pi/g2*EXP(-(g2*rc2)/4.0_dp) - ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN tmp = 4.0_dp/rc2 LG(idim) = 4.0_dp*Pi*tmp**2/(g2*(g2 + tmp)**2) END IF @@ -363,9 +363,8 @@ CONTAINS CALL ewald_env_get(ewald_env, ewald_type=ewald_type, do_multipoles=do_multipoles, & gmax=gmax, o_spline=o_spline, alpha=alpha, rcut=rcut) - IF (do_multipoles) THEN + IF (do_multipoles) & CPABORT("No multipole force fields allowed in QM-QM Ewald long range correction") - END IF SELECT CASE (qmmm_coupl_type) CASE (do_qmmm_coulomb) diff --git a/src/qmmm_tb_methods.F b/src/qmmm_tb_methods.F index a1d0aab62f..8058c41956 100644 --- a/src/qmmm_tb_methods.F +++ b/src/qmmm_tb_methods.F @@ -147,7 +147,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -159,7 +159,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -179,7 +179,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -263,7 +263,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -275,7 +275,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -363,7 +363,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -375,7 +375,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -469,7 +469,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -512,7 +512,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -644,7 +644,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -654,7 +654,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -675,7 +675,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -703,7 +703,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -743,7 +743,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN ! use all kinds END IF DO i = 1, SIZE(list) @@ -887,7 +887,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -897,7 +897,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -917,7 +917,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -1054,7 +1054,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1116,7 +1116,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1159,7 +1159,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN ! END IF DO i = 1, SIZE(list) diff --git a/src/qmmm_topology_util.F b/src/qmmm_topology_util.F index ad9f796bdb..3ea4eaf263 100644 --- a/src/qmmm_topology_util.F +++ b/src/qmmm_topology_util.F @@ -139,9 +139,8 @@ CONTAINS molecule => molecule_set(imolecule) CALL get_molecule(molecule, molecule_kind=molecule_kind, & first_atom=first_atom, last_atom=last_atom) - IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) THEN + IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) & qm_mol_num = qm_mol_num + 1 - END IF END DO ! ALLOCATE (qm_molecule_index(qm_mol_num)) diff --git a/src/qmmm_util.F b/src/qmmm_util.F index 3357a6cfff..18cdfd5389 100644 --- a/src/qmmm_util.F +++ b/src/qmmm_util.F @@ -128,11 +128,10 @@ CONTAINS END IF IF (force_env%in_use == use_qmmmx) THEN - IF (iwall_type /= do_qmmm_wall_none) THEN + IF (iwall_type /= do_qmmm_wall_none) & CALL cp_warn(__LOCATION__, & "Reflective walls for QM/MM are not implemented (or useful) when "// & "force mixing is active. Skipping!") - END IF RETURN END IF @@ -620,7 +619,7 @@ CONTAINS REAL(KIND=dp) :: r, r0 - r = NORM2(rij) + r = SQRT(DOT_PRODUCT(rij, rij)) r0 = spherical_cutoff(1) - 20.0_dp*spherical_cutoff(2) factor = 0.5_dp*(1.0_dp - TANH((r - r0)/spherical_cutoff(2))) diff --git a/src/qmmmx_force.F b/src/qmmmx_force.F index 72afe1f591..1e69447e42 100644 --- a/src/qmmmx_force.F +++ b/src/qmmmx_force.F @@ -80,10 +80,9 @@ CONTAINS TYPE(section_vals_type), POINTER :: force_env_section IF (PRESENT(require_consistent_energy_force)) THEN - IF (require_consistent_energy_force) THEN + IF (require_consistent_energy_force) & CALL cp_abort(__LOCATION__, & "qmmmx_energy_and_forces got require_consistent_energy_force but force mixing is active. ") - END IF END IF ! Possibly translate the system @@ -119,9 +118,9 @@ CONTAINS IF (mom_conserv_region == do_fm_mom_conserv_core) THEN mom_conserv_min_label = force_mixing_label_QM_core - ELSE IF (mom_conserv_region == do_fm_mom_conserv_QM) THEN + ELSEIF (mom_conserv_region == do_fm_mom_conserv_QM) THEN mom_conserv_min_label = force_mixing_label_QM_dynamics - ELSE IF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN + ELSEIF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN mom_conserv_min_label = force_mixing_label_buffer ELSE CPABORT("Got unknown MOMENTUM_CONSERVATION_REGION (not CORE, QM, or BUFFER) !") @@ -142,9 +141,8 @@ CONTAINS ELSE IF (mom_conserv_type == do_fm_mom_conserv_equal_a) THEN mom_conserv_mass = 0.0_dp DO ip = 1, SIZE(cur_indices) - IF (cur_labels(ip) >= mom_conserv_min_label) THEN + IF (cur_labels(ip) >= mom_conserv_min_label) & mom_conserv_mass = mom_conserv_mass + particles_qmmm_core(cur_indices(ip))%atomic_kind%mass - END IF END DO delta_a = total_f/mom_conserv_mass DO ip = 1, SIZE(cur_indices) diff --git a/src/qmmmx_util.F b/src/qmmmx_util.F index 6779e0100a..680cba631d 100644 --- a/src/qmmmx_util.F +++ b/src/qmmmx_util.F @@ -285,9 +285,8 @@ CONTAINS ![NB] need more sophisticated QM extended, buffer rules ! add QM using hysteretic selection (core_list, r_qm) + unbreakable bonds - IF (debug_this_module .AND. output_unit > 0) THEN + IF (debug_this_module .AND. output_unit > 0) & WRITE (output_unit, *) "BOB QM_extended_seed_is_core_list ", QM_extended_seed_is_core_list - END IF IF (QM_extended_seed_is_core_list) THEN QM_extended_seed_min_label_val = force_mixing_label_QM_core_list ELSE ! QM region seed is all of core, not just core list + unbreakable bonds @@ -379,19 +378,17 @@ CONTAINS EXIT END IF END DO - IF (old_index <= 0) THEN + IF (old_index <= 0) & CALL cp_abort(__LOCATION__, & "add_new_label found atom with a label "// & "already set, but not in new_indices array") - END IF new_labels(old_index) = label ELSE n_new = n_new + 1 - IF (n_new > max_n_qm) THEN + IF (n_new > max_n_qm) & CALL cp_abort(__LOCATION__, & "add_new_label tried to add more atoms "// & "than allowed by &FORCE_MIXING&MAX_N_QM!") - END IF IF (n_new > SIZE(new_indices)) CALL reallocate(new_indices, 1, n_new + 9) IF (n_new > SIZE(new_labels)) CALL reallocate(new_labels, 1, n_new + 9) new_indices(n_new) = ip @@ -486,9 +483,8 @@ CONTAINS adaptive_exclude = .FALSE. DO im_exclude = 1, SIZE(adaptive_exclude_molecules) IF (TRIM(molecule_set(im)%molecule_kind%name) == TRIM(adaptive_exclude_molecules(im_exclude)) .OR. & - TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) THEN + TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) & adaptive_exclude = .TRUE. - END IF END DO IF (adaptive_exclude) CYCLE END IF @@ -497,17 +493,15 @@ CONTAINS IF (molec_in_inner) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) THEN + IF (new_full_labels(ip) < set_label_val) & CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) - END IF END DO ELSE IF (molec_in_outer) THEN IF (ANY(orig_full_labels(molecule_set(im)%first_atom:molecule_set(im)%last_atom) >= set_label_val)) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) THEN + IF (new_full_labels(ip) < set_label_val) & CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) - END IF END DO END IF END IF @@ -650,9 +644,8 @@ CONTAINS ! get CUR_INDICES, CUR_LABELS CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels) - IF (SIZE(cur_indices) <= 0) THEN + IF (SIZE(cur_indices) <= 0) & CPABORT("cur_indices is empty, found no QM atoms") - END IF IF (debug_this_module .AND. output_unit > 0) THEN WRITE (output_unit, *) "cur_indices ", cur_indices @@ -672,23 +665,21 @@ CONTAINS EXIT END IF END DO - IF (.NOT. mapped) THEN + IF (.NOT. mapped) & CALL cp_abort(__LOCATION__, & "Force-mixing failed to find QM_KIND mapping for atom of type "// & TRIM(particles(cur_indices(ip))%atomic_kind%element_symbol)// & "! ") - END IF END IF END DO ! pre-existing QM_KIND section specifies list of core atom qm_kind_section => section_vals_get_subs_vals3(qmmm_section, "QM_KIND") CALL section_vals_get(qm_kind_section, n_repetition=i_rep_section_core) - IF (i_rep_section_core <= 0) THEN + IF (i_rep_section_core <= 0) & CALL cp_abort(__LOCATION__, & "Force-mixing QM didn't find any QM_KIND sections, "// & "so no core specified!") - END IF i_rep_section_extended = i_rep_section_core DO ielem = 1, n_elements new_element_core = .TRUE. @@ -809,9 +800,8 @@ CONTAINS n_labels = n_labels + SIZE(labels_entry) END DO - IF (n_indices /= n_labels) THEN + IF (n_indices /= n_labels) & CPABORT("got unequal numbers of force_mixing indices and labels!") - END IF END SUBROUTINE get_force_mixing_indices END MODULE qmmmx_util diff --git a/src/qs_2nd_kernel_ao.F b/src/qs_2nd_kernel_ao.F index dd4e7540c8..882a42af8d 100644 --- a/src/qs_2nd_kernel_ao.F +++ b/src/qs_2nd_kernel_ao.F @@ -301,9 +301,8 @@ CONTAINS CPASSERT(.NOT. dft_control%qs_control%gapw_xc) CPASSERT(.NOT. dft_control%qs_control%lrigpw) CPASSERT(.NOT. linres_control%lr_triplet) - IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) THEN + IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) & CPABORT("kpp1_admm has to be associated if ADMM kernel calculations are requested") - END IF nspins = dft_control%nspins diff --git a/src/qs_active_space_methods.F b/src/qs_active_space_methods.F index 56c589cbd6..a4bcfd1e69 100644 --- a/src/qs_active_space_methods.F +++ b/src/qs_active_space_methods.F @@ -288,23 +288,19 @@ CONTAINS NULLIFY (kpoints) CALL get_qs_env(qs_env, do_kpoints=do_kpoints, dft_control=dft_control, kpoints=kpoints) IF (do_kpoints) THEN - IF (.NOT. ASSOCIATED(kpoints)) THEN + IF (.NOT. ASSOCIATED(kpoints)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - END IF CALL get_kpoint_info(kpoints, kp_scheme=kp_scheme, nkp=nkp, use_real_wfn=use_real_wfn) IF (TRIM(kp_scheme) /= "GAMMA" .OR. nkp /= 1 .OR. .NOT. use_real_wfn) THEN CALL cp_abort(__LOCATION__, & "Only Gamma-point DFT%KPOINTS are supported in the active space module") END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env)) THEN + IF (.NOT. ASSOCIATED(kpoints%kp_env)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) THEN + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) THEN + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point MOs for active space module") - END IF END IF ! adiabatic rescaling? @@ -790,7 +786,7 @@ CONTAINS END IF mo_set_active%eigenvalues(i) = eigenvalues(i, ispin) ! if it was not an active orbital, check whether it is an inactive orbital - ELSE IF (nmo_inactive_remaining > 0) THEN + ELSEIF (nmo_inactive_remaining > 0) THEN CALL cp_fm_to_fm(fm_dummy, fm_target_inactive, 1, i, i) ! store on the fly the mapping of inactive orbitals active_space_env%inactive_orbitals(nmo_inactive - nmo_inactive_remaining + 1, ispin) = i @@ -823,7 +819,7 @@ CONTAINS DO j = 0, jm IF (ANY(active_space_env%active_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [A]" - ELSE IF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN + ELSEIF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [I]" ELSE WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [V]" @@ -1000,7 +996,7 @@ CONTAINS IF (i == 1) THEN n1 = nmo n2 = nmo - ELSE IF (i == 2) THEN + ELSEIF (i == 2) THEN n1 = nmo n2 = nmo ELSE @@ -1455,9 +1451,8 @@ CONTAINS ! Check the input group CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) IF (eri_env%eri_gpw%group_size < 1) eri_env%eri_gpw%group_size = para_env%num_pe - IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) THEN + IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) & CPABORT("Group size must be a divisor of the total number of processes!") - END IF ! Create a new para_env or reuse the old one IF (eri_env%eri_gpw%group_size == para_env%num_pe) THEN eri_env%para_env_sub => para_env @@ -1779,7 +1774,7 @@ CONTAINS ! DEALLOCATE (eri, eri_index) END DO - ELSE IF (eri_env%method == eri_method_full_gpw) THEN + ELSEIF (eri_env%method == eri_method_full_gpw) THEN DO isp2 = isp1, nspins CALL get_mo_set(mo_set=mos(isp2), nmo=nmo2) nx = (nmo2*(nmo2 + 1))/2 @@ -2198,7 +2193,7 @@ CONTAINS CALL section_vals_val_get(input, "STRIDE", i_vals=istride) IF (SIZE(istride) == 1) THEN str(1:3) = istride(1) - ELSE IF (SIZE(istride) == 3) THEN + ELSEIF (SIZE(istride) == 3) THEN str(1:3) = istride(1:3) ELSE CPABORT("STRIDE arguments inconsistent") @@ -3141,7 +3136,7 @@ CONTAINS END IF converged = .TRUE. EXIT - ELSE IF (ABS(delta_E) <= eps_iter) THEN + ELSEIF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" @@ -3323,7 +3318,7 @@ CONTAINS converged = .TRUE. EXIT ! check for convergence - ELSE IF (ABS(delta_E) <= eps_iter) THEN + ELSEIF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" diff --git a/src/qs_active_space_mixing.F b/src/qs_active_space_mixing.F index 5813e70d75..b39d14d962 100644 --- a/src/qs_active_space_mixing.F +++ b/src/qs_active_space_mixing.F @@ -256,7 +256,8 @@ CONTAINS active_space_env%as_mix_x_buffer(ib, :) = p_old active_space_env%as_mix_r_buffer(ib, :) = p_solver - p_old - res_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) + res_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & + active_space_env%as_mix_r_buffer(ib, :))) IF (nb == 1 .OR. res_norm < 1.E-14_dp) THEN CALL active_space_direct_mix(p_old, p_solver, mixing_store%alpha, p_mixed) @@ -336,7 +337,7 @@ CONTAINS ALLOCATE (p_res(ndim)) p_res(:) = p_solver(:) - p_old(:) - res_norm = NORM2(p_res) + res_norm = SQRT(DOT_PRODUCT(p_res, p_res)) mixing_store%ncall = mixing_store%ncall + 1 IF (mixing_store%ncall == 1) THEN @@ -357,7 +358,8 @@ CONTAINS active_space_env%as_mix_r_buffer(ib, :) = p_res - active_space_env%as_mix_r_old active_space_env%as_mix_x_buffer(ib, :) = p_old - active_space_env%as_mix_x_old - delta_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) + delta_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & + active_space_env%as_mix_r_buffer(ib, :))) can_update = res_norm > 1.E-14_dp .AND. delta_norm > 1.E-14_dp IF (can_update) THEN diff --git a/src/qs_active_space_types.F b/src/qs_active_space_types.F index c470db2ec7..8042e71158 100644 --- a/src/qs_active_space_types.F +++ b/src/qs_active_space_types.F @@ -237,9 +237,8 @@ CONTAINS DEALLOCATE (active_space_env%as_mix_x_buffer) END IF - IF (ASSOCIATED(active_space_env%pmat_inactive)) THEN + IF (ASSOCIATED(active_space_env%pmat_inactive)) & CALL dbcsr_deallocate_matrix_set(active_space_env%pmat_inactive) - END IF DEALLOCATE (active_space_env) END IF @@ -381,9 +380,8 @@ CONTAINS ! 1) Collect the amount of local data from each process nonzero_elements_local = 0 - IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) THEN + IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) & nonzero_elements_local = eri%nzerow_local(i12l) - END IF CALL mp_group%allgather(nonzero_elements_local, nonzero_elements_global) ! 2) Prepare arrays for communication (calculate the offsets and the total number of elements) diff --git a/src/qs_cdft_methods.F b/src/qs_cdft_methods.F index 950b77b4f7..03f8f75cdd 100644 --- a/src/qs_cdft_methods.F +++ b/src/qs_cdft_methods.F @@ -181,9 +181,8 @@ CONTAINS becke_control => cdft_control%becke_control group => cdft_control%group cutoffs => becke_control%cutoffs - IF (cdft_control%atomic_charges) THEN + IF (cdft_control%atomic_charges) & charge => cdft_control%charge - END IF in_memory = .FALSE. IF (cdft_control%save_pot) THEN in_memory = becke_control%in_memory @@ -222,7 +221,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) + becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) END DO END DO @@ -244,9 +243,8 @@ CONTAINS ! A subsequent check (atom_in_group) ensures that the gradients of these dummy atoms are correct IF (cdft_control%save_pot .OR. & becke_control%cavity_confine .OR. & - becke_control%should_skip) THEN + becke_control%should_skip) & is_constraint(catom(i)) = .TRUE. - END IF END DO bo = group(1)%weight%pw_grid%bounds_local dvol = group(1)%weight%pw_grid%dvol @@ -335,7 +333,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(iatom) == 0.0_dp) THEN r = becke_control%vector_buffer%position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%distance_vecs(:, iatom) = dist_vec becke_control%vector_buffer%distances(iatom) = dist1 ELSE @@ -348,7 +346,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -369,7 +367,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(jatom) == 0.0_dp) THEN r1 = becke_control%vector_buffer%position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%distance_vecs(:, jatom) = dist_vec becke_control%vector_buffer%distances(jatom) = dist2 ELSE @@ -382,7 +380,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (in_memory) THEN IF (becke_control%vector_buffer%store_vectors) THEN @@ -564,9 +562,8 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) THEN + IF (ALLOCATED(is_constraint)) & DEALLOCATE (is_constraint) - END IF DEALLOCATE (catom) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) @@ -1189,9 +1186,8 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & CPABORT("Becke control has not been allocated.") - END IF group => cdft_control%group ! Initialize nvar = SIZE(cdft_control%target) @@ -1232,10 +1228,9 @@ CONTAINS IF (is_becke .AND. (cdft_control%external_control .AND. becke_control%cavity_confine)) THEN ! With external control, we can use cavity_mat as a mask to kahan sum eps_cavity = becke_control%eps_cavity - IF (igroup /= 1) THEN + IF (igroup /= 1) & CALL cp_abort(__LOCATION__, & "Multiple constraints not yet supported by parallel mixed calculations.") - END IF dE(igroup) = dE(igroup) + sign*accurate_dot_product(group(igroup)%weight%array, rho_r(i)%array, & becke_control%cavity_mat, eps_cavity)*dvol ELSE @@ -1259,10 +1254,9 @@ CONTAINS END IF IF (dft_control%qs_control%gapw) THEN ! GAPW: add core charges (rho_hard - rho_soft) - IF (cdft_control%fragment_density) THEN + IF (cdft_control%fragment_density) & CALL cp_abort(__LOCATION__, & "Fragment constraints not yet compatible with GAPW.") - END IF ALLOCATE (gapw_offset(nvar, dft_control%nspins)) gapw_offset = 0.0_dp CALL get_qs_env(qs_env, rho0_mpole=rho0_mpole) @@ -1628,21 +1622,18 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & CPABORT("Becke control has not been allocated.") - END IF group => cdft_control%group dvol = group(1)%weight%pw_grid%dvol ! Fragment densities are meaningful only for some calculation types - IF (.NOT. qs_env%single_point_run) THEN + IF (.NOT. qs_env%single_point_run) & CALL cp_abort(__LOCATION__, & "CDFT fragment constraints are only compatible with single "// & "point calculations (run_type ENERGY or ENERGY_FORCE).") - END IF - IF (dft_control%qs_control%gapw) THEN + IF (dft_control%qs_control%gapw) & CALL cp_abort(__LOCATION__, & "CDFT fragment constraint not compatible with GAPW.") - END IF needs_spin_density = .FALSE. multiplier = 1.0_dp nfrag_spins = 1 @@ -1700,11 +1691,10 @@ CONTAINS CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, nelectron_total=nelectron_total) nelectron_frag = pw_integrate_function(rho_frag(1)) - IF (NINT(nelectron_frag) /= nelectron_total) THEN + IF (NINT(nelectron_frag) /= nelectron_total) & CALL cp_abort(__LOCATION__, & "The number of electrons in the reference and interacting "// & "configurations does not match. Check your fragment cube files.") - END IF ! Update constraint target value i.e. perform integration w_i*rho_frag_{tot/spin}*dr cdft_control%target = 0.0_dp DO igroup = 1, SIZE(group) diff --git a/src/qs_cdft_opt_types.F b/src/qs_cdft_opt_types.F index 4a3ed616c6..92cb004adb 100644 --- a/src/qs_cdft_opt_types.F +++ b/src/qs_cdft_opt_types.F @@ -135,12 +135,10 @@ CONTAINS TYPE(cdft_opt_type), POINTER :: cdft_opt_control IF (ASSOCIATED(cdft_opt_control)) THEN - IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) THEN + IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) & DEALLOCATE (cdft_opt_control%jacobian_vector) - END IF - IF (ALLOCATED(cdft_opt_control%jacobian_step)) THEN + IF (ALLOCATED(cdft_opt_control%jacobian_step)) & DEALLOCATE (cdft_opt_control%jacobian_step) - END IF DEALLOCATE (cdft_opt_control) END IF @@ -190,26 +188,22 @@ CONTAINS CALL section_vals_val_get(cdft_opt_section, "FACTOR_LS", & r_val=cdft_opt_control%factor_ls) IF (cdft_opt_control%factor_ls <= 0.0_dp .OR. & - cdft_opt_control%factor_ls >= 1.0_dp) THEN + cdft_opt_control%factor_ls >= 1.0_dp) & CALL cp_abort(__LOCATION__, & "Keyword FACTOR_LS must be between 0.0 and 1.0.") - END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", explicit=exists) IF (exists) THEN CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", & i_vals=tmplist) - IF (SIZE(tmplist) /= 2) THEN + IF (SIZE(tmplist) /= 2) & CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes exactly two input values.") - END IF - IF (ANY(tmplist < 0)) THEN + IF (ANY(tmplist < 0)) & CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes only positive values.") - END IF - IF (ALL(tmplist == 0)) THEN + IF (ALL(tmplist == 0)) & CALL cp_abort(__LOCATION__, & "Both values to keyword JACOBIAN_FREQ cannot be zero.") - END IF cdft_opt_control%jacobian_freq(:) = tmplist(1:2) END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_RESTART", & @@ -281,10 +275,9 @@ CONTAINS IF (cdft_opt_control%jacobian_freq(2) > 0) THEN WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(2), " energy evaluation" - IF (cdft_opt_control%jacobian_freq(1) > 0) THEN + IF (cdft_opt_control%jacobian_freq(1) > 0) & WRITE (output_unit, '(T29,A,I4,A)') & - "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" - END IF + "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" ELSE WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" diff --git a/src/qs_cdft_scf_utils.F b/src/qs_cdft_scf_utils.F index c7b6bf59a1..f70237f2de 100644 --- a/src/qs_cdft_scf_utils.F +++ b/src/qs_cdft_scf_utils.F @@ -80,12 +80,11 @@ CONTAINS dft_control=dft_control) IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= 1 .AND. & - SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) THEN + SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) & CALL cp_abort(__LOCATION__, & cp_to_string(SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step))// & " values passed to keyword JACOBIAN_STEP, expected 1 or "// & cp_to_string(SIZE(scf_env%outer_scf%variables, 1))) - END IF ALLOCATE (dh(SIZE(scf_env%outer_scf%variables, 1))) IF (SIZE(dh) /= SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step)) THEN @@ -230,9 +229,8 @@ CONTAINS use_md_history = .TRUE. ! Check that none of the history values are identical in which case we should try something different DO i = 1, nvar - IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) THEN + IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) & use_md_history = .FALSE. - END IF END DO IF (use_md_history) THEN ALLOCATE (jacobian(nvar, nvar)) @@ -240,9 +238,8 @@ CONTAINS jacobian(i, i) = (gradient_history(i, 2) - gradient_history(i, 1))/ & (variable_history(i, 2) - variable_history(i, 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -256,19 +253,17 @@ CONTAINS IF (ihistory >= 2 .AND. .NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ! Next, try history from current SCF procedure nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF must be greater than or equal "// & "to 3 for optimizers that build the Jacobian from SCF history.") - END IF ALLOCATE (jacobian(nvar, nvar)) DO i = 1, nvar jacobian(i, i) = (scf_env%outer_scf%gradient(i, ihistory) - scf_env%outer_scf%gradient(i, ihistory - 1))/ & (scf_env%outer_scf%variables(i, ihistory) - scf_env%outer_scf%variables(i, ihistory - 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -299,13 +294,11 @@ CONTAINS CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control%jacobian_vector)) nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) THEN + IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) & CALL cp_abort(__LOCATION__, & "Too many or too few values defined for restarting inverse Jacobian.") - END IF - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian iwork = 1 DO i = 1, nvar diff --git a/src/qs_cdft_types.F b/src/qs_cdft_types.F index 3841d78f60..74672844ab 100644 --- a/src/qs_cdft_types.F +++ b/src/qs_cdft_types.F @@ -315,43 +315,31 @@ CONTAINS TYPE(becke_constraint_type), INTENT(INOUT) :: becke_control IF (becke_control%vector_buffer%store_vectors) THEN - IF (ALLOCATED(becke_control%vector_buffer%distances)) THEN + IF (ALLOCATED(becke_control%vector_buffer%distances)) & DEALLOCATE (becke_control%vector_buffer%distances) - END IF - IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) THEN + IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) & DEALLOCATE (becke_control%vector_buffer%distance_vecs) - END IF - IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) THEN + IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) & DEALLOCATE (becke_control%vector_buffer%position_vecs) - END IF - IF (ALLOCATED(becke_control%vector_buffer%R12)) THEN + IF (ALLOCATED(becke_control%vector_buffer%R12)) & DEALLOCATE (becke_control%vector_buffer%R12) - END IF - IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) THEN + IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) & DEALLOCATE (becke_control%vector_buffer%pair_dist_vecs) - END IF END IF - IF (ASSOCIATED(becke_control%cutoffs)) THEN + IF (ASSOCIATED(becke_control%cutoffs)) & DEALLOCATE (becke_control%cutoffs) - END IF - IF (ASSOCIATED(becke_control%cutoffs_tmp)) THEN + IF (ASSOCIATED(becke_control%cutoffs_tmp)) & DEALLOCATE (becke_control%cutoffs_tmp) - END IF - IF (ASSOCIATED(becke_control%radii_tmp)) THEN + IF (ASSOCIATED(becke_control%radii_tmp)) & DEALLOCATE (becke_control%radii_tmp) - END IF - IF (ASSOCIATED(becke_control%radii)) THEN + IF (ASSOCIATED(becke_control%radii)) & DEALLOCATE (becke_control%radii) - END IF - IF (ASSOCIATED(becke_control%aij)) THEN + IF (ASSOCIATED(becke_control%aij)) & DEALLOCATE (becke_control%aij) - END IF - IF (ASSOCIATED(becke_control%cavity_mat)) THEN + IF (ASSOCIATED(becke_control%cavity_mat)) & DEALLOCATE (becke_control%cavity_mat) - END IF - IF (becke_control%cavity_confine) THEN + IF (becke_control%cavity_confine) & CALL release_hirshfeld_type(becke_control%cavity_env) - END IF END SUBROUTINE becke_control_release @@ -447,60 +435,44 @@ CONTAINS INTEGER :: i ! Constraint settings - IF (ASSOCIATED(cdft_control%atoms)) THEN + IF (ASSOCIATED(cdft_control%atoms)) & DEALLOCATE (cdft_control%atoms) - END IF - IF (ASSOCIATED(cdft_control%strength)) THEN + IF (ASSOCIATED(cdft_control%strength)) & DEALLOCATE (cdft_control%strength) - END IF - IF (ASSOCIATED(cdft_control%target)) THEN + IF (ASSOCIATED(cdft_control%target)) & DEALLOCATE (cdft_control%target) - END IF - IF (ASSOCIATED(cdft_control%value)) THEN + IF (ASSOCIATED(cdft_control%value)) & DEALLOCATE (cdft_control%value) - END IF - IF (ASSOCIATED(cdft_control%charges_fragment)) THEN + IF (ASSOCIATED(cdft_control%charges_fragment)) & DEALLOCATE (cdft_control%charges_fragment) - END IF - IF (ASSOCIATED(cdft_control%fragments)) THEN + IF (ASSOCIATED(cdft_control%fragments)) & DEALLOCATE (cdft_control%fragments) - END IF - IF (ASSOCIATED(cdft_control%is_constraint)) THEN + IF (ASSOCIATED(cdft_control%is_constraint)) & DEALLOCATE (cdft_control%is_constraint) - END IF - IF (ASSOCIATED(cdft_control%charge)) THEN + IF (ASSOCIATED(cdft_control%charge)) & DEALLOCATE (cdft_control%charge) - END IF ! Constraint atom groups IF (ASSOCIATED(cdft_control%group)) THEN DO i = 1, SIZE(cdft_control%group) - IF (ASSOCIATED(cdft_control%group(i)%atoms)) THEN + IF (ASSOCIATED(cdft_control%group(i)%atoms)) & DEALLOCATE (cdft_control%group(i)%atoms) - END IF - IF (ASSOCIATED(cdft_control%group(i)%coeff)) THEN + IF (ASSOCIATED(cdft_control%group(i)%coeff)) & DEALLOCATE (cdft_control%group(i)%coeff) - END IF - IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) THEN + IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) & DEALLOCATE (cdft_control%group(i)%d_sum_const_dR) - END IF IF (cdft_control%type == outer_scf_becke_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients)) & DEALLOCATE (cdft_control%group(i)%gradients) - END IF ELSE IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) & DEALLOCATE (cdft_control%group(i)%gradients_x) - END IF - IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) & DEALLOCATE (cdft_control%group(i)%gradients_y) - END IF - IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) & DEALLOCATE (cdft_control%group(i)%gradients_z) - END IF END IF - IF (ASSOCIATED(cdft_control%group(i)%integrated)) THEN + IF (ASSOCIATED(cdft_control%group(i)%integrated)) & DEALLOCATE (cdft_control%group(i)%integrated) - END IF END DO DEALLOCATE (cdft_control%group) END IF @@ -516,27 +488,21 @@ CONTAINS ! Release OUTER_SCF types CALL cdft_opt_type_release(cdft_control%ot_control%cdft_opt_control) CALL cdft_opt_type_release(cdft_control%constraint_control%cdft_opt_control) - IF (ASSOCIATED(cdft_control%constraint%variables)) THEN + IF (ASSOCIATED(cdft_control%constraint%variables)) & DEALLOCATE (cdft_control%constraint%variables) - END IF - IF (ASSOCIATED(cdft_control%constraint%count)) THEN + IF (ASSOCIATED(cdft_control%constraint%count)) & DEALLOCATE (cdft_control%constraint%count) - END IF - IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN + IF (ASSOCIATED(cdft_control%constraint%gradient)) & DEALLOCATE (cdft_control%constraint%gradient) - END IF - IF (ASSOCIATED(cdft_control%constraint%energy)) THEN + IF (ASSOCIATED(cdft_control%constraint%energy)) & DEALLOCATE (cdft_control%constraint%energy) - END IF - IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN + IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) & DEALLOCATE (cdft_control%constraint%inv_jacobian) - END IF ! Storage for mixed CDFT calculations IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations) - IF (ASSOCIATED(cdft_control%occupations(i)%array)) THEN + IF (ASSOCIATED(cdft_control%occupations(i)%array)) & DEALLOCATE (cdft_control%occupations(i)%array) - END IF END DO DEALLOCATE (cdft_control%occupations) END IF @@ -577,9 +543,8 @@ CONTAINS SUBROUTINE hirshfeld_control_release(hirshfeld_control) TYPE(hirshfeld_constraint_type), INTENT(INOUT) :: hirshfeld_control - IF (ASSOCIATED(hirshfeld_control%radii)) THEN + IF (ASSOCIATED(hirshfeld_control%radii)) & DEALLOCATE (hirshfeld_control%radii) - END IF CALL release_hirshfeld_type(hirshfeld_control%hirshfeld_env) END SUBROUTINE hirshfeld_control_release diff --git a/src/qs_cdft_utils.F b/src/qs_cdft_utils.F index a5d0de5020..c82c9cddc3 100644 --- a/src/qs_cdft_utils.F +++ b/src/qs_cdft_utils.F @@ -163,11 +163,10 @@ CONTAINS IF (becke_control%adjust) THEN IF (.NOT. ASSOCIATED(becke_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) & CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF ALLOCATE (becke_control%radii(SIZE(atomic_kind_set))) becke_control%radii(:) = becke_control%radii_tmp(:) DEALLOCATE (becke_control%radii_tmp) @@ -181,11 +180,10 @@ CONTAINS CASE (becke_cutoff_global) becke_control%cutoffs(:) = becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) & CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does not "// & "match number of atomic kinds in the input coordinate file.") - END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -240,7 +238,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) + becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) ! Set up heteronuclear cell partitioning using user defined radii IF (build) THEN @@ -331,9 +329,8 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) THEN + IF (ASSOCIATED(radii_list)) & DEALLOCATE (radii_list) - END IF END IF ! Form cavity by summing isolated Gaussian densities over constraint atoms NULLIFY (rs_cavity) @@ -428,10 +425,9 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (para_env%is_source() .AND. unit_nr < 1) THEN + IF (para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") - END IF CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, particles=particles) CALL cp_pw_to_cube(becke_control%cavity, unit_nr, "CAVITY", particles=particles, stride=stride, mpi_io=mpi_io) @@ -439,9 +435,8 @@ CONTAINS DEALLOCATE (stride) END IF END IF - IF (ALLOCATED(is_constraint)) THEN + IF (ALLOCATED(is_constraint)) & DEALLOCATE (is_constraint) - END IF CALL timestop(handle) END SUBROUTINE becke_constraint_init @@ -502,10 +497,9 @@ CONTAINS CALL section_vals_val_get(becke_section, "IN_MEMORY", l_val=becke_control%in_memory) IF (cdft_control%becke_control%cavity_confine) THEN CALL section_vals_val_get(becke_section, "CAVITY_SHAPE", i_val=becke_control%cavity_shape) - IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) THEN + IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) & CALL cp_abort(__LOCATION__, & "Activate keyword ADJUST_SIZE to use cavity shape USER.") - END IF CALL section_vals_val_get(becke_section, "CAVITY_RADIUS", r_val=becke_control%rcavity) CALL section_vals_val_get(becke_section, "EPS_CAVITY", r_val=becke_control%eps_cavity) CALL section_vals_val_get(becke_section, "CAVITY_PRINT", l_val=becke_control%print_cavity) @@ -556,9 +550,8 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) THEN + IF (SIZE(tmplist) < 1) & CPABORT("Each ATOM_GROUP must contain at least 1 atom.") - END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (cdft_control%group(k)%atoms(natoms)) @@ -625,9 +618,8 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) THEN + IF (SIZE(tmplist) < 1) & CPABORT("DUMMY_ATOMS must contain at least 1 atom.") - END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (dummylist(natoms)) @@ -643,18 +635,16 @@ CONTAINS ! Check for duplicates DO j = 1, natoms DO i = j + 1, natoms - IF (dummylist(i) == dummylist(j)) THEN + IF (dummylist(i) == dummylist(j)) & CPABORT("Duplicate atoms defined in section DUMMY_ATOMS.") - END IF END DO END DO ! Check that a dummy atom is not included in any ATOM_GROUP DO j = 1, SIZE(atomlist) DO i = 1, SIZE(dummylist) - IF (dummylist(i) == atomlist(j)) THEN + IF (dummylist(i) == atomlist(j)) & CALL cp_abort(__LOCATION__, & "Duplicate atoms defined in sections ATOM_GROUP and DUMMY_ATOMS.") - END IF END DO END DO END IF @@ -681,24 +671,22 @@ CONTAINS ALLOCATE (cdft_control%value(nvar)) ALLOCATE (cdft_control%target(nvar)) CALL section_vals_val_get(cdft_control_section, "STRENGTH", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) THEN + IF (SIZE(rtmplist) /= nvar) & CALL cp_abort(__LOCATION__, & "The length of keyword STRENGTH is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") - END IF DO j = 1, nvar cdft_control%strength(j) = rtmplist(j) END DO CALL section_vals_val_get(cdft_control_section, "TARGET", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) THEN + IF (SIZE(rtmplist) /= nvar) & CALL cp_abort(__LOCATION__, & "The length of keyword TARGET is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") - END IF DO j = 1, nvar cdft_control%target(j) = rtmplist(j) END DO @@ -768,9 +756,8 @@ CONTAINS outer_scf_section => section_vals_get_subs_vals(cdft_control_section, "OUTER_SCF") CALL outer_scf_read_parameters(cdft_control%constraint_control, outer_scf_section) IF (cdft_control%constraint_control%have_scf) THEN - IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) THEN + IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) & CPABORT("Unsupported CDFT constraint.") - END IF ! Constraint definitions CALL read_constraint_definitions(cdft_control, cdft_control_section) ! Constraint-specific initializations @@ -1027,11 +1014,10 @@ CONTAINS nkind = SIZE(qs_kind_set) ! Parse atomic radii for setting up Gaussian shape function IF (ASSOCIATED(hirshfeld_control%radii)) THEN - IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) & CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF ALLOCATE (radii_list(SIZE(hirshfeld_control%radii))) DO ikind = 1, SIZE(hirshfeld_control%radii) @@ -1144,9 +1130,8 @@ CONTAINS CALL qs_scf_cdft_constraint_info(iw, cdft_control) ! Print weight function(s) to cube file(s) whenever weight is (re)built - IF (cdft_control%print_weight .AND. cdft_control%need_pot) THEN + IF (cdft_control%print_weight .AND. cdft_control%need_pot) & CALL cdft_print_weight_function(qs_env) - END IF ! Print atomic CDFT charges IF (iw > 0 .AND. cdft_control%atomic_charges) THEN @@ -1305,10 +1290,9 @@ CONTAINS extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) ! Note PROGRAM_RUN_INFO section neeeds to be active! - IF (para_env%is_source() .AND. unit_nr < 1) THEN + IF (para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print CDFT weight function.") - END IF CALL cp_pw_to_cube(cdft_control%group(igroup)%weight, & unit_nr, & diff --git a/src/qs_charge_mixing.F b/src/qs_charge_mixing.F index 7682698cfc..d4981f4b0a 100644 --- a/src/qs_charge_mixing.F +++ b/src/qs_charge_mixing.F @@ -117,9 +117,8 @@ CONTAINS mixer_max_weight = tblite_mixer_max_weight_default IF (PRESENT(tblite_mixer_max_weight)) mixer_max_weight = tblite_mixer_max_weight IF (mixer_max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (mixer_max_weight < mixer_min_weight) THEN + IF (mixer_max_weight < mixer_min_weight) & CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") - END IF mixer_weight_factor = tblite_mixer_weight_factor_default IF (PRESENT(tblite_mixer_weight_factor)) mixer_weight_factor = tblite_mixer_weight_factor IF (mixer_weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") @@ -184,21 +183,21 @@ CONTAINS IF ((iter_count == 1) .OR. (iter_count + 1 <= mixing_store%nskip_mixing)) THEN ! skip mixing mixing_store%iter_method = "NoMix" - ELSE IF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN + ELSEIF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN CALL mix_charges_only(mixing_store, charges, alpha, imin, ns, para_env) mixing_store%iter_method = "Mixing" - ELSE IF (mixing_method == gspace_mixing_nr) THEN + ELSEIF (mixing_method == gspace_mixing_nr) THEN CPABORT("Kerker method not available for Charge Mixing") - ELSE IF (mixing_method == pulay_mixing_nr) THEN + ELSEIF (mixing_method == pulay_mixing_nr) THEN CPABORT("Pulay method not available for Charge Mixing") - ELSE IF (mixing_method == broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr) THEN CALL broyden_mixing(mixing_store, charges, imin, nvec, ns, para_env) mixing_store%iter_method = "Broy." - ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN + ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN CPABORT("Modified Broyden mixing is only available for DFT density mixing") - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN CPABORT("Multisecant_mixing method not available for Charge Mixing") - ELSE IF (mixing_method == new_pulay_mixing_nr) THEN + ELSEIF (mixing_method == new_pulay_mixing_nr) THEN CPABORT("New Pulay method not available for Charge Mixing") END IF diff --git a/src/qs_chargemol.F b/src/qs_chargemol.F index e26a09e4fb..32f7c50516 100644 --- a/src/qs_chargemol.F +++ b/src/qs_chargemol.F @@ -604,7 +604,7 @@ CONTAINS DO imo = 1, mos(1)%homo IF (nspins == 1) THEN WRITE (iwfx, '(A15)') "Alpha and Beta" - ELSE IF (dft_control%uks) THEN + ELSEIF (dft_control%uks) THEN WRITE (iwfx, '(A6)') "Alpha" ELSE CALL cp_abort(__LOCATION__, "This wavefunction type is currently"// & diff --git a/src/qs_charges_types.F b/src/qs_charges_types.F index b72dd7d539..7771cd0745 100644 --- a/src/qs_charges_types.F +++ b/src/qs_charges_types.F @@ -73,13 +73,11 @@ CONTAINS REAL(KIND=dp), INTENT(in), OPTIONAL :: total_rho_core_rspace, total_rho_gspace qs_charges%total_rho_core_rspace = 0.0_dp - IF (PRESENT(total_rho_core_rspace)) THEN + IF (PRESENT(total_rho_core_rspace)) & qs_charges%total_rho_core_rspace = total_rho_core_rspace - END IF qs_charges%total_rho_gspace = 0.0_dp - IF (PRESENT(total_rho_gspace)) THEN + IF (PRESENT(total_rho_gspace)) & qs_charges%total_rho_gspace = total_rho_gspace - END IF qs_charges%total_rho_soft_gspace = 0.0_dp qs_charges%total_rho0_hard_lebedev = 0.0_dp qs_charges%total_rho_soft_gspace = 0.0_dp diff --git a/src/qs_cneo_methods.F b/src/qs_cneo_methods.F index 3485e11369..43081fa9b5 100644 --- a/src/qs_cneo_methods.F +++ b/src/qs_cneo_methods.F @@ -185,10 +185,9 @@ CONTAINS CALL get_gto_basis_set(nuc_soft_basis, npgf=npgf_s, gcc=gcc_s) ! There is such a limitation because we rely on atomic code to build S, T and U. ! Usually l=5 is more than enough, suppoting PB6H basis. - IF (maxl > lmat) THEN + IF (maxl > lmat) & CALL cp_abort(__LOCATION__, "Nuclear basis with angular momentum higher than "// & "atom_types::lmat is not supported yet.") - END IF set_index = 0 shell_index = 0 @@ -1075,7 +1074,7 @@ CONTAINS ! initial guess of f is taken from the result of last iteration CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) ! test if zero initial guess is better - IF (NORM2(r) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN + IF (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN CALL atom_solve_cneo(fmat, [0.0_dp, 0.0_dp, 0.0_dp], utrans, wfn, & ener, pmat, r_tmp, distance, nsgf, nne) IF (DOT_PRODUCT(r_tmp, r_tmp) < DOT_PRODUCT(r, r)) THEN @@ -1086,7 +1085,7 @@ CONTAINS max_iter = 20 iter = 0 ! using Newton's method to solve for f - DO WHILE (NORM2(r) > 1.e-12_dp) + DO WHILE (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp) iter = iter + 1 ! construct numerical Jacobian with one-side finite difference DO i = 1, 3 @@ -1119,13 +1118,13 @@ CONTAINS CALL invert_matrix_3x3(jac, jac_inv, det, try_svd=.TRUE.) END IF df = -RESHAPE(MATMUL(jac_inv, RESHAPE(r, [3, 1])), [3]) - df_norm = NORM2(df) + df_norm = SQRT(DOT_PRODUCT(df, df)) f_tmp = f r_tmp = r - g0 = NORM2(r_tmp) + g0 = SQRT(DOT_PRODUCT(r_tmp, r_tmp)) f = f_tmp + df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = NORM2(r) + g1 = SQRT(DOT_PRODUCT(r, r)) step = 1.0_dp DO WHILE (g1 >= g0) ! line search @@ -1137,7 +1136,7 @@ CONTAINS step = step*MAX(-g0p/(2.0_dp*(g1 - g0 - g0p)), 0.1_dp) f = f_tmp + step*df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = NORM2(r) + g1 = SQRT(DOT_PRODUCT(r, r)) END DO IF (iter >= max_iter) THEN CALL cp_warn(__LOCATION__, "CNEO nuclear position constraint solver failed to "// & diff --git a/src/qs_cneo_types.F b/src/qs_cneo_types.F index f5661286f4..40dd2fb323 100644 --- a/src/qs_cneo_types.F +++ b/src/qs_cneo_types.F @@ -121,45 +121,32 @@ CONTAINS TYPE(rhoz_cneo_type), POINTER :: rhoz_cneo IF (ASSOCIATED(rhoz_cneo)) THEN - IF (ASSOCIATED(rhoz_cneo%pmat)) THEN + IF (ASSOCIATED(rhoz_cneo%pmat)) & DEALLOCATE (rhoz_cneo%pmat) - END IF - IF (ASSOCIATED(rhoz_cneo%core)) THEN + IF (ASSOCIATED(rhoz_cneo%core)) & DEALLOCATE (rhoz_cneo%core) - END IF - IF (ASSOCIATED(rhoz_cneo%vmat)) THEN + IF (ASSOCIATED(rhoz_cneo%vmat)) & DEALLOCATE (rhoz_cneo%vmat) - END IF - IF (ASSOCIATED(rhoz_cneo%fmat)) THEN + IF (ASSOCIATED(rhoz_cneo%fmat)) & DEALLOCATE (rhoz_cneo%fmat) - END IF - IF (ASSOCIATED(rhoz_cneo%wfn)) THEN + IF (ASSOCIATED(rhoz_cneo%wfn)) & DEALLOCATE (rhoz_cneo%wfn) - END IF - IF (ASSOCIATED(rhoz_cneo%cpc_h)) THEN + IF (ASSOCIATED(rhoz_cneo%cpc_h)) & DEALLOCATE (rhoz_cneo%cpc_h) - END IF - IF (ASSOCIATED(rhoz_cneo%cpc_s)) THEN + IF (ASSOCIATED(rhoz_cneo%cpc_s)) & DEALLOCATE (rhoz_cneo%cpc_s) - END IF - IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) THEN + IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) & DEALLOCATE (rhoz_cneo%rho_rad_h) - END IF - IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) THEN + IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) & DEALLOCATE (rhoz_cneo%rho_rad_s) - END IF - IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) THEN + IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) & DEALLOCATE (rhoz_cneo%vrho_rad_h) - END IF - IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) THEN + IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) & DEALLOCATE (rhoz_cneo%vrho_rad_s) - END IF - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) THEN + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) & DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_h) - END IF - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) THEN + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) & DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_s) - END IF END IF END SUBROUTINE deallocate_rhoz_cneo @@ -194,9 +181,8 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential - IF (ASSOCIATED(potential)) THEN + IF (ASSOCIATED(potential)) & CALL deallocate_cneo_potential(potential) - END IF ALLOCATE (potential) @@ -211,51 +197,36 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential IF (ASSOCIATED(potential)) THEN - IF (ASSOCIATED(potential%elec_conf)) THEN + IF (ASSOCIATED(potential%elec_conf)) & DEALLOCATE (potential%elec_conf) - END IF - IF (ASSOCIATED(potential%my_gcc_h)) THEN + IF (ASSOCIATED(potential%my_gcc_h)) & DEALLOCATE (potential%my_gcc_h) - END IF - IF (ASSOCIATED(potential%my_gcc_s)) THEN + IF (ASSOCIATED(potential%my_gcc_s)) & DEALLOCATE (potential%my_gcc_s) - END IF - IF (ASSOCIATED(potential%ovlp)) THEN + IF (ASSOCIATED(potential%ovlp)) & DEALLOCATE (potential%ovlp) - END IF - IF (ASSOCIATED(potential%kin)) THEN + IF (ASSOCIATED(potential%kin)) & DEALLOCATE (potential%kin) - END IF - IF (ASSOCIATED(potential%utrans)) THEN + IF (ASSOCIATED(potential%utrans)) & DEALLOCATE (potential%utrans) - END IF - IF (ASSOCIATED(potential%distance)) THEN + IF (ASSOCIATED(potential%distance)) & DEALLOCATE (potential%distance) - END IF - IF (ASSOCIATED(potential%harmonics)) THEN + IF (ASSOCIATED(potential%harmonics)) & CALL deallocate_harmonics_atom(potential%harmonics) - END IF - IF (ASSOCIATED(potential%Qlm_gg)) THEN + IF (ASSOCIATED(potential%Qlm_gg)) & DEALLOCATE (potential%Qlm_gg) - END IF - IF (ASSOCIATED(potential%gg)) THEN + IF (ASSOCIATED(potential%gg)) & DEALLOCATE (potential%gg) - END IF - IF (ASSOCIATED(potential%vgg)) THEN + IF (ASSOCIATED(potential%vgg)) & DEALLOCATE (potential%vgg) - END IF - IF (ASSOCIATED(potential%n2oindex)) THEN + IF (ASSOCIATED(potential%n2oindex)) & DEALLOCATE (potential%n2oindex) - END IF - IF (ASSOCIATED(potential%o2nindex)) THEN + IF (ASSOCIATED(potential%o2nindex)) & DEALLOCATE (potential%o2nindex) - END IF - IF (ASSOCIATED(potential%rad2l)) THEN + IF (ASSOCIATED(potential%rad2l)) & DEALLOCATE (potential%rad2l) - END IF - IF (ASSOCIATED(potential%oorad2l)) THEN + IF (ASSOCIATED(potential%oorad2l)) & DEALLOCATE (potential%oorad2l) - END IF DEALLOCATE (potential) END IF @@ -385,9 +356,8 @@ CONTAINS IF (PRESENT(z)) THEN potential%z = z potential%zeff = REAL(z, dp) - IF (ASSOCIATED(potential%elec_conf)) THEN + IF (ASSOCIATED(potential%elec_conf)) & CPABORT("elec_conf is already associated") - END IF ALLOCATE (potential%elec_conf(0:3)) potential%elec_conf(0:3) = ptable(z)%e_conv(0:3) CPASSERT(potential%mass == 0.0_dp) diff --git a/src/qs_collocate_density.F b/src/qs_collocate_density.F index c0df7d1eaf..57925e0e86 100644 --- a/src/qs_collocate_density.F +++ b/src/qs_collocate_density.F @@ -1245,10 +1245,9 @@ CONTAINS CALL transfer_rs2pw(rs_rho, rhoc_r) - IF (PRESENT(total_rho_metal)) THEN + IF (PRESENT(total_rho_metal)) & !minus sign: account for the fact that rho_metal has opposite sign total_rho_metal = pw_integrate_function(rhoc_r, isign=-1) - END IF CALL pw_transfer(rhoc_r, rho_metal) CALL auxbas_pw_pool%give_back_pw(rhoc_r) @@ -1570,7 +1569,7 @@ CONTAINS IF (PRESENT(soft_valid)) my_soft_valid = soft_valid IF (PRESENT(task_list_external)) THEN task_list => task_list_external - ELSE IF (my_soft_valid) THEN + ELSEIF (my_soft_valid) THEN CALL get_ks_env(ks_env, task_list_soft=task_list) ELSE CALL get_ks_env(ks_env, task_list=task_list) @@ -2359,48 +2358,44 @@ CONTAINS END SELECT IF (iatom <= jatom) THEN - IF (iatom == lambda) THEN + IF (iatom == lambda) & CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF - IF (jatom == lambda) THEN + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + IF (jatom == lambda) & CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) ELSE rab_inv = -rab - IF (jatom == lambda) THEN + IF (jatom == lambda) & CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF - IF (iatom == lambda) THEN + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + IF (iatom == lambda) & CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) END IF END DO loop_tasks diff --git a/src/qs_core_hamiltonian.F b/src/qs_core_hamiltonian.F index 2ab3d7e09c..ff5dfb464e 100644 --- a/src/qs_core_hamiltonian.F +++ b/src/qs_core_hamiltonian.F @@ -230,10 +230,9 @@ CONTAINS IF (dft_control%tddfpt2_control%enabled) THEN nders = 1 IF (dft_control%do_admm) THEN - IF (dft_control%admm_control%purification_method /= do_admm_purify_none) THEN + IF (dft_control%admm_control%purification_method /= do_admm_purify_none) & CALL cp_abort(__LOCATION__, & "Only purification method NONE is possible with TDDFT at the moment") - END IF END IF END IF @@ -337,10 +336,9 @@ CONTAINS nkind = SIZE(atomic_kind_set) CALL allocate_oce_set(oce, nkind) eps_fit = dft_control%qs_control%gapw_control%eps_fit - IF (ASSOCIATED(sap_oce)) THEN + IF (ASSOCIATED(sap_oce)) & CALL build_oce_matrices(oce%intac, calculate_forces, nder, qs_kind_set, particle_set, & sap_oce, eps_fit) - END IF END IF ! *** KG atomic potentials for nonadditive kinetic energy diff --git a/src/qs_core_matrices.F b/src/qs_core_matrices.F index b57e8fd83c..8ee4e78031 100644 --- a/src/qs_core_matrices.F +++ b/src/qs_core_matrices.F @@ -567,7 +567,7 @@ CONTAINS END IF IF (PRESENT(matrixkp_t)) THEN CALL build_atomic_relmat(matrixkp_t(1, ic)%matrix, atomic_kind_set, qs_kind_set) - ELSE IF (PRESENT(matrix_t)) THEN + ELSEIF (PRESENT(matrix_t)) THEN CALL build_atomic_relmat(matrix_t(1)%matrix, atomic_kind_set, qs_kind_set) END IF ELSE diff --git a/src/qs_dcdr_utils.F b/src/qs_dcdr_utils.F index 9c83bf24e0..9de800d1c3 100644 --- a/src/qs_dcdr_utils.F +++ b/src/qs_dcdr_utils.F @@ -778,9 +778,8 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(dcdr_section, "REFERENCE_POINT", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) THEN + IF (reference == use_mom_ref_user) & CPABORT("User-defined reference point should be given explicitly") - END IF END IF CALL get_reference_point(rpoint=dcdr_env%ref_point, qs_env=qs_env, & diff --git a/src/qs_dftb_parameters.F b/src/qs_dftb_parameters.F index 60d7083667..35c95324c7 100644 --- a/src/qs_dftb_parameters.F +++ b/src/qs_dftb_parameters.F @@ -204,11 +204,10 @@ CONTAINS CALL parser_release(parser) END BLOCK END IF - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "Failure in assigning KINDS <"//TRIM(iname)//"> and <"//TRIM(jname)// & "> to a DFTB interaction pair!") - END IF END DO END DO ! reading the files diff --git a/src/qs_dftb_utils.F b/src/qs_dftb_utils.F index 43440135a1..79a4972d93 100644 --- a/src/qs_dftb_utils.F +++ b/src/qs_dftb_utils.F @@ -62,9 +62,8 @@ CONTAINS TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - IF (ASSOCIATED(dftb_parameter)) THEN + IF (ASSOCIATED(dftb_parameter)) & CALL deallocate_dftb_atom_param(dftb_parameter) - END IF ALLOCATE (dftb_parameter) diff --git a/src/qs_diis.F b/src/qs_diis.F index cbc8b1596b..5b89b5f419 100644 --- a/src/qs_diis.F +++ b/src/qs_diis.F @@ -571,9 +571,6 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env CALL timeset(routineN, handle) - IF (ls_scf_env%do_pao) THEN - CPABORT("LS_SCF%LS_DIIS not compatible with PAO") - END IF nspin = ls_scf_env%nspins diis_step = .FALSE. my_nmixing = 2 diff --git a/src/qs_dispersion_cnum.F b/src/qs_dispersion_cnum.F index 2632a12933..9d5d96d71a 100644 --- a/src/qs_dispersion_cnum.F +++ b/src/qs_dispersion_cnum.F @@ -1261,9 +1261,9 @@ CONTAINS rcut = rcut + 0.1_dp IF (cnfun == 1) THEN CALL cnparam_d3(rcut, rcov, dispersion_env%k1, cnab, dcnab) - ELSE IF (cnfun == 2) THEN + ELSEIF (cnfun == 2) THEN CALL modcn_d3(rcut, rcov, cnab, dcnab) - ELSE IF (cnfun == 3) THEN + ELSEIF (cnfun == 3) THEN den = 0.0_dp CALL cn_d4per(rcut, rcov, den, cnab, dcnab) ELSE @@ -1367,9 +1367,9 @@ CONTAINS rcovab = dispersion_env%rcov(za) + dispersion_env%rcov(zb) IF (cnfun == 1) THEN CALL cnparam_d3(rcc, rcovab, dispersion_env%k1, cnab, dcnab) - ELSE IF (cnfun == 2) THEN + ELSEIF (cnfun == 2) THEN CALL modcn_d3(rcc, rcovab, cnab, dcnab) - ELSE IF (cnfun == 3) THEN + ELSEIF (cnfun == 3) THEN den = ABS(dispersion_env%eneg(za) - dispersion_env%eneg(zb)) CALL cn_d4per(rcc, rcovab, den, cnab, dcnab) ELSE diff --git a/src/qs_dispersion_d3.F b/src/qs_dispersion_d3.F index 0afac622bf..83f2a1ed5d 100644 --- a/src/qs_dispersion_d3.F +++ b/src/qs_dispersion_d3.F @@ -984,7 +984,7 @@ CONTAINS IF (rab >= ru) THEN fcc = 0._dp dfcc = 0._dp - ELSE IF (rab <= rl) THEN + ELSEIF (rab <= rl) THEN fcc = 1._dp dfcc = 0._dp ELSE diff --git a/src/qs_dispersion_nonloc.F b/src/qs_dispersion_nonloc.F index e4cce04a17..fa63eaf80f 100644 --- a/src/qs_dispersion_nonloc.F +++ b/src/qs_dispersion_nonloc.F @@ -583,7 +583,7 @@ CONTAINS COMPLEX(KIND=dp) :: uu COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: theta - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw(:, :) INTEGER :: handle, ig, iq, l, m, nl_type, nqs, & q1_i, q2_i LOGICAL :: use_virial diff --git a/src/qs_dispersion_pairpot.F b/src/qs_dispersion_pairpot.F index 26d6bff01b..3f68b76445 100644 --- a/src/qs_dispersion_pairpot.F +++ b/src/qs_dispersion_pairpot.F @@ -188,12 +188,11 @@ CONTAINS disp%defined = .FALSE. END IF ! Check if the parameter is defined - IF (.NOT. disp%defined) THEN + IF (.NOT. disp%defined) & CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") - END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO CASE (vdw_pairpot_dftd3, vdw_pairpot_dftd3bj) @@ -275,12 +274,11 @@ CONTAINS ELSE disp%defined = .FALSE. END IF - IF (.NOT. disp%defined) THEN + IF (.NOT. disp%defined) & CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") - END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO @@ -481,11 +479,11 @@ CONTAINS IF (dispersion_env%pp_type == vdw_pairpot_dftd2) THEN CALL calculate_dispersion_d2_pairpot(qs_env, dispersion_env, evdw, calculate_forces, atevdw) - ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & - dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN + ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & + dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN CALL calculate_dispersion_d3_pairpot(qs_env, dispersion_env, evdw, calculate_forces, & unit_nr, atevdw) - ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN + ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN IF (dispersion_env%lrc) THEN CPABORT("Long range correction with DFTD4 not implemented") END IF diff --git a/src/qs_efield_berry.F b/src/qs_efield_berry.F index bf69918821..48de8e24b0 100644 --- a/src/qs_efield_berry.F +++ b/src/qs_efield_berry.F @@ -263,7 +263,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -296,9 +296,8 @@ CONTAINS END IF END IF IF (use_virial) THEN - IF (para_env%mepos == 0) THEN + IF (para_env%mepos == 0) & CALL virial_pair_force(virial%pv_virial, 1.0_dp, forcea, ria) - END IF END IF END DO qi = AIMAG(LOG(zi)) @@ -753,7 +752,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/qs_electric_field_gradient.F b/src/qs_electric_field_gradient.F index 31adb830c8..c706d01b8e 100644 --- a/src/qs_electric_field_gradient.F +++ b/src/qs_electric_field_gradient.F @@ -153,7 +153,7 @@ CONTAINS smoothing = .FALSE. ecut = 1.e10_dp ! not used, just to have vars defined sigma = 1._dp ! not used, just to have vars defined - ELSE IF (ecut == -1._dp .AND. sigma == -1._dp) THEN + ELSEIF (ecut == -1._dp .AND. sigma == -1._dp) THEN smoothing = .TRUE. CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL auxbas_pw_pool%create_pw(dvr2rs) diff --git a/src/qs_energy.F b/src/qs_energy.F index 2c83157a0d..9ef6f0d88a 100644 --- a/src/qs_energy.F +++ b/src/qs_energy.F @@ -167,9 +167,8 @@ CONTAINS END IF IF (dft_control%tddfpt2_control%do_smearing) THEN - IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) THEN + IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) & CPABORT("Smearing occupation not associated.") - END IF CALL deallocate_fermi_params(dft_control%tddfpt2_control%smeared_occup) END IF IF (dft_control%qs_control%lrigpw) THEN diff --git a/src/qs_energy_init.F b/src/qs_energy_init.F index 48655f12db..7e82c28f28 100644 --- a/src/qs_energy_init.F +++ b/src/qs_energy_init.F @@ -283,14 +283,12 @@ CONTAINS CALL set_kpoint_info(kpoints, sab_nl_nosym=sab_nl_nosym) END IF IF (dft_control%qs_control%cdft) THEN - IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) THEN + IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) & dft_control%qs_control%cdft_control%need_pot = .TRUE. - END IF IF (ASSOCIATED(dft_control%qs_control%cdft_control%group)) THEN ! In case CDFT weight function was built beforehand (in mixed force_eval) - IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) THEN + IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) & dft_control%qs_control%cdft_control%need_pot = .FALSE. - END IF END IF END IF @@ -302,13 +300,13 @@ CONTAINS CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.FALSE.) CALL get_qs_env(qs_env=qs_env, dispersion_env=dispersion_env, energy=energy) CALL calculate_dispersion_pairpot(qs_env, dispersion_env, energy%dispersion, calc_forces) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL qs_env_update_s_mstruct(qs_env) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.FALSE.) ELSE diff --git a/src/qs_energy_types.F b/src/qs_energy_types.F index f527355b98..bb58784a8d 100644 --- a/src/qs_energy_types.F +++ b/src/qs_energy_types.F @@ -80,8 +80,7 @@ MODULE qs_energy_types surf_dipole = 0.0_dp, & embed_corr = 0.0_dp, & ! correction for embedding potential xtb_xb_inter = 0.0_dp, & ! correction for halogen bonding within GFN1-xTB - xtb_nonbonded = 0.0_dp, & ! correction for nonbonded interactions within GFN1-xTB - xtb_spinpol = 0.0_dp ! spin-polarised Hamiltonian energy within GFN1/2-xTB + xtb_nonbonded = 0.0_dp ! correction for nonbonded interactions within GFN1-xTB REAL(KIND=dp), DIMENSION(:), POINTER :: ddapc_restraint => NULL() END TYPE qs_energy_type diff --git a/src/qs_energy_window.F b/src/qs_energy_window.F index 5e782d11cf..6c41baed36 100644 --- a/src/qs_energy_window.F +++ b/src/qs_energy_window.F @@ -88,7 +88,7 @@ CONTAINS INTEGER :: handle, i, lanzcos_max_iter, last, nao, & nelectron_total, newton_schulz_order, & next, nwindows, print_unit, unit_nr - INTEGER, DIMENSION(:), POINTER :: stride + INTEGER, DIMENSION(:), POINTER :: stride(:) LOGICAL :: mpi_io, print_cube, restrict_range REAL(KIND=dp) :: bin_width, density_ewindow_total, density_total, energy_range, fermi_level, & filter_eps, frob_norm, lanzcos_threshold, lower_bound, occupation, upper_bound diff --git a/src/qs_environment.F b/src/qs_environment.F index 1743d76cea..bf7ae4766d 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -218,9 +218,7 @@ MODULE qs_environment USE transport, ONLY: transport_env_create USE xtb_parameters, ONLY: init_xtb_basis,& xtb_parameters_init,& - xtb_parameters_set,& - xtb_spinpol_ext,& - xtb_spinpol_init + xtb_parameters_set USE xtb_potentials, ONLY: xtb_pp_radius USE xtb_types, ONLY: allocate_xtb_atom_param,& set_xtb_atom_param @@ -419,17 +417,14 @@ CONTAINS do_tddfpt_unsupported_kpoints = tddfpt_kernel /= tddfpt_kernel_none IF (.NOT. do_tddfpt_unsupported_kpoints) THEN CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) THEN + IF (use_real_wfn) & CALL cp_abort(__LOCATION__, "K-point TDDFPT requires complex wavefunctions.") - END IF END IF CALL section_vals_val_get(tddfpt_section, "DO_BSE", l_val=do_bse) - IF (.NOT. do_bse) THEN + IF (.NOT. do_bse) & CALL section_vals_val_get(tddfpt_section, "DO_BSE_W_ONLY", l_val=do_bse) - END IF - IF (.NOT. do_bse) THEN + IF (.NOT. do_bse) & CALL section_vals_val_get(tddfpt_section, "DO_BSE_GW_ONLY", l_val=do_bse) - END IF END IF do_active_space = .FALSE. active_space_section => section_vals_get_subs_vals(qs_env%input, "DFT%ACTIVE_SPACE") @@ -476,11 +471,10 @@ CONTAINS l_val=do_wfc_low_scaling) CALL section_vals_val_get(qs_env%input, "DFT%XC%WF_CORRELATION%LOW_SCALING%DO_KPOINTS", & l_val=do_wfc_low_scaling_kpoints) - IF (.NOT. do_bse) THEN + IF (.NOT. do_bse) & CALL section_vals_val_get(qs_env%input, & "DFT%XC%WF_CORRELATION%RI_RPA%GW%BSE%_SECTION_PARAMETERS_", & l_val=do_bse) - END IF END IF CALL restrict_unsupported_atomic_kpoint_symmetry(kpoints, method_id, do_hfx, do_exx, do_gw, & do_tddfpt_unsupported_kpoints, & @@ -540,9 +534,8 @@ CONTAINS ! more kpoint stuff CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints, blacs_env=blacs_env) IF (do_kpoints) THEN - IF (dft_control%qs_control%do_ls_scf) THEN + IF (dft_control%qs_control%do_ls_scf) & CPABORT("DFT%KPOINTS are not implemented with QS/LS_SCF; use a real-space supercell instead.") - END IF CALL kpoint_env_initialize(kpoints, para_env, blacs_env, with_aux_fit=dft_control%do_admm) CALL kpoint_initialize_mos(kpoints, qs_env%mos) CALL get_qs_env(qs_env=qs_env, wf_history=wf_history) @@ -1196,7 +1189,7 @@ CONTAINS CALL ewald_pw_create(ewald_pw, ewald_env, cell, cell_ref, print_section=print_section) CALL set_qs_env(qs_env, ewald_env=ewald_env, ewald_pw=ewald_pw) END IF - ELSE IF (dft_control%qs_control%method_id == do_method_xtb) THEN + ELSEIF (dft_control%qs_control%method_id == do_method_xtb) THEN ! Read xTB parameter file xtb_control => dft_control%qs_control%xtb_control CALL get_qs_env(qs_env, nkind=nkind) @@ -1240,12 +1233,6 @@ CONTAINS CALL xtb_parameters_init(qs_kind%xtb_parameter, gfn_type, element_symbol, & xtb_control%parameter_file_path, xtb_control%parameter_file_name, & para_env) - IF (xtb_control%do_spinpol) THEN - CALL xtb_spinpol_init(qs_kind%xtb_parameter, gfn_type, element_symbol, & - xtb_control%parameter_file_path, xtb_control%spinpol_param_file_name, & - para_env) - CALL xtb_spinpol_ext(qs_kind%xtb_parameter, gfn_type, xtb_control) - END IF ! set dependent parameters CALL xtb_parameters_set(qs_kind%xtb_parameter) ! Generate basis set @@ -1636,13 +1623,11 @@ CONTAINS IF (.NOT. dft_control%qs_control%do_ls_scf) THEN SELECT CASE (dft_control%qs_control%method_id) CASE (do_method_dftb) - IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN + IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & scf_control%max_scf = dft_control%qs_control%dftb_control%tblite_mixer_iterations - END IF CASE (do_method_xtb) - IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN + IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & scf_control%max_scf = dft_control%qs_control%xtb_control%tblite_mixer_iterations - END IF END SELECT END IF @@ -1888,7 +1873,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN + ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd3bj dispersion_env%eps_cn = dftb_control%epscn @@ -1904,7 +1889,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN + ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd2 dispersion_env%exp_pre = dftb_control%exp_pre @@ -2232,11 +2217,10 @@ CONTAINS n_mo(1) = n_mo(1) + scf_control%added_mos(1) IF (dft_control%nspins == 2) THEN - IF (n_mo(2) > n_mo(1)) THEN + IF (n_mo(2) > n_mo(1)) & CALL cp_warn(__LOCATION__, & "More beta than alpha MOs requested. "// & "The number of beta MOs will be reduced to the number alpha MOs.") - END IF n_mo(2) = MIN(n_mo(1), n_mo(2)) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2246,11 +2230,10 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) IF (do_kpoints .AND. dft_control%nspins == 2) THEN ! we need equal number of calculated states - IF (n_mo(2) /= n_mo(1)) THEN + IF (n_mo(2) /= n_mo(1)) & CALL cp_warn(__LOCATION__, & "Kpoints: Different number of MOs requested. "// & "The number of beta MOs will be set to the number alpha MOs.") - END IF n_mo(2) = n_mo(1) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2497,7 +2480,7 @@ CONTAINS "- Orbital basis functions: ", maxlgto, & "- Local part of the GTH pseudopotential: ", maxlppl, & "- Non-local part of the GTH pseudopotential: ", maxlppnl - ELSE IF (maxlppl > -1) THEN + ELSEIF (maxlppl > -1) THEN WRITE (UNIT=output_unit, FMT="(/,T3,A,(T30,A,T75,I6))") & "Maximum angular momentum of the", & "- Orbital basis functions: ", maxlgto, & diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index ac95bc2f66..ac6c8fa2a6 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -163,8 +163,6 @@ MODULE qs_environment_types USE wannier_states_types, ONLY: wannier_centres_type USE xas_env_types, ONLY: xas_env_release,& xas_environment_type - USE xc_gauxc_cache, ONLY: cp_gauxc_cache_type,& - gauxc_cache_release #include "./base/base_uses.f90" IMPLICIT NONE @@ -324,7 +322,6 @@ MODULE qs_environment_types TYPE(mo_set_type), DIMENSION(:), POINTER :: mos_last_converged => NULL() ! tblite TYPE(tblite_type), POINTER :: tb_tblite => Null() - TYPE(cp_gauxc_cache_type), POINTER :: gauxc_cache => NULL() END TYPE qs_environment_type CONTAINS @@ -744,27 +741,20 @@ CONTAINS ! Resp charges IF (PRESENT(rhs)) rhs => qs_env%rhs - IF (PRESENT(local_rho_set)) THEN + IF (PRESENT(local_rho_set)) & local_rho_set => qs_env%local_rho_set - END IF - IF (PRESENT(rho_atom_set)) THEN + IF (PRESENT(rho_atom_set)) & CALL get_local_rho(qs_env%local_rho_set, rho_atom_set=rho_atom_set) - END IF - IF (PRESENT(rho0_atom_set)) THEN + IF (PRESENT(rho0_atom_set)) & CALL get_local_rho(qs_env%local_rho_set, rho0_atom_set=rho0_atom_set) - END IF - IF (PRESENT(rho0_mpole)) THEN + IF (PRESENT(rho0_mpole)) & CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_mpole) - END IF - IF (PRESENT(rhoz_set)) THEN + IF (PRESENT(rhoz_set)) & CALL get_local_rho(qs_env%local_rho_set, rhoz_set=rhoz_set) - END IF - IF (PRESENT(rhoz_cneo_set)) THEN + IF (PRESENT(rhoz_cneo_set)) & CALL get_local_rho(qs_env%local_rho_set, rhoz_cneo_set=rhoz_cneo_set) - END IF - IF (PRESENT(ecoul_1c)) THEN + IF (PRESENT(ecoul_1c)) & CALL get_hartree_local(qs_env%hartree_local, ecoul_1c=ecoul_1c) - END IF IF (PRESENT(rho0_s_rs)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_m) IF (ASSOCIATED(rho0_m)) THEN @@ -1011,7 +1001,6 @@ CONTAINS IF (.NOT. ASSOCIATED(qs_env%molecular_scf_guess_env)) ALLOCATE (qs_env%molecular_scf_guess_env) NULLIFY (qs_env%tb_tblite) - NULLIFY (qs_env%gauxc_cache) END SUBROUTINE init_qs_env @@ -1496,12 +1485,10 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) THEN + IF (ASSOCIATED(qs_env%gradient_history)) & DEALLOCATE (qs_env%gradient_history) - END IF - IF (ASSOCIATED(qs_env%variable_history)) THEN + IF (ASSOCIATED(qs_env%variable_history)) & DEALLOCATE (qs_env%variable_history) - END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1693,11 +1680,6 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF - IF (ASSOCIATED(qs_env%gauxc_cache)) THEN - CALL gauxc_cache_release(qs_env%gauxc_cache) - DEALLOCATE (qs_env%gauxc_cache) - END IF - END SUBROUTINE qs_env_release ! ************************************************************************************************** @@ -1735,12 +1717,10 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) THEN + IF (ASSOCIATED(qs_env%gradient_history)) & DEALLOCATE (qs_env%gradient_history) - END IF - IF (ASSOCIATED(qs_env%variable_history)) THEN + IF (ASSOCIATED(qs_env%variable_history)) & DEALLOCATE (qs_env%variable_history) - END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1924,11 +1904,6 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF - IF (ASSOCIATED(qs_env%gauxc_cache)) THEN - CALL gauxc_cache_release(qs_env%gauxc_cache) - DEALLOCATE (qs_env%gauxc_cache) - END IF - END SUBROUTINE qs_env_part_release END MODULE qs_environment_types diff --git a/src/qs_external_potential.F b/src/qs_external_potential.F index e77b4b3655..ec813c6695 100644 --- a/src/qs_external_potential.F +++ b/src/qs_external_potential.F @@ -91,7 +91,7 @@ CONTAINS qs_env%sim_step, qs_env%sim_time, & scaling_factor) dft_control%eval_external_potential = .FALSE. - ELSE IF (dft_control%expot_control%read_from_cube) THEN + ELSEIF (dft_control%expot_control%read_from_cube) THEN scaling_factor = dft_control%expot_control%scaling_factor CALL cp_cube_to_pw(v_ee, 'pot.cube', scaling_factor) dft_control%eval_external_potential = .FALSE. diff --git a/src/qs_fb_env_types.F b/src/qs_fb_env_types.F index 0b0173c14b..3b580c1ac1 100644 --- a/src/qs_fb_env_types.F +++ b/src/qs_fb_env_types.F @@ -266,33 +266,24 @@ CONTAINS CPASSERT(ASSOCIATED(fb_env%obj)) CPASSERT(fb_env%obj%ref_count > 0) - IF (PRESENT(rcut)) THEN + IF (PRESENT(rcut)) & rcut => fb_env%obj%rcut - END IF - IF (PRESENT(filter_temperature)) THEN + IF (PRESENT(filter_temperature)) & filter_temperature = fb_env%obj%filter_temperature - END IF - IF (PRESENT(auto_cutoff_scale)) THEN + IF (PRESENT(auto_cutoff_scale)) & auto_cutoff_scale = fb_env%obj%auto_cutoff_scale - END IF - IF (PRESENT(eps_default)) THEN + IF (PRESENT(eps_default)) & eps_default = fb_env%obj%eps_default - END IF - IF (PRESENT(atomic_halos)) THEN + IF (PRESENT(atomic_halos)) & CALL fb_atomic_halo_list_associate(atomic_halos, fb_env%obj%atomic_halos) - END IF - IF (PRESENT(trial_fns)) THEN + IF (PRESENT(trial_fns)) & CALL fb_trial_fns_associate(trial_fns, fb_env%obj%trial_fns) - END IF - IF (PRESENT(collective_com)) THEN + IF (PRESENT(collective_com)) & collective_com = fb_env%obj%collective_com - END IF - IF (PRESENT(local_atoms)) THEN + IF (PRESENT(local_atoms)) & local_atoms => fb_env%obj%local_atoms - END IF - IF (PRESENT(nlocal_atoms)) THEN + IF (PRESENT(nlocal_atoms)) & nlocal_atoms = fb_env%obj%nlocal_atoms - END IF END SUBROUTINE fb_env_get ! ********************************************************************** @@ -338,38 +329,32 @@ CONTAINS END IF fb_env%obj%rcut => rcut END IF - IF (PRESENT(filter_temperature)) THEN + IF (PRESENT(filter_temperature)) & fb_env%obj%filter_temperature = filter_temperature - END IF - IF (PRESENT(auto_cutoff_scale)) THEN + IF (PRESENT(auto_cutoff_scale)) & fb_env%obj%auto_cutoff_scale = auto_cutoff_scale - END IF - IF (PRESENT(eps_default)) THEN + IF (PRESENT(eps_default)) & fb_env%obj%eps_default = eps_default - END IF IF (PRESENT(atomic_halos)) THEN CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) CALL fb_atomic_halo_list_associate(fb_env%obj%atomic_halos, atomic_halos) END IF IF (PRESENT(trial_fns)) THEN - IF (fb_trial_fns_has_data(trial_fns)) THEN + IF (fb_trial_fns_has_data(trial_fns)) & CALL fb_trial_fns_retain(trial_fns) - END IF CALL fb_trial_fns_release(fb_env%obj%trial_fns) CALL fb_trial_fns_associate(fb_env%obj%trial_fns, trial_fns) END IF - IF (PRESENT(collective_com)) THEN + IF (PRESENT(collective_com)) & fb_env%obj%collective_com = collective_com - END IF IF (PRESENT(local_atoms)) THEN IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE (fb_env%obj%local_atoms) END IF fb_env%obj%local_atoms => local_atoms END IF - IF (PRESENT(nlocal_atoms)) THEN + IF (PRESENT(nlocal_atoms)) & fb_env%obj%nlocal_atoms = nlocal_atoms - END IF END SUBROUTINE fb_env_set END MODULE qs_fb_env_types diff --git a/src/qs_fb_filter_matrix_methods.F b/src/qs_fb_filter_matrix_methods.F index 5b94b8fdc0..1be7bcdc2a 100644 --- a/src/qs_fb_filter_matrix_methods.F +++ b/src/qs_fb_filter_matrix_methods.F @@ -480,7 +480,7 @@ CONTAINS INTEGER :: handle, handle_mpi, iatom_global, iatom_in_halo, ind, ipair, ipe, itrial, & jatom_global, jatom_in_halo, jkind, natoms_global, natoms_in_halo, ncols_atmatrix, & - ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode + ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode, stat INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs_recv, pairs_send INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data, ind_in_halo, & @@ -583,7 +583,9 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1)) + atomic_H_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -601,7 +603,9 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1)) + atomic_S_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -793,7 +797,7 @@ CONTAINS INTEGER :: handle, iatom_global, iatom_in_halo, itrial, jatom_global, jatom_in_halo, jkind, & natoms_global, natoms_in_halo, ncols_atmatrix, ncols_blk, ncols_blk_max, nrows_atmatrix, & - nrows_blk, nrows_blk_max + nrows_blk, nrows_blk_max, stat INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data INTEGER, DIMENSION(:), POINTER :: halo_atoms, ntfns, row_block_size_data @@ -837,7 +841,9 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1)) + atomic_H_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -853,7 +859,9 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1)) + atomic_S_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -898,6 +906,9 @@ CONTAINS nrows_blk = row_block_size_data(iatom_global) ncols_blk = ntfns(jkind) + ! ALLOCATE(mat_blk(nrows_blk,ncols_blk) STAT=stat) + ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) + ! do it column-wise one trial function at a time DO itrial = 1, ntfns(jkind) CALL dgemv("N", & diff --git a/src/qs_force.F b/src/qs_force.F index ab1f8d5ece..3bf365e4c1 100644 --- a/src/qs_force.F +++ b/src/qs_force.F @@ -227,9 +227,8 @@ CONTAINS CALL calc_c_mat_force(qs_env) IF (dft_control%do_admm) CALL rt_admm_force(qs_env) - IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) THEN + IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) & CALL velocity_gauge_nl_force(qs_env, particle_set) - END IF END IF ! from an eventual Mulliken restraint IF (dft_control%qs_control%mulliken_restraint) THEN @@ -287,18 +286,18 @@ CONTAINS CALL build_se_core_matrix(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.TRUE.) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.TRUE.) ELSE CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) END IF - ELSE IF (perform_ec) THEN + ELSEIF (perform_ec) THEN ! Calculates core and grid based forces CALL energy_correction(qs_env, ec_init=.FALSE., calculate_forces=.TRUE.) ELSE @@ -306,12 +305,10 @@ CONTAINS CALL build_core_hamiltonian_matrix(qs_env=qs_env, calculate_forces=.TRUE.) ! The above line reset the core H, which should be re-updated in case a TD field is applied: IF (qs_env%run_rtp) THEN - IF (dft_control%apply_efield_field) THEN + IF (dft_control%apply_efield_field) & CALL efield_potential_lengh_gauge(qs_env) - END IF - IF (dft_control%rtp_control%velocity_gauge) THEN + IF (dft_control%rtp_control%velocity_gauge) & CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) - END IF END IF CALL calculate_ecore_self(qs_env) @@ -371,9 +368,9 @@ CONTAINS t3=dummy_real) END IF END IF - ELSE IF (perform_ec) THEN + ELSEIF (perform_ec) THEN ! energy correction forces postponed - ELSE IF (qs_env%harris_method) THEN + ELSEIF (qs_env%harris_method) THEN ! Harris method forces already done in harris_energy_correction ELSE ! Compute grid-based forces diff --git a/src/qs_fxc.F b/src/qs_fxc.F index 1380dc5c1d..6fe283637e 100644 --- a/src/qs_fxc.F +++ b/src/qs_fxc.F @@ -371,9 +371,8 @@ CONTAINS END DO ! Create fields for mGGA functionals. This implementation is not ready yet! IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) THEN + IF (.NOT. ASSOCIATED(tau1_r)) & CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") - END IF ALLOCATE (fxc_tau(spindim), gxc_tau(nspins)) DO ispin = 1, spindim CALL pw_pool%create_pw(fxc_tau(ispin)) diff --git a/src/qs_gapw_densities.F b/src/qs_gapw_densities.F index 2aaa407afc..567c7e99bb 100644 --- a/src/qs_gapw_densities.F +++ b/src/qs_gapw_densities.F @@ -158,11 +158,10 @@ CONTAINS END IF !Calculate rho0_h and rho0_s on the radial grids centered on the atomic position - IF (my_do_rho0) THEN + IF (my_do_rho0) & CALL calculate_rho0_atom(gapw_control, rho_atom_set, rhoz_cneo_set, rho0_atom_set, & rho0_mpole, atom_list, natom, ikind, my_kind_set(ikind), & rho0_h_tot) - END IF END DO !Do not mess with charges if using a non-default kind_set diff --git a/src/qs_gspace_mixing.F b/src/qs_gspace_mixing.F index e88926315d..eb64b2fbfa 100644 --- a/src/qs_gspace_mixing.F +++ b/src/qs_gspace_mixing.F @@ -164,25 +164,25 @@ CONTAINS CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSE IF (mixing_method == gspace_mixing_nr) THEN + ELSEIF (mixing_method == gspace_mixing_nr) THEN CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSE IF (mixing_method == pulay_mixing_nr) THEN + ELSEIF (mixing_method == pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Pulay" - ELSE IF (mixing_method == new_pulay_mixing_nr) THEN + ELSEIF (mixing_method == new_pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "NPulay" - ELSE IF (mixing_method == broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr) THEN CALL cite_reference(Broyden1965) CALL broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Broy." - ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN + ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN CALL cite_reference(Johnson1988) CALL modified_broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "MBroy" - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN CPASSERT(.NOT. gapw) CALL multisecant_mixing(mixing_store, rho, para_env) mixing_store%iter_method = "MSec." @@ -1446,7 +1446,7 @@ CONTAINS DO jb = 1, nb + 1 IF (jb < ib) THEN kb = jb - ELSE IF (jb > ib) THEN + ELSEIF (jb > ib) THEN kb = jb - 1 ELSE CYCLE @@ -1564,7 +1564,7 @@ CONTAINS AIMAG(pgn(ig))*AIMAG(pgn(ig)) END DO CALL para_env%sum(pgn_norm) - ELSE IF (use_zgemm_rev) THEN + ELSEIF (use_zgemm_rev) THEN CALL zgemv("N", nb, ng_global, cone, a_matrix(1, 1), & nb, gn_global(1), 1, czero, tmp_vec(1), 1) diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index 123380fab2..5c5acca6c7 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -330,9 +330,8 @@ CONTAINS IF (j /= 0) THEN filename = TRIM(file_name)//".bak-"//ADJUSTL(cp_to_string(j)) END IF - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & INQUIRE (FILE=filename, exist=exist) - END IF CALL para_env%bcast(exist) IF ((.NOT. exist) .AND. (i < not_read)) THEN not_read = i @@ -418,7 +417,7 @@ CONTAINS IF (has_unit_metric) THEN CALL make_basis_simple(mo_coeff, nmo) - ELSE IF (dft_control%smear) THEN + ELSEIF (dft_control%smear) THEN CALL make_basis_lowdin(vmatrix=mo_coeff, ncol=nmo, & matrix_s=s_sparse(1)%matrix) ELSE @@ -938,11 +937,11 @@ CONTAINS WRITE (ounit, *) 'wrong', i, SUM(buff**2) END IF END IF - length = NORM2(buff(:, 1)) + length = SQRT(DOT_PRODUCT(buff(:, 1), buff(:, 1))) buff(:, :) = buff(:, :)/length DO j = i + 1, nmo CALL cp_fm_get_submatrix(mo_coeff, buff2, 1, j, nao, 1) - length = NORM2(buff2(:, 1)) + length = SQRT(DOT_PRODUCT(buff2(:, 1), buff2(:, 1))) buff2(:, :) = buff2(:, :)/length IF (ABS(DOT_PRODUCT(buff(:, 1), buff2(:, 1)) - 1.0_dp) < 1E-10_dp) THEN IF (ounit > 0) THEN @@ -1259,6 +1258,7 @@ CONTAINS pdiag(:) = 0.0_dp ALLOCATE (sdiag(nao)) + sdiag(:) = 0.0_dp IF (has_unit_metric) THEN sdiag(:) = 1.0_dp @@ -1289,10 +1289,10 @@ CONTAINS lmax=maxll, occupation=edftb) maxll = MIN(maxll, maxl) econf(0:maxl) = edftb(0:maxl) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, z=z, natorb=nsgf, nao=naox, lao=laox, occupation=occupation) - ELSE IF (has_pot) THEN + ELSEIF (has_pot) THEN CALL get_atomic_kind(atomic_kind_set(ikind), z=z) CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff) maxll = MIN(SIZE(elec_conf) - 1, maxl) @@ -1334,25 +1334,24 @@ CONTAINS END SELECT END DO END DO - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN DO iatom = 1, natom atom_a = atom_list(iatom) isgfa = first_sgf(atom_a) IF (z == 1 .AND. nsgf == 2) THEN ! Hydrogen 2s basis - pdiag(isgfa) = 1.0_dp/REAL(nspin, dp) + pdiag(isgfa) = 1.0_dp pdiag(isgfa + 1) = 0.0_dp ELSE DO isgf = 1, nsgf na = naox(isgf) la = laox(isgf) occ = REAL(occupation(la + 1), dp)/REAL(2*la + 1, dp) - occ = occ/REAL(nspin, dp) pdiag(isgfa + isgf - 1) = occ END DO END IF END DO - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN yy = REAL(dft_control%charge, KIND=dp)/REAL(nao, KIND=dp) DO iatom = 1, natom atom_a = atom_list(iatom) @@ -1456,11 +1455,8 @@ CONTAINS END DO DO ispin = 1, nspin IF (nelectron_spin(ispin) /= 0) THEN - rscale = SUM(pdiag)/REAL(nelectron_spin(ispin), dp) matrix_p => pmat(ispin)%matrix - pdiag = pdiag/rscale CALL dbcsr_set_diag(matrix_p, pdiag) - pdiag = pdiag*rscale END IF END DO ELSE diff --git a/src/qs_integrate_potential_product.F b/src/qs_integrate_potential_product.F index e99302334e..decbe53525 100644 --- a/src/qs_integrate_potential_product.F +++ b/src/qs_integrate_potential_product.F @@ -417,58 +417,54 @@ CONTAINS END IF IF (iatom <= jatom) THEN - IF (iatom == lambda) THEN + IF (iatom == lambda) & CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) - END IF - IF (jatom == lambda) THEN + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) + IF (jatom == lambda) & CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) - END IF + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) ELSE rab_inv = -rab - IF (iatom == lambda) THEN + IF (iatom == lambda) & CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) - END IF - IF (jatom == lambda) THEN + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) + IF (jatom == lambda) & CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) - END IF + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) END IF new_set_pair_coming = .FALSE. diff --git a/src/qs_kind_types.F b/src/qs_kind_types.F index 3367d1ec57..8928bc4553 100644 --- a/src/qs_kind_types.F +++ b/src/qs_kind_types.F @@ -1008,7 +1008,7 @@ CONTAINS IF (PRESENT(maxlppl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nexp_ppl=n) maxlppl = MAX(maxlppl, 2*(n - 1)) - ELSE IF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSEIF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nrloc=nrloc, ecp_semi_local=ecp_semi_local) n = MAXVAL(nrloc) - 2 maxlppl = MAX(maxlppl, 2*(n - 1)) @@ -1023,7 +1023,7 @@ CONTAINS IF (PRESENT(maxlppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, lprj_ppnl_max=imax) maxlppnl = MAX(maxlppnl, imax) - ELSE IF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSEIF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, lmax=imax) maxlppnl = MAX(maxlppnl, imax) END IF @@ -1046,7 +1046,7 @@ CONTAINS IF (PRESENT(maxppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) - ELSE IF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSEIF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) END IF @@ -1327,7 +1327,7 @@ CONTAINS IF (ASSOCIATED(qs_kind%gth_potential)) THEN CALL init_potential(qs_kind%gth_potential) - ELSE IF (ASSOCIATED(qs_kind%sgp_potential)) THEN + ELSEIF (ASSOCIATED(qs_kind%sgp_potential)) THEN CALL init_potential(qs_kind%sgp_potential) END IF @@ -1790,12 +1790,12 @@ CONTAINS basis_set_type(i) = "ORB" basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(1) - ELSE IF (SIZE(tmpstringlist) == 2) THEN + ELSEIF (SIZE(tmpstringlist) == 2) THEN ! default is GTO basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(2) - ELSE IF (SIZE(tmpstringlist) == 3) THEN + ELSEIF (SIZE(tmpstringlist) == 3) THEN basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = tmpstringlist(2) basis_set_name(i) = tmpstringlist(3) @@ -1876,7 +1876,7 @@ CONTAINS potential_type = potential_name END IF END IF - ELSE IF (SIZE(tmpstringlist) == 2) THEN + ELSEIF (SIZE(tmpstringlist) == 2) THEN potential_type = tmpstringlist(1) potential_name = tmpstringlist(2) ELSE @@ -1930,22 +1930,19 @@ CONTAINS CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RHO0_EXP_RADIUS", r_val=qs_kind%hard0_radius) END IF - IF (qs_kind%hard_radius < qs_kind%hard0_radius) THEN + IF (qs_kind%hard_radius < qs_kind%hard0_radius) & CPABORT("rc0 should be <= rc") - END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="MAX_RAD_LOCAL", r_val=qs_kind%max_rad_local) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="LEBEDEV_GRID", i_val=qs_kind%ngrid_ang) - IF (qs_kind%ngrid_ang <= 0) THEN + IF (qs_kind%ngrid_ang <= 0) & CPABORT("# point lebedev grid < 0") - END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RADIAL_GRID", i_val=qs_kind%ngrid_rad) - IF (qs_kind%ngrid_rad <= 0) THEN + IF (qs_kind%ngrid_rad <= 0) & CPABORT("# point radial grid < 0") - END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="GPW_TYPE", l_val=qs_kind%gpw_type_forced) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & @@ -2149,25 +2146,21 @@ CONTAINS keyword_name="ORBITALS", & i_vals=orbitals) norbitals = SIZE(orbitals) - IF (norbitals <= 0 .OR. norbitals > 2*l + 1) THEN + IF (norbitals <= 0 .OR. norbitals > 2*l + 1) & CALL cp_abort(__LOCATION__, "DFT+U| Invalid number of ORBITALS specified: "// & "1 to 2*L+1 integer numbers are expected") - END IF ALLOCATE (qs_kind%dft_plus_u%orbitals(norbitals)) qs_kind%dft_plus_u%orbitals(:) = orbitals(:) NULLIFY (orbitals) DO m = 1, norbitals - IF (qs_kind%dft_plus_u%orbitals(m) > l) THEN + IF (qs_kind%dft_plus_u%orbitals(m) > l) & CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m > l") - END IF - IF (qs_kind%dft_plus_u%orbitals(m) < -l) THEN + IF (qs_kind%dft_plus_u%orbitals(m) < -l) & CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m < -l") - END IF DO j = 1, norbitals IF (j /= m) THEN - IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) THEN + IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) & CPABORT("DFT+U| An orbital magnetic quantum number was specified twice") - END IF END IF END DO END DO @@ -2261,18 +2254,16 @@ CONTAINS qs_kind%se_parameter%zeff = qs_kind%se_parameter%zeff - zeff_correction check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF CASE (do_method_dftb) ! Allocate all_potential @@ -2296,18 +2287,16 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF CASE (do_method_xtb) ! Allocate all_potential @@ -2331,18 +2320,16 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF CASE (do_method_pw) ! PW DFT @@ -2658,9 +2645,8 @@ CONTAINS CALL atom_release_upf(upfpot) CALL atom_sgp_release(sgppot) CASE ("CNEO") - IF (zeff_correction /= 0.0_dp) THEN + IF (zeff_correction /= 0.0_dp) & CPABORT("CORE_CORRECTION is not compatible with CNEO") - END IF CALL allocate_cneo_potential(qs_kind%cneo_potential) CALL set_cneo_potential(qs_kind%cneo_potential, z=z) mass = 0.0_dp @@ -2787,17 +2773,14 @@ CONTAINS CALL get_qs_kind(qs_kind, name=name, gth_potential=gth_potential, basis_set=basis_set) npp = -1; nbs = -1 - IF (ASSOCIATED(gth_potential)) THEN + IF (ASSOCIATED(gth_potential)) & npp = parse_valence_electrons(gth_potential%aliases) - END IF - IF (ASSOCIATED(basis_set)) THEN + IF (ASSOCIATED(basis_set)) & nbs = parse_valence_electrons(basis_set%aliases) - END IF - IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) THEN + IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) & CALL cp_abort(__LOCATION__, "Basis-set and pseudo-potential of atomic kind '"//TRIM(name)//"'"// & " were optimized for different valence electron numbers.") - END IF END SUBROUTINE check_potential_basis_compatibility @@ -4003,7 +3986,7 @@ CONTAINS IF (ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nlcc_present=nlcc_present) nlcc = nlcc .OR. nlcc_present - ELSE IF (ASSOCIATED(sgp_potential)) THEN + ELSEIF (ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, has_nlcc=nlcc_present) nlcc = nlcc .OR. nlcc_present END IF diff --git a/src/qs_kinetic.F b/src/qs_kinetic.F index 3ba3a01c62..b743911176 100644 --- a/src/qs_kinetic.F +++ b/src/qs_kinetic.F @@ -220,7 +220,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSE IF (PRESENT(matrixkp_t)) THEN + ELSEIF (PRESENT(matrixkp_t)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -279,7 +279,7 @@ CONTAINS ELSE IF (PRESENT(matrix_p)) THEN matp => matrix_p - ELSE IF (PRESENT(matrixkp_p)) THEN + ELSEIF (PRESENT(matrixkp_p)) THEN matp => matrixkp_p(1, 1)%matrix ELSE CPABORT("Missing density matrix") @@ -409,6 +409,8 @@ CONTAINS row=irow, col=icol, block=p_block, found=found) CPASSERT(found) ELSE +!deb CALL dbcsr_get_block_p(matrix=matrix_p, row=irow, col=icol, & +!deb block=p_block, found=found) CALL dbcsr_get_block_p(matrix=matp, row=irow, col=icol, & block=p_block, found=found) CPASSERT(found) diff --git a/src/qs_kpp1_env_methods.F b/src/qs_kpp1_env_methods.F index 504224f6c8..2ff3fe8229 100644 --- a/src/qs_kpp1_env_methods.F +++ b/src/qs_kpp1_env_methods.F @@ -200,9 +200,8 @@ CONTAINS poisson_env=poisson_env) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) THEN + IF (gapw .OR. gapw_xc) & CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) - END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -455,7 +454,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=my_calc_forces, tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_ks_apply_restraints.F b/src/qs_ks_apply_restraints.F index 79524ca9f1..d2d9c792c7 100644 --- a/src/qs_ks_apply_restraints.F +++ b/src/qs_ks_apply_restraints.F @@ -83,25 +83,22 @@ CONTAINS CALL auxbas_pw_pool%create_pw(cdft_control%group(igroup)%weight) ! Sanity check IF (cdft_control%group(igroup)%constraint_type /= cdft_charge_constraint & - .AND. dft_control%nspins == 1) THEN + .AND. dft_control%nspins == 1) & CALL cp_abort(__LOCATION__, & "Spin constraints require a spin polarized calculation.") - END IF END DO IF (cdft_control%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control%charge)) THEN + IF (.NOT. ASSOCIATED(cdft_control%charge)) & ALLOCATE (cdft_control%charge(cdft_control%natoms)) - END IF DO iatom = 1, cdft_control%natoms CALL auxbas_pw_pool%create_pw(cdft_control%charge(iatom)) END DO END IF ! Another sanity check CALL get_qs_env(qs_env, natom=natom) - IF (natom < cdft_control%natoms) THEN + IF (natom < cdft_control%natoms) & CALL cp_abort(__LOCATION__, & "The number of constraint atoms exceeds the total number of atoms.") - END IF ELSE DO igroup = 1, SIZE(cdft_control%group) inv_vol = 1.0_dp/cdft_control%group(igroup)%weight%pw_grid%dvol diff --git a/src/qs_ks_atom.F b/src/qs_ks_atom.F index 891c94351b..fbf62a1fe3 100644 --- a/src/qs_ks_atom.F +++ b/src/qs_ks_atom.F @@ -649,14 +649,14 @@ CONTAINS 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (dista) THEN + ELSEIF (dista) THEN CALL DGEMM('N', 'T', nsp, ncontb, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_b(:, :, 1), SIZE(C_hh_b, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, ncontb, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & C_ss_b(:, :, 1), SIZE(C_ss_b, 1), 1.0_dp, coc, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & coc, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (distb) THEN + ELSEIF (distb) THEN CALL DGEMM('N', 'N', nconta, nsp, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, nconta) CALL DGEMM('N', 'N', nconta, nsp, nsp, -factor, C_ss_a(:, :, 1), SIZE(C_ss_a, 1), & @@ -692,14 +692,14 @@ CONTAINS CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, coc, nsp, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', ncontb, nconta, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (dista) THEN + ELSEIF (dista) THEN CALL DGEMM('N', 'N', ncontb, nsp, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, ncontb) CALL DGEMM('N', 'N', ncontb, nsp, nsp, -factor, C_ss_b(:, :, 1), SIZE(C_ss_b, 1), & int_soft, SIZE(int_soft, 1), 1.0_dp, coc, ncontb) CALL DGEMM('N', 'T', ncontb, nconta, nsp, 1.0_dp, coc, ncontb, & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (distb) THEN + ELSEIF (distb) THEN CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, nconta, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index a2cf906d65..652655dae1 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -143,7 +143,6 @@ MODULE qs_ks_methods get_gauxc_section,& xc_section_uses_native_skala_grid USE smeagol_interface, ONLY: smeagol_shift_v_hartree - USE string_utilities, ONLY: uppercase USE surface_dipole, ONLY: calc_dipsurf_potential USE tblite_ks_matrix, ONLY: build_tblite_ks_matrix USE virial_types, ONLY: virial_type @@ -200,15 +199,14 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_build_kohn_sham_matrix' - CHARACTER(len=default_string_length) :: gauxc_model_name, name + CHARACTER(len=default_string_length) :: name INTEGER :: ace_rebuild_frequency, atom_a, handle, & iatom, ikind, img, ispin, natom, & nimages, nspins, output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of LOGICAL :: ace_active, do_adiabatic_rescaling, do_ddapc, do_hfx, do_kpoints, do_ppl, dokp, & - gapw, gapw_xc, gauxc_model_none, just_energy_xc, lrigpw, my_print, & - native_grid_diagnostics, native_grid_use_cuda, native_skala_restore_exc, rigpw, & - use_gauxc_matrix, use_virial + gapw, gapw_xc, just_energy_xc, lrigpw, my_print, native_grid_diagnostics, & + native_grid_use_cuda, native_skala_restore_exc, rigpw, use_gauxc_matrix, use_virial LOGICAL, SAVE :: native_grid_cpu_kpoints_warned = .FALSE. REAL(KIND=dp) :: ecore_ppl, edisp, ee_ener, ekin_mol, & mulliken_order_p, & @@ -577,7 +575,7 @@ CONTAINS CALL admm_mo_calc_rho_aux(qs_env) END IF END IF - ELSE IF (dft_control%do_admm_dm) THEN + ELSEIF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF @@ -924,19 +922,12 @@ CONTAINS NULLIFY (rho1) IF (dft_control%use_gauxc .AND. (gapw .OR. gapw_xc) .AND. & .NOT. xc_section_uses_native_skala_grid(xc_section)) THEN - gauxc_model_none = .FALSE. - gauxc_section => get_gauxc_section(xc_section) - IF (ASSOCIATED(gauxc_section)) THEN - CALL section_vals_val_get(gauxc_section, "MODEL", c_val=gauxc_model_name) - gauxc_model_name = ADJUSTL(gauxc_model_name) - CALL uppercase(gauxc_model_name) - gauxc_model_none = (TRIM(gauxc_model_name) == "" .OR. & - TRIM(gauxc_model_name) == "NONE") - END IF - IF (gauxc_model_none .AND. & - (gapw_xc .OR. gauxc_gapw_has_paw_pseudopotentials(qs_kind_set))) THEN - CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) - END IF + ! Molecular GauXC evaluates the XC term outside xc_derivatives. + ! The accurate-XCINT force correction would otherwise try to + ! evaluate the GAUXC section through CP2K's local functional path. + ! Native-grid SKALA can provide this correction through the + ! CP2K grid path and needs it for GAPW_XC force consistency. + CONTINUE ELSE CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) END IF @@ -1093,7 +1084,7 @@ CONTAINS ELSE CALL admm_mo_merge_ks_matrix(qs_env) END IF - ELSE IF (dft_control%do_admm_dm) THEN + ELSEIF (dft_control%do_admm_dm) THEN CALL admm_dm_merge_ks_matrix(qs_env) END IF @@ -1171,9 +1162,8 @@ CONTAINS IF (native_skala_restore_exc) energy%total = native_skala_total_scf - IF (abnormal_value(energy%total)) THEN + IF (abnormal_value(energy%total)) & CPABORT("KS energy is an abnormal value (NaN/Inf).") - END IF ! Print detailed energy IF (my_print) THEN @@ -1449,9 +1439,8 @@ CONTAINS END IF ! kinetic energy - IF (ASSOCIATED(matrixkp_t)) THEN + IF (ASSOCIATED(matrixkp_t)) & CALL calculate_ptrace(matrixkp_t, rho_ao_kp, energy%kinetic, dft_control%nspins) - END IF CALL timestop(handle) END SUBROUTINE evaluate_core_matrix_traces @@ -1484,12 +1473,12 @@ CONTAINS calculate_forces=calculate_forces, & just_energy=just_energy) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_ks_matrix(qs_env, & calculate_forces=calculate_forces, & just_energy=just_energy) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, & calculate_forces=calculate_forces, & diff --git a/src/qs_ks_types.F b/src/qs_ks_types.F index 0f6c029414..73e953562b 100644 --- a/src/qs_ks_types.F +++ b/src/qs_ks_types.F @@ -621,9 +621,8 @@ CONTAINS IF (PRESENT(potential_changed)) ks_env%potential_changed = potential_changed IF (PRESENT(forces_up_to_date)) ks_env%forces_up_to_date = forces_up_to_date IF (PRESENT(complex_ks)) ks_env%complex_ks = complex_ks - IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) THEN + IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) & ks_env%forces_up_to_date = .FALSE. - END IF IF (PRESENT(exc_accint)) ks_env%exc_accint = exc_accint IF (PRESENT(v_hartree_rspace)) ks_env%v_hartree_rspace => v_hartree_rspace @@ -764,12 +763,10 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - END IF - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) - END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -778,15 +775,12 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%distribution_2d)) THEN + IF (ASSOCIATED(ks_env%distribution_2d)) & CALL distribution_2d_release(ks_env%distribution_2d) - END IF - IF (ASSOCIATED(ks_env%task_list)) THEN + IF (ASSOCIATED(ks_env%task_list)) & CALL deallocate_task_list(ks_env%task_list) - END IF - IF (ASSOCIATED(ks_env%task_list_soft)) THEN + IF (ASSOCIATED(ks_env%task_list_soft)) & CALL deallocate_task_list(ks_env%task_list_soft) - END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() @@ -875,12 +869,10 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - END IF - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) - END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -889,12 +881,10 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%task_list)) THEN + IF (ASSOCIATED(ks_env%task_list)) & CALL deallocate_task_list(ks_env%task_list) - END IF - IF (ASSOCIATED(ks_env%task_list_soft)) THEN + IF (ASSOCIATED(ks_env%task_list_soft)) & CALL deallocate_task_list(ks_env%task_list_soft) - END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index 00c65cf2cd..98755af9bf 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -789,9 +789,8 @@ CONTAINS IF (dft_control%sic_method_id == sic_none) RETURN IF (dft_control%sic_method_id == sic_eo) RETURN - IF (dft_control%qs_control%gapw) THEN + IF (dft_control%qs_control%gapw) & CPABORT("sic and GAPW not yet compatible") - END IF ! OK, right now we like two spins to do sic, could be relaxed for AD CPASSERT(dft_control%nspins == 2) @@ -1088,7 +1087,7 @@ CONTAINS "Exchange-correlation energy: ", energy%exc + energy%exc_aux_fit END IF ELSE - !ZMP to print some variables at each step +!ZMP to print some variables at each step IF (dft_control%apply_external_density) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T61,F20.10))") & "DOING ZMP CALCULATION FROM EXTERNAL DENSITY " @@ -1132,22 +1131,18 @@ CONTAINS "Integral of the (density * v_xc): ", energy%exc END IF - IF (energy%e_hartree /= 0.0_dp) THEN + IF (energy%e_hartree /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Coulomb (electron-electron) energy: ", energy%e_hartree - END IF - IF (energy%dispersion /= 0.0_dp) THEN + "Coulomb (electron-electron) energy: ", energy%e_hartree + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Dispersion energy: ", energy%dispersion - END IF - IF (energy%efield /= 0.0_dp) THEN + "Dispersion energy: ", energy%dispersion + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Electric field interaction energy: ", energy%efield - END IF - IF (energy%gcp /= 0.0_dp) THEN + "Electric field interaction energy: ", energy%efield + IF (energy%gcp /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "gCP energy: ", energy%gcp - END IF + "gCP energy: ", energy%gcp IF (dft_control%qs_control%gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T61,F20.10))") & "GAPW| Exc from hard and soft atomic rho1: ", energy%exc1 + energy%exc1_aux_fit, & @@ -1535,7 +1530,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1639,7 +1634,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1677,7 +1672,7 @@ CONTAINS IF (calculate_forces) THEN CALL calculate_lri_forces(lri_env, lri_density, qs_env, rho_ao_kp, atomic_kind_set) END IF - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN CALL get_qs_env(qs_env, matrix_s=smat) DO ispin = 1, nspins CALL calculate_ri_ks_matrix(lri_env, lri_v_int, ks_matrix(ispin, 1)%matrix, & diff --git a/src/qs_kubo_transport.F b/src/qs_kubo_transport.F index 68825aecb2..8ec3525d01 100644 --- a/src/qs_kubo_transport.F +++ b/src/qs_kubo_transport.F @@ -193,7 +193,7 @@ CONTAINS END IF IF (ALL(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "CP2K canonical MOs" - ELSE IF (ANY(reused_mos)) THEN + ELSEIF (ANY(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "mixed canonical/internal" ELSE WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "internal diagonalization" @@ -708,7 +708,7 @@ CONTAINS x = (eig - mu)/kT IF (x > 80.0_dp) THEN occ = 0.0_dp - ELSE IF (x < -80.0_dp) THEN + ELSEIF (x < -80.0_dp) THEN occ = maxocc ELSE occ = maxocc/(1.0_dp + EXP(x)) diff --git a/src/qs_linres_atom_current.F b/src/qs_linres_atom_current.F index a258a30e77..43eee3ff8c 100644 --- a/src/qs_linres_atom_current.F +++ b/src/qs_linres_atom_current.F @@ -266,11 +266,16 @@ CONTAINS NULLIFY (basis_1c_set, jp_RARnu, jp2_RARnu) ALLOCATE (a_block(nspins), b_block(nspins), c_block(nspins), d_block(nspins), & - jp_RARnu(nspins), jp2_RARnu(nspins)) + jp_RARnu(nspins), jp2_RARnu(nspins), & + STAT=istat) + CPASSERT(istat == 0) ALLOCATE (a_matrix(max_nsgf, max_nsgf), b_matrix(max_nsgf, max_nsgf), & - c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf)) - ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC)) + c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf), & + STAT=istat) + CPASSERT(istat == 0) + ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC), STAT=istat) + CPASSERT(istat == 0) !$OMP SINGLE !$ ALLOCATE (alloc_lock(natom)) @@ -597,9 +602,8 @@ CONTAINS END IF CALL para_env%sum(tmp_coeff) - IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) THEN + IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) & nbr_dbl = nbr_dbl + 8.0_dp*REAL(SIZE(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef), dp) - END IF END DO ! ispin END DO ! iat diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index a0f155514c..400cc30712 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -1024,9 +1024,8 @@ CONTAINS IF (do_igaim) CALL dbcsr_get_block_p(matrix=deltajp_d(1)%matrix, row=brow, col=bcol, & block=jp_block_d, found=den_found) - IF (.NOT. ASSOCIATED(jp_block_a)) THEN + IF (.NOT. ASSOCIATED(jp_block_a)) & CPABORT("p_block not associated in deltap") - END IF iatom_old = iatom jatom_old = jatom diff --git a/src/qs_linres_current_utils.F b/src/qs_linres_current_utils.F index 49c842e78f..b31ce717f5 100644 --- a/src/qs_linres_current_utils.F +++ b/src/qs_linres_current_utils.F @@ -794,9 +794,8 @@ CONTAINS current_env%do_selected_states = n_rep > 0 ! ! for the moment selected states doesnt work with the preconditioner FULL_ALL - IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) THEN + IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) & CPABORT("Selected states doesnt work with the preconditioner FULL_ALL") - END IF ! ! NULLIFY (current_env%selected_states_on_atom_list) @@ -1161,7 +1160,7 @@ CONTAINS REPEAT(' ', 20 - LEN_TRIM(current_env%orb_center_name))//TRIM(current_env%orb_center_name) IF (current_env%orb_center == current_orb_center_common) THEN WRITE (output_unit, "(T2,A,T50,3F10.6)") "CURRENT| Common center", common_center(1:3) - ELSE IF (current_env%orb_center == current_orb_center_box) THEN + ELSEIF (current_env%orb_center == current_orb_center_box) THEN WRITE (output_unit, "(T2,A,T60,3I5)") "CURRENT| Nbr boxes in each direction", nbox(1:3) END IF ! diff --git a/src/qs_linres_epr_nablavks.F b/src/qs_linres_epr_nablavks.F index 6761fb1794..9a571ba003 100644 --- a/src/qs_linres_epr_nablavks.F +++ b/src/qs_linres_epr_nablavks.F @@ -631,7 +631,7 @@ CONTAINS rap(1) = MODULO(rap(1), cell%hmat(1, 1)) - cell%hmat(1, 1)/2._dp rap(2) = MODULO(rap(2), cell%hmat(2, 2)) - cell%hmat(2, 2)/2._dp rap(3) = MODULO(rap(3), cell%hmat(3, 3)) - cell%hmat(3, 3)/2._dp - sqrt_rap = NORM2(rap) + sqrt_rap = SQRT(DOT_PRODUCT(rap, rap)) exp_rap = EXP(-alpha*sqrt_rap**2) sqrt_rap = MAX(sqrt_rap, 1.e-10_dp) ! d_x diff --git a/src/qs_linres_issc_utils.F b/src/qs_linres_issc_utils.F index 44ed32e9f2..c02149d74f 100644 --- a/src/qs_linres_issc_utils.F +++ b/src/qs_linres_issc_utils.F @@ -200,8 +200,11 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) + !CALL cp_fm_to_fm(p_psi0(ispin,ijdir)%matrix, psi1(ispin)) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! + !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(efg_psi0(ispin, ijdir), h1_psi0(ispin)) END DO @@ -220,6 +223,18 @@ CONTAINS chk = chk + fro END DO ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_efg',& + ! idir=ijdir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -266,6 +281,18 @@ CONTAINS chk = chk + fro END DO ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_pso',& + ! idir=idir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -287,8 +314,11 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) + !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! + !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(fc_psi0(ispin), h1_psi0(ispin)) END DO @@ -307,6 +337,18 @@ CONTAINS chk = chk + fro END DO ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_pso',& + ! idir=idir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -352,6 +394,20 @@ CONTAINS fro = cp_fm_frobenius_norm(psi1(ispin)) chk = chk + fro END DO + ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_pso',& + ! idir=idir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! + ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" END IF @@ -544,6 +600,27 @@ CONTAINS ! !>>>>> for debugging we compute here the polarizability and NOT the DSO term! IF (do_dso .AND. iatom == natom .AND. jatom == natom) THEN + ! + ! build the integral for the jatom + !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(4)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(5)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(6)%matrix,0.0_dp) + !CALL build_dso_matrix(qs_env,matrix_dso,r_i,r_j) + !DO ixyz = 1,6 + ! CALL cp_sm_fm_multiply(matrix_dso(ixyz)%matrix,mo_coeff,& + ! & fc_psi0(ispin),ncol=nmo,& ! fc_psi0 a buffer + ! & alpha=1.0_dp,beta=0.0_dp) + ! CALL cp_fm_trace(fc_psi0(ispin),mo_coeff,buf) + ! issc_dso = 2.0_dp * maxocc * facdso * buf + ! issc(ixyz,jxyz,iatom,jatom,4) = issc_dso + !ENDDO + !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + !CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1) DO ixyz = 1, 3 CALL cp_dbcsr_sm_fm_multiply(matrix_dso(ixyz)%matrix, mo_coeff, & fc_psi0(ispin), ncol=nmo,& ! fc_psi0 a buffer @@ -702,9 +779,9 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_env_init' - INTEGER :: handle, iatom, idir, ini, ir, ispin, m, & - n, n_rep, nao, natom, nspins, & - output_unit + INTEGER :: handle, iatom, idir, ini, ir, ispin, & + istat, m, n, n_rep, nao, natom, & + nspins, output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf INTEGER, DIMENSION(:), POINTER :: list, row_blk_sizes LOGICAL :: gapw @@ -764,10 +841,9 @@ CONTAINS natom = SIZE(particle_set, 1) ! ! check that the psi0 are localized and you have all the centers - IF (.NOT. linres_control%localized_psi0) THEN + IF (.NOT. linres_control%localized_psi0) & CALL cp_warn(__LOCATION__, 'To get indirect spin-spin coupling parameters within '// & 'PBC you need to localize zero order orbitals') - END IF ! ! ! read terms need to be calculated @@ -800,7 +876,8 @@ CONTAINS END DO ! IF (.NOT. ASSOCIATED(issc_env%issc_on_atom_list)) THEN - ALLOCATE (issc_env%issc_on_atom_list(natom)) + ALLOCATE (issc_env%issc_on_atom_list(natom), STAT=istat) + CPASSERT(istat == 0) DO iatom = 1, natom issc_env%issc_on_atom_list(iatom) = iatom END DO @@ -810,15 +887,20 @@ CONTAINS ! ! Initialize the issc tensor ALLOCATE (issc_env%issc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & - issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4)) + issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & + STAT=istat) + CPASSERT(istat == 0) issc_env%issc(:, :, :, :, :) = 0.0_dp issc_env%issc_loc(:, :, :, :, :) = 0.0_dp ! ! allocation ALLOCATE (issc_env%efg_psi0(nspins, 6), issc_env%pso_psi0(nspins, 3), issc_env%fc_psi0(nspins), & issc_env%psi1_efg(nspins, 6), issc_env%psi1_pso(nspins, 3), issc_env%psi1_fc(nspins), & - issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3)) + issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3), & + STAT=istat) + CPASSERT(istat == 0) DO ispin = 1, nspins + !mo_coeff => current_env%psi0_order(ispin)%matrix CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff, ncol_global=m, nrow_global=nao) diff --git a/src/qs_linres_kernel.F b/src/qs_linres_kernel.F index 82abe2463a..c9ac0c1255 100644 --- a/src/qs_linres_kernel.F +++ b/src/qs_linres_kernel.F @@ -142,9 +142,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Linear response not available with SE methods") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("Linear response not available with DFTB") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL apply_op_2_xtb(qs_env, p_env) ELSE CALL apply_op_2_dft(qs_env, p_env) @@ -278,9 +278,8 @@ CONTAINS CALL auxbas_pw_pool%create_pw(v_hartree_gspace) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) THEN + IF (gapw .OR. gapw_xc) & CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) - END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -445,9 +444,8 @@ CONTAINS END IF IF (lrigpw) THEN - IF (ASSOCIATED(v_xc_tau)) THEN + IF (ASSOCIATED(v_xc_tau)) & CPABORT("metaGGA-functionals not supported with LRI!") - END IF lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind) @@ -508,7 +506,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=.FALSE., tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) @@ -572,7 +570,7 @@ CONTAINS REAL(dp), ALLOCATABLE, DIMENSION(:) :: mcharge, mcharge1 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: aocg, aocg1, charges, charges1 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: pmat, rho_ao + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: rho_ao TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_p, matrix_p1, matrix_s TYPE(dft_control_type), POINTER :: dft_control TYPE(linres_control_type), POINTER :: linres_control @@ -630,7 +628,6 @@ CONTAINS aocg1 = 0.0_dp CALL ao_charges(matrix_p, matrix_s, aocg, para_env) CALL ao_charges(matrix_p1, matrix_s, aocg1, para_env) - IF (nspins == 2) aocg1 = 0.5_dp*aocg1 DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=na) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) @@ -651,8 +648,7 @@ CONTAINS mcharge1(iatom) = SUM(charges1(iatom, :)) END DO ! Coulomb Kernel - pmat => matrix_p1(:, 1) - CALL xtb_coulomb_hessian(qs_env, p_env%kpp1, charges1, mcharge1, mcharge, pmat) + CALL xtb_coulomb_hessian(qs_env, p_env%kpp1, charges1, mcharge1, mcharge) ! DEALLOCATE (charges, mcharge, charges1, mcharge1) END IF diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index ad5d4d0c72..f730cfc2cf 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -642,7 +642,7 @@ CONTAINS CALL qs_rho_update_rho(rho, qs_env=qs_env) ! that could be called before IF (dft_control%qs_control%gapw) THEN CALL prepare_gapw_den(qs_env) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL prepare_gapw_den(qs_env, do_rho0=.FALSE.) END IF diff --git a/src/qs_linres_module.F b/src/qs_linres_module.F index ff4d100b67..4da28f2d80 100644 --- a/src/qs_linres_module.F +++ b/src/qs_linres_module.F @@ -202,9 +202,8 @@ CONTAINS vcd_env%apt_total_nvpt(:, :, vcd_env%dcdr_env%lambda) = & vcd_env%apt_el_nvpt(:, :, vcd_env%dcdr_env%lambda) + vcd_env%apt_nuc_nvpt(:, :, vcd_env%dcdr_env%lambda) - IF (vcd_env%do_mfp) THEN + IF (vcd_env%do_mfp) & vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda) = vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda)*4._dp - END IF END DO !lambda diff --git a/src/qs_linres_op.F b/src/qs_linres_op.F index ed9e9fe2b8..ad52669b40 100644 --- a/src/qs_linres_op.F +++ b/src/qs_linres_op.F @@ -1276,7 +1276,7 @@ CONTAINS IF ((b == a + 1 .OR. b == a - 2) .AND. (c == b + 1 .OR. c == b - 2)) THEN factor = 1.0_dp - ELSE IF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN + ELSEIF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN factor = -1.0_dp END IF @@ -1298,9 +1298,9 @@ CONTAINS l(1:3) = 0 IF (ii == 0) THEN l(iii) = 1 - ELSE IF (iii == 0) THEN + ELSEIF (iii == 0) THEN l(ii) = 1 - ELSE IF (ii == iii) THEN + ELSEIF (ii == iii) THEN l(ii) = 2 i = coset(l(1), l(2), l(3)) - 1 ELSE @@ -1324,10 +1324,10 @@ CONTAINS IF (i1 == 1) THEN i2 = 2 i3 = 3 - ELSE IF (i1 == 2) THEN + ELSEIF (i1 == 2) THEN i2 = 3 i3 = 1 - ELSE IF (i1 == 3) THEN + ELSEIF (i1 == 3) THEN i2 = 1 i3 = 2 ELSE @@ -1347,9 +1347,9 @@ CONTAINS IF ((i1 + i2) == 3) THEN i3 = 3 - ELSE IF ((i1 + i2) == 4) THEN + ELSEIF ((i1 + i2) == 4) THEN i3 = 2 - ELSE IF ((i1 + i2) == 5) THEN + ELSEIF ((i1 + i2) == 5) THEN i3 = 1 ELSE END IF diff --git a/src/qs_loc_main.F b/src/qs_loc_main.F index f929aacda9..356f10d813 100644 --- a/src/qs_loc_main.F +++ b/src/qs_loc_main.F @@ -401,7 +401,7 @@ CONTAINS CALL cp_fm_release(tmp_fm) CALL cp_fm_release(tmp_fm_1) CALL cp_fm_struct_release(tmp_fm_struct) - ELSE IF (my_guess_wan) THEN + ELSEIF (my_guess_wan) THEN nguess = localized_wfn_control%nguess(myspin) ALLOCATE (tmp_mat(nao, nguess)) CALL cp_fm_get_submatrix(moloc_coeff(myspin), tmp_mat, 1, 1, nao, nguess) diff --git a/src/qs_loc_states.F b/src/qs_loc_states.F index 8163a283a2..0c9d90a473 100644 --- a/src/qs_loc_states.F +++ b/src/qs_loc_states.F @@ -133,21 +133,16 @@ CONTAINS IF (qs_loc_env%do_localize) THEN ! Do the Real localization.. - IF (output_unit > 0 .AND. do_homo) THEN + IF (output_unit > 0 .AND. do_homo) WRITE (output_unit, "(/,T2,A,I3)") & + "LOCALIZATION| Computing localization properties "// & + "for OCCUPIED ORBITALS. Spin:", ispin + IF (output_unit > 0 .AND. do_mixed) WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & + "LOCALIZATION| Computing localization properties for OCCUPIED, ", & + "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin + IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) & WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for OCCUPIED ORBITALS. Spin:", ispin - END IF - IF (output_unit > 0 .AND. do_mixed) THEN - WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & - "LOCALIZATION| Computing localization properties for OCCUPIED, ", & - "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin - END IF - IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) THEN - WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for UNOCCUPIED ORBITALS. Spin:", ispin - END IF + "LOCALIZATION| Computing localization properties "// & + "for UNOCCUPIED ORBITALS. Spin:", ispin scenter => qs_loc_env%localized_wfn_control%centers_set(ispin)%array diff --git a/src/qs_loc_types.F b/src/qs_loc_types.F index 4da4fc2c07..e22f26abb8 100644 --- a/src/qs_loc_types.F +++ b/src/qs_loc_types.F @@ -196,9 +196,8 @@ CONTAINS INTEGER :: i, ii, j IF (ASSOCIATED(qs_loc_env%cell)) CALL cell_release(qs_loc_env%cell) - IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN + IF (ASSOCIATED(qs_loc_env%local_molecules)) & CALL distribution_1d_release(qs_loc_env%local_molecules) - END IF IF (ASSOCIATED(qs_loc_env%localized_wfn_control)) THEN CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control) END IF @@ -337,9 +336,8 @@ CONTAINS IF (PRESENT(cell)) cell => qs_loc_env%cell IF (PRESENT(moloc_coeff)) moloc_coeff => qs_loc_env%moloc_coeff IF (PRESENT(local_molecules)) local_molecules => qs_loc_env%local_molecules - IF (PRESENT(localized_wfn_control)) THEN + IF (PRESENT(localized_wfn_control)) & localized_wfn_control => qs_loc_env%localized_wfn_control - END IF IF (PRESENT(op_sm_set)) op_sm_set => qs_loc_env%op_sm_set IF (PRESENT(op_fm_set)) op_fm_set => qs_loc_env%op_fm_set IF (PRESENT(para_env)) para_env => qs_loc_env%para_env @@ -394,9 +392,8 @@ CONTAINS IF (PRESENT(local_molecules)) THEN CALL distribution_1d_retain(local_molecules) - IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN + IF (ASSOCIATED(qs_loc_env%local_molecules)) & CALL distribution_1d_release(qs_loc_env%local_molecules) - END IF qs_loc_env%local_molecules => local_molecules END IF diff --git a/src/qs_loc_utils.F b/src/qs_loc_utils.F index 3a8cd53d04..988b9b6212 100644 --- a/src/qs_loc_utils.F +++ b/src/qs_loc_utils.F @@ -340,11 +340,10 @@ CONTAINS IF (localized_wfn_control%do_homo) THEN occ_imo = occupations(imo) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) THEN + IF (localized_wfn_control%localization_method /= do_loc_none) & CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") - END IF END IF END IF ! Take the imo vector from the full set and copy in the imoloc vector of the subset @@ -358,11 +357,10 @@ CONTAINS my_occ = occupations(lb) occ_imo = occupations(ub) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) THEN + IF (localized_wfn_control%localization_method /= do_loc_none) & CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") - END IF END IF nmosub = localized_wfn_control%nloc_states(ispin) @@ -416,7 +414,7 @@ CONTAINS END DO END DO - ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN natoms = SIZE(qs_loc_env%particle_set, 1) ALLOCATE (qs_loc_env%op_fm_set(natoms, 1)) CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=natoms) @@ -441,7 +439,7 @@ CONTAINS CALL get_berry_operator(qs_loc_env, qs_env) - ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN !! here we don't have to do anything !! CALL get_pipek_mezey_operator ( qs_loc_env, qs_env ) @@ -759,7 +757,7 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSE IF (my_do_mixed) THEN + ELSEIF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -874,13 +872,12 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN fname_key = "LOCHOMO_RESTART_FILE_NAME" - ELSE IF (my_do_mixed) THEN + ELSEIF (my_do_mixed) THEN fname_key = "LOCMIXD_RESTART_FILE_NAME" ELSE fname_key = "LOCLUMO_RESTART_FILE_NAME" - IF (.NOT. PRESENT(evals)) THEN + IF (.NOT. PRESENT(evals)) & CPABORT("Missing argument to localize unoccupied states.") - END IF END IF file_exists = .FALSE. @@ -892,7 +889,7 @@ CONTAINS print_key => section_vals_get_subs_vals(section2, "LOC_RESTART") IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSE IF (my_do_mixed) THEN + ELSEIF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -917,10 +914,8 @@ CONTAINS READ (rst_unit) qs_loc_env%localized_wfn_control%nloc_states END IF ELSE - IF (output_unit > 0) THEN - WRITE (output_unit, "(/,T10,A)") & - "Restart file not available filename=<"//TRIM(filename)//'>' - END IF + IF (output_unit > 0) WRITE (output_unit, "(/,T10,A)") & + "Restart file not available filename=<"//TRIM(filename)//'>' END IF CALL para_env%bcast(file_exists) @@ -961,16 +956,14 @@ CONTAINS eig_read = 0.0_dp READ (rst_unit) eig_read(1:nmo_read) END IF - IF (nmo_read < nmo) THEN + IF (nmo_read < nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. ") - END IF - IF (nmo_read > nmo) THEN + IF (nmo_read > nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") - END IF nmo = MIN(nmo, nmo_read) IF (do_homo .OR. do_mixed) THEN @@ -1193,6 +1186,7 @@ CONTAINS maxocc=maxocc) ! Get eigenstates (only needed if not already calculated before) IF ((.NOT. my_do_mo_cubes) & + ! .OR. section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO")==0)& .AND. my_do_homo .AND. ASSOCIATED(qs_env%scf_env) & .AND. qs_env%scf_env%method == ot_method_nr .AND. (.NOT. dft_control%restricted)) THEN CALL make_mo_eig(mos, nspin, ks_rmpv, scf_control, mo_derivs) @@ -1213,12 +1207,11 @@ CONTAINS localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = ilast_intocc IF (nmoloc(ispin) /= n_mo(ispin)) THEN - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - ilast_intocc, " occupied orbitals are localized,", " with energies from ", & - mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." - END IF + "LOCALIZATION| Spin ", ispin, " The first ", & + ilast_intocc, " occupied orbitals are localized,", " with energies from ", & + mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." END IF ELSE IF (localized_wfn_control%set_of_states == energy_loc_range .AND. my_do_homo) THEN ilow = 0 @@ -1250,12 +1243,11 @@ CONTAINS nmoloc(ispin) = n_mo(ispin) - homo localized_wfn_control%lu_bound_states(1, ispin) = homo + 1 localized_wfn_control%lu_bound_states(2, ispin) = n_mo(ispin) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & - mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." - END IF + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & + mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." ELSE IF (localized_wfn_control%set_of_states == state_loc_mixed) THEN nextra = localized_wfn_control%nextra nocc = homo @@ -1270,15 +1262,14 @@ CONTAINS nmoloc(ispin) = nocc + nextra localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = nmoloc(ispin) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,I6,/,T15,A,I6,/,T15,A,I6,/,T15,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " orbitals are localized.", & - "Number of fully occupied MOs: ", nocc, & - "Number of partially occupied MOs: ", npocc, & - "Number of extra degrees of freedom: ", nextra, & - "Excess charge: ", my_tot_zeff_corr, " electrons" - END IF + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " orbitals are localized.", & + "Number of fully occupied MOs: ", nocc, & + "Number of partially occupied MOs: ", npocc, & + "Number of extra degrees of freedom: ", nextra, & + "Excess charge: ", my_tot_zeff_corr, " electrons" ELSE nmoloc(ispin) = MIN(localized_wfn_control%nloc_states(1), n_mo(ispin)) IF (output_unit > 0 .AND. my_do_homo) WRITE (output_unit, "(/,T2,A,I4,A,I6,A)") "LOCALIZATION| Spin ", ispin, & diff --git a/src/qs_local_rho_types.F b/src/qs_local_rho_types.F index 97b456cf64..2efbf1089a 100644 --- a/src/qs_local_rho_types.F +++ b/src/qs_local_rho_types.F @@ -156,9 +156,12 @@ CONTAINS nkind = SIZE(rhoz_set) DO ikind = 1, nkind - IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) DEALLOCATE (rhoz_set(ikind)%r_coef) - IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) DEALLOCATE (rhoz_set(ikind)%dr_coef) - IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) DEALLOCATE (rhoz_set(ikind)%vr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) & + DEALLOCATE (rhoz_set(ikind)%r_coef) + IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) & + DEALLOCATE (rhoz_set(ikind)%dr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) & + DEALLOCATE (rhoz_set(ikind)%vr_coef) END DO DEALLOCATE (rhoz_set) diff --git a/src/qs_localization_methods.F b/src/qs_localization_methods.F index 6cc9eebe2f..97b0e6c4b8 100644 --- a/src/qs_localization_methods.F +++ b/src/qs_localization_methods.F @@ -162,6 +162,7 @@ CONTAINS END DO END DO CALL C%matrix_struct%para_env%sum(f2) + !write(*,*) 'qs_localize: f_2=',f2 !------------------------------------------------------------------- ! compute the derivative of f_2 ! f_2(x)=(x^2+eps)^1/2 @@ -178,6 +179,7 @@ CONTAINS !------------------------------------------------------------------- ! gnorm = cp_fm_frobenius_norm(G) + !write(*,*) 'qs_localize: norm(G)=',gnorm ! ! rescale for steepest descent CALL cp_fm_scale(-alpha, G) @@ -189,6 +191,7 @@ CONTAINS expfactor = 1.0_dp CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, G) tnorm = cp_fm_frobenius_norm(G) + !write(*,*) 'Taylor expansion i=',1,' norm(X^i)/i!=',tnorm IF (tnorm > 1.0E-10_dp) THEN ! other orders CALL cp_fm_to_fm(G, Gp1) @@ -200,6 +203,7 @@ CONTAINS expfactor = expfactor/REAL(i, KIND=dp) CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, Gp1) tnorm = cp_fm_frobenius_norm(Gp1) + !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',tnorm*expfactor IF (tnorm*expfactor < 1.0E-10_dp) EXIT END DO END IF @@ -215,6 +219,7 @@ CONTAINS ! ! Are we done? sweeps = istep + !IF(gnorm<=grad_thresh.AND.ABS((f2-f2old)/f2)<=f2_thresh.AND.istep>1) THEN IF (ABS((f2 - f2old)/f2) <= eps .AND. istep > 1) THEN converged = .TRUE. EXIT @@ -226,6 +231,23 @@ CONTAINS ! ! Print the final result IF (output_unit > 0) WRITE (output_unit, '(A,E16.10)') ' sparseness function f2 = ', f2 + ! + ! sparsity + !DO i=1,size(thresh,1) + ! gnorm = 0.0_dp + ! DO o=1,ncol_local + ! DO p=1,nrow_local + ! IF(ABS(C%local_data(p,o))>thresh(i)) THEN + ! gnorm = gnorm + 1.0_dp + ! ENDIF + ! ENDDO + ! ENDDO + ! CALL C%matrix_struct%para_env%sum(gnorm) + ! IF(output_unit>0) THEN + ! WRITE(output_unit,*) 'qs_localize: ratio2=',gnorm / ( REAL(k,KIND=dp)*REAL(n,KIND=dp) ),thresh(i) + ! ENDIF + !ENDDO + ! ! deallocate CALL cp_fm_struct_release(fm_struct_k_k) CALL cp_fm_release(CTmp) @@ -667,7 +689,7 @@ CONTAINS IF (do_cinit_random) THEN icinit = 1 do_U_guess_mo = .FALSE. - ELSE IF (do_cinit_mo) THEN + ELSEIF (do_cinit_mo) THEN icinit = 2 do_U_guess_mo = .TRUE. END IF @@ -1139,7 +1161,7 @@ CONTAINS IF ((ABS(ds) < 1.0E-10_dp) .AND. (lsl == 1)) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha - ELSE IF (ABS(ds) > 10.0_dp) THEN + ELSEIF (ABS(ds) > 10.0_dp) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha ELSE @@ -1327,7 +1349,7 @@ CONTAINS IF (ABS(b12) > 1.e-10_dp) THEN ratio = -a12/b12 theta = 0.25_dp*ATAN(ratio) - ELSE IF (ABS(b12) < 1.e-10_dp) THEN + ELSEIF (ABS(b12) < 1.e-10_dp) THEN b12 = 0.0_dp theta = 0.0_dp ELSE @@ -1975,6 +1997,14 @@ CONTAINS IF (new_direction) THEN ! energy converged up to machine precision ? line_searches = line_searches + 1 + ! DO i=1,line_search_count + ! write(15,*) pos(i),energy(i) + ! ENDDO + ! write(15,*) "" + ! CALL m_flush(15) + !write(16,*) evals(:) + !write(17,*) matrix_A%local_data(:,:) + !write(18,*) matrix_G%local_data(:,:) IF (output_unit > 0) THEN WRITE (output_unit, '(T5,I10,T18,I10,T31,2F20.6,F10.3)') line_searches, Iterations, Omega, tol, ds_min CALL m_flush(output_unit) @@ -2483,9 +2513,9 @@ CONTAINS COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: c_array_me, c_array_partner COMPLEX(KIND=dp), POINTER :: mii(:), mij(:), mjj(:) INTEGER :: i, idim, ii, ik, il1, il2, il_recv, il_recv_partner, ilow1, ilow2, ip, ip_has_i, & - ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istate, iu1, iu2, iup1, iup2, j, & - jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, ns_recv_from, & - ns_recv_partner + ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istat, istate, iu1, iu2, iup1, & + iup2, j, jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, & + ns_recv_from, ns_recv_partner INTEGER, ALLOCATABLE, DIMENSION(:) :: rcount, rdispl INTEGER, ALLOCATABLE, DIMENSION(:, :) :: list_pair LOGICAL :: should_stop @@ -2502,8 +2532,8 @@ CONTAINS ALLOCATE (mii(dim2), mij(dim2), mjj(dim2)) - ALLOCATE (rcount(para_env%num_pe)) - ALLOCATE (rdispl(para_env%num_pe)) + ALLOCATE (rcount(para_env%num_pe), STAT=istat) + ALLOCATE (rdispl(para_env%num_pe), STAT=istat) tolerance = 1.0e10_dp sweeps = 0 @@ -2675,6 +2705,7 @@ CONTAINS IF (ilow1 < ilow2) THEN ! no longer compiles in official sdgb: + !CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1, k), nstate, rmat_loc(1 + n1, 1), n1 + n2, 0.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, rmat_loc(1 + n1:, 1:n1), & n2, 0.0_dp, gmat(:, :), nstate) @@ -2684,6 +2715,7 @@ CONTAINS CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, & rmat_loc(1:, n2 + 1:), n1 + n2, 0.0_dp, gmat(:, :), nstate) ! no longer compiles in official sdgb: + !CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1, 1), nstate, rmat_loc(n2 + 1, n2 + 1), n1 + n2, 1.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1:, 1:), nstate, rmat_loc(n2 + 1:, n2 + 1:), & n1, 1.0_dp, gmat(:, :), nstate) @@ -2961,7 +2993,7 @@ CONTAINS list_pair(JJ, II) = i END DO IF (MOD(para_env%num_pe, 2) == 1) list_pair(2, npair) = -1 - ELSE IF (MOD(iperm, 2) == 0) THEN + ELSEIF (MOD(iperm, 2) == 0) THEN !..a type shift jj = list_pair(1, npair) DO I = npair, 3, -1 diff --git a/src/qs_mixing_utils.F b/src/qs_mixing_utils.F index b61e5251e4..d5869da8f0 100644 --- a/src/qs_mixing_utils.F +++ b/src/qs_mixing_utils.F @@ -188,7 +188,7 @@ CONTAINS CPASSERT(.NOT. mixing_store%gmix_p) IF (dft_control%qs_control%dftb) THEN max_shell = max_dftb_scc_vars - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN max_shell = max_xtb_scc_vars ELSE CPABORT('UNKNOWN METHOD') @@ -219,7 +219,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%pulay_matrix)) DEALLOCATE (mixing_store%pulay_matrix) ALLOCATE (mixing_store%pulay_matrix(nbuffer, nbuffer, nspins)) mixing_store%pulay_matrix = 0.0_dp - ELSE IF (mixing_method == broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr) THEN IF (ASSOCIATED(mixing_store%abroy)) DEALLOCATE (mixing_store%abroy) ALLOCATE (mixing_store%abroy(nbuffer, nbuffer)) mixing_store%abroy = 0.0_dp @@ -232,7 +232,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%ubroy)) DEALLOCATE (mixing_store%ubroy) ALLOCATE (mixing_store%ubroy(na, max_shell, nbuffer)) mixing_store%ubroy = 0.0_dp - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN CPABORT("multisecant_mixing not available") END IF ELSE @@ -588,7 +588,7 @@ CONTAINS END IF IF (mixing_method == gspace_mixing_nr) THEN - ELSE IF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN + ELSEIF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN IF (mixing_store%gmix_p .AND. PRESENT(rho_atom)) THEN DO ispin = 1, nspin DO iat = 1, natom @@ -613,7 +613,7 @@ CONTAINS END DO END DO END IF - ELSE IF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN DO ispin = 1, nspin IF (.NOT. ASSOCIATED(mixing_store%rhoin_old(ispin)%cc)) THEN ALLOCATE (mixing_store%rhoin_old(ispin)%cc(ng)) @@ -685,7 +685,7 @@ CONTAINS END DO IF (rho_g(1)%pw_grid%have_g0) mixing_store%p_metric(1) = bconst END IF - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN IF (.NOT. ASSOCIATED(mixing_store%ig_global_index)) THEN ALLOCATE (mixing_store%ig_global_index(ng)) END IF diff --git a/src/qs_mo_io.F b/src/qs_mo_io.F index 55c77ef141..4504787e02 100644 --- a/src/qs_mo_io.F +++ b/src/qs_mo_io.F @@ -346,7 +346,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -383,7 +383,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 @@ -754,9 +754,8 @@ CONTAINS IF (nao_read /= nao) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) & " READ RESTART : WARNING : DIFFERENT # AOs ", nao, nao_read - IF (PRESENT(rt_mos)) THEN + IF (PRESENT(rt_mos)) & CPABORT("To change basis is not possible. ") - END IF END IF READ (rst_unit) nset_info @@ -811,16 +810,14 @@ CONTAINS occ_read = 0.0_dp nmo = MIN(nmo, nmo_read) - IF (nmo_read < nmo) THEN + IF (nmo_read < nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. The MO set will be padded with zeros!") - END IF - IF (nmo_read > nmo) THEN + IF (nmo_read > nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") - END IF READ (rst_unit) eig_read(1:nmo_read), occ_read(1:nmo_read) mos(ispin)%eigenvalues(1:nmo) = eig_read(1:nmo) @@ -881,7 +878,7 @@ CONTAINS nshell=nshell, & l=l) minbas = .FALSE. - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset = 1 minbas = .TRUE. @@ -1329,16 +1326,14 @@ CONTAINS name = TRIM(energy_str)//", OCCUPATION NUMBERS, AND "// & TRIM(orbital_str)//" "//TRIM(vector_str) - IF (.NOT. my_final) THEN + IF (.NOT. my_final) & WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step - END IF ELSE IF (print_occup .OR. print_eigvals) THEN name = TRIM(energy_str)//" AND OCCUPATION NUMBERS" - IF (.NOT. my_final) THEN + IF (.NOT. my_final) & WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step - END IF END IF ! print_eigvecs ! Print headline diff --git a/src/qs_mo_occupation.F b/src/qs_mo_occupation.F index 209dcba053..38d815e707 100644 --- a/src/qs_mo_occupation.F +++ b/src/qs_mo_occupation.F @@ -155,11 +155,10 @@ CONTAINS CPWARN_IF(is_large, TRIM(method_label)//" smearing includes the first MO") is_large = ABS(all_occ(all_nmo)) > smear%eps_fermi_dirac - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF IF (.NOT. do_gce) THEN ! check that the total electron count is accurate is_large = (ABS(all_nelec - accurate_sum(all_occ(:))) > smear%eps_fermi_dirac*all_nelec) @@ -179,11 +178,6 @@ CONTAINS nelec_a = accurate_sum(occ_a(:)) nelec_b = accurate_sum(occ_b(:)) - lfomo_a = nmo_a + 1 - lfomo_b = nmo_b + 1 - homo_a = 0 - homo_b = 0 - DO i = 1, nmo_a IF (occ_a(i) < 1.0_dp) THEN lfomo_a = i @@ -348,15 +342,13 @@ CONTAINS multiplicity_old = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (mo_array(1)%nelectron >= mo_array(1)%nmo) THEN + IF (mo_array(1)%nelectron >= mo_array(1)%nmo) & CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") - END IF - IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) THEN + IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) & CALL cp_warn(__LOCATION__, "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") - END IF eigval_a => mo_array(1)%eigenvalues eigval_b => mo_array(2)%eigenvalues @@ -375,22 +367,20 @@ CONTAINS lumo_b = lumo_b + 1 END IF IF (lumo_a > mo_array(1)%nmo) THEN - IF (i /= nelec) THEN + IF (i /= nelec) & CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") - END IF IF (i < nelec) THEN lumo_a = lumo_a - 1 lumo_b = lumo_b + 1 END IF END IF IF (lumo_b > mo_array(2)%nmo) THEN - IF (lumo_b < lumo_a) THEN + IF (lumo_b < lumo_a) & CALL cp_warn(__LOCATION__, & "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") - END IF IF (i < nelec) THEN lumo_a = lumo_a + 1 lumo_b = lumo_b - 1 @@ -416,12 +406,11 @@ CONTAINS mo_array(2)%nelectron = mo_array(2)%homo multiplicity_new = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (multiplicity_new /= multiplicity_old) THEN + IF (multiplicity_new /= multiplicity_old) & CALL cp_warn(__LOCATION__, & "Multiplicity changed from "// & TRIM(ADJUSTL(cp_to_string(multiplicity_old)))//" to "// & TRIM(ADJUSTL(cp_to_string(multiplicity_new)))) - END IF IF (PRESENT(probe)) THEN CALL set_mo_occupation_1(mo_array(1), smear=smear, probe=probe) @@ -507,9 +496,8 @@ CONTAINS mo_set%occupation_numbers(1:nomo) = mo_set%maxocc IF (xas_estate > 0) mo_set%occupation_numbers(xas_estate) = occ_estate el_count = SUM(mo_set%occupation_numbers(1:nomo)) - IF (el_count > xas_nelectron) THEN + IF (el_count > xas_nelectron) & mo_set%occupation_numbers(nomo) = mo_set%occupation_numbers(nomo) - (el_count - xas_nelectron) - END IF el_count = SUM(mo_set%occupation_numbers(1:nomo)) is_large = ABS(el_count - xas_nelectron) > xas_nelectron*EPSILON(el_count) CPASSERT(.NOT. is_large) @@ -598,13 +586,13 @@ CONTAINS END DO nomo = nomo - irmo IF (mo_set%occupation_numbers(nomo) == 0.0_dp) nomo = nomo - 1 - ELSE IF (delectron < 0.0_dp) THEN + ELSEIF (delectron < 0.0_dp) THEN mo_set%occupation_numbers(nomo) = -delectron ELSE mo_set%occupation_numbers(nomo) = 0.0_dp nomo = nomo - 1 END IF - ELSE IF (total_zeff_corr > 0.0_dp) THEN + ELSEIF (total_zeff_corr > 0.0_dp) THEN ! add electron density to the mos delectron = total_zeff_corr - REAL(mo_set%maxocc, KIND=dp) IF (delectron > 0.0_dp) THEN @@ -667,9 +655,8 @@ CONTAINS END DO is_large = ABS(MAXVAL(mo_set%occupation_numbers) - mo_set%maxocc) > probe(1)%eps_hp ! this is not a real problem, but the temperature might be a bit large - IF (is_large) THEN + IF (is_large) & CPWARN("Hair-probes occupancy distribution includes the first MO") - END IF ! Find the highest (fractional) occupied MO which will be now the HOMO DO imo = nmo, mo_set%lfomo, -1 @@ -679,17 +666,15 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > probe(1)%eps_hp - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & "Hair-probes occupancy distribution includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > probe(1)%eps_hp*nelec) - IF (is_large) THEN + IF (is_large) & CPWARN("Total number of electrons is not accurate") - END IF END IF @@ -765,11 +750,10 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > smear%eps_fermi_dirac - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & "Fermi-Dirac smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -822,11 +806,10 @@ CONTAINS END IF END DO is_large = ABS(mo_set%occupation_numbers(nmo)) > smear%eps_fermi_dirac - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! Check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -843,11 +826,10 @@ CONTAINS END IF e2 = mo_set%eigenvalues(mo_set%homo) + 0.5_dp*smear%window_size - IF (e2 >= mo_set%eigenvalues(nmo)) THEN + IF (e2 >= mo_set%eigenvalues(nmo)) & CALL cp_warn(__LOCATION__, & "Energy window for smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! Find the lowest fractional occupied MO (LFOMO) DO imo = i_first, nomo diff --git a/src/qs_mom_methods.F b/src/qs_mom_methods.F index 9d5921eaab..29544e3795 100644 --- a/src/qs_mom_methods.F +++ b/src/qs_mom_methods.F @@ -89,9 +89,8 @@ CONTAINS ! Ensure that all orbital indices are positive integers. ! A special value '0' means 'disabled keyword', ! it must appear once to be interpreted in such a way - IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) THEN + IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) & CPABORT("MOM: all molecular orbital indices must be positive integer numbers") - END IF DEALLOCATE (tmp_iarr) END IF @@ -266,10 +265,9 @@ CONTAINS (mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccA) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccB) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occA) .AND. & - mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) THEN + mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) & CALL cp_abort(__LOCATION__, & "Duplicate orbital indices were found in the MOM section") - END IF ! ignore beta orbitals for spin-unpolarized calculations IF (nspins == 1 .AND. (scf_control%diagonalization%mom_deoccB(1) /= 0 & @@ -310,18 +308,16 @@ CONTAINS END DO ! proceed alpha orbitals - IF (nspins >= 1) THEN + IF (nspins >= 1) & CALL mom_reoccupy_orbitals(mos(1), & scf_control%diagonalization%mom_deoccA, & scf_control%diagonalization%mom_occA, 'alpha') - END IF ! proceed beta orbitals (if any) - IF (nspins >= 2) THEN + IF (nspins >= 2) & CALL mom_reoccupy_orbitals(mos(2), & scf_control%diagonalization%mom_deoccB, & scf_control%diagonalization%mom_occB, 'beta') - END IF ! recompute the density matrix if the molecular orbitals are here; ! otherwise do nothing to prevent zeroing out the density matrix @@ -396,10 +392,9 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. scf_control%diagonalization%mom_didguess) THEN + IF (.NOT. scf_control%diagonalization%mom_didguess) & CALL cp_abort(__LOCATION__, & "The current implementation of the maximum overlap method is incompatible with the initial SCF guess") - END IF ! number of spins == dft_control%nspins nspins = SIZE(matrix_ks) diff --git a/src/qs_moments.F b/src/qs_moments.F index c434f3ca8b..6a8ac14ccf 100644 --- a/src/qs_moments.F +++ b/src/qs_moments.F @@ -3361,9 +3361,8 @@ CONTAINS kpnts => section_vals_get_subs_vals(qs_env%input, "DFT%PRINT%MOMENTS%KPOINTS") CALL section_vals_get(kpset, explicit=explicit_kpset) CALL section_vals_get(kpnts, explicit=explicit_kpnts) - IF (explicit_kpset .AND. explicit_kpnts) then + IF (explicit_kpset .AND. explicit_kpnts) & CPABORT("Both KPOINT_SET and KPOINTS present in MOMENTS section") - end if IF (explicit_kpset) THEN CALL get_qs_env(qs_env, cell=cell) @@ -4012,9 +4011,8 @@ CONTAINS IF (ABS(energy_diff) <= eps_degenerate) CYCLE CALL cp_fm_get_element(moment_re, m, n, creal) CALL cp_fm_get_element(moment_im, m, n, cimag) - IF (para_env%is_source()) then + IF (para_env%is_source()) & dipole(ispin, ikp, i_dir, n, m) = CMPLX(creal, cimag, KIND=dp)/energy_diff - end if END DO END DO END DO diff --git a/src/qs_neighbor_list_types.F b/src/qs_neighbor_list_types.F index f85df43651..c77afac074 100644 --- a/src/qs_neighbor_list_types.F +++ b/src/qs_neighbor_list_types.F @@ -358,9 +358,8 @@ CONTAINS TYPE(neighbor_list_set_p_type), DIMENSION(:), & POINTER :: nl - IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) THEN + IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) & CPABORT("Parallel iterator calls must include 'mepos'") - END IF IF (PRESENT(mepos)) THEN me = mepos @@ -462,10 +461,10 @@ CONTAINS IF (iterator%inode >= iterator%nnode) THEN ! end of loop istat = 1 - ELSE IF (iterator%inode == 0) THEN + ELSEIF (iterator%inode == 0) THEN iterator%inode = 1 iterator%neighbor_node => first_node(iterator%neighbor_list) - ELSE IF (iterator%inode > 0) THEN + ELSEIF (iterator%inode > 0) THEN ! we can be sure that there is another node in this list iterator%inode = iterator%inode + 1 iterator%neighbor_node => iterator%neighbor_node%next_neighbor_node diff --git a/src/qs_neighbor_lists.F b/src/qs_neighbor_lists.F index b67e328c93..4c8e38cf4f 100644 --- a/src/qs_neighbor_lists.F +++ b/src/qs_neighbor_lists.F @@ -112,10 +112,6 @@ MODULE qs_neighbor_lists END TYPE local_atoms_type ! ************************************************************************************************** - TYPE local_lists - INTEGER, DIMENSION(:), POINTER :: list => NULL() - END TYPE local_lists - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_neighbor_lists' ! private counter, used to version qs neighbor lists @@ -434,7 +430,7 @@ CONTAINS IF (dokp) THEN ! no MIC for kpoints mic = .FALSE. - ELSE IF (nddo) THEN + ELSEIF (nddo) THEN ! enforce MIC for interaction lists in SE mic = .TRUE. END IF @@ -667,9 +663,8 @@ CONTAINS CALL pair_radius_setup(orb_present, orb_present, orb_radius, orb_radius, pair_radius_lb) DO jkind = 1, nkind DO ikind = 1, nkind - IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) THEN + IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) & pair_radius(ikind, jkind) = pair_radius_lb(ikind, jkind) - roperator - END IF END DO END DO ELSE @@ -952,7 +947,7 @@ CONTAINS qs_env%lri_env%soo_list => soo_list CALL write_neighbor_lists(soo_list, particle_set, cell, para_env, neighbor_list_section, & "/SOO_LIST", "soo_list", "ORBITAL ORBITAL (RI)") - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN ALLOCATE (ri_present(nkind), ri_radius(nkind)) ri_present = .FALSE. ri_radius = 0.0_dp @@ -1086,28 +1081,31 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'build_neighbor_lists' - INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, iatom_subcell, icell, ikind, & - inode, j, jatom, jatom_local, jcell, jkind, k, kcell, maxat, mol_a, mol_b, natom, nentry, & - nkind, nnode, otype - INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb + TYPE local_lists + INTEGER, DIMENSION(:), POINTER :: list + END TYPE local_lists + + INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, & + iatom_subcell, icell, ikind, j, jatom, jatom_local, jcell, jkind, k, & + kcell, maxat, mol_a, mol_b, nkind, otype, natom, inode, nnode, nentry INTEGER, DIMENSION(3) :: cell_b, ncell, nsubcell, periodic INTEGER, DIMENSION(:), POINTER :: index_list - LOGICAL :: include_ab, my_mic, my_molecular, & - my_sort_atomb, my_symmetric + LOGICAL :: include_ab, my_mic, & + my_molecular, my_symmetric, my_sort_atomb LOGICAL, ALLOCATABLE, DIMENSION(:) :: pres_a, pres_b - REAL(dp) :: deth, rab2, rab2_max, rab_max, rabm, & - subcell_scale - REAL(dp), DIMENSION(3) :: pd, r, ra, rab, rab_pbc, rb, sab_max, & - sab_max_guard, sb, sb_max, sb_min, & - sb_pbc - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: r_pbc + REAL(dp) :: rab2, rab2_max, rab_max, rabm, deth, subcell_scale + REAL(dp), DIMENSION(3) :: r, rab, ra, rb, sab_max, sb, & + sb_pbc, sb_min, sb_max, rab_pbc, pd, sab_max_guard + INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb TYPE(local_lists), DIMENSION(:), POINTER :: lista, listb + TYPE(neighbor_list_p_type), & + ALLOCATABLE, DIMENSION(:) :: kind_a + TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set + TYPE(subcell_type), DIMENSION(:, :, :), & + POINTER :: subcell + REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: r_pbc TYPE(neighbor_list_iterator_p_type), & DIMENSION(:), POINTER :: nl_iterator - TYPE(neighbor_list_p_type), ALLOCATABLE, & - DIMENSION(:) :: kind_a - TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set - TYPE(subcell_type), DIMENSION(:, :, :), POINTER :: subcell CALL timeset(routineN//"_"//TRIM(nlname), handle) diff --git a/src/qs_nonscf_utils.F b/src/qs_nonscf_utils.F index 79bf5fd5e2..bc73ecfbd9 100644 --- a/src/qs_nonscf_utils.F +++ b/src/qs_nonscf_utils.F @@ -82,22 +82,19 @@ CONTAINS "Self energy of the core charge distribution: ", energy%core_self, & "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", energy%exc - IF (energy%dispersion /= 0.0_dp) THEN + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - END IF - IF (energy%gcp /= 0.0_dp) THEN + "Dispersion energy: ", energy%dispersion + IF (energy%gcp /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - END IF - IF (energy%efield /= 0.0_dp) THEN + "gCP energy: ", energy%gcp + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT("NONSCF not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPASSERT(energy%dftb3 == 0.0_dp) energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & @@ -106,11 +103,10 @@ CONTAINS "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Dispersion energy: ", energy%dispersion - IF (energy%efield /= 0.0_dp) THEN + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF - ELSE IF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + ELSEIF (dft_control%qs_control%xtb) THEN energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & "Diagonalization", "Time:", tdiag, energy%total @@ -121,14 +117,12 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF - IF (energy%efield /= 0.0_dp) THEN + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield ELSE CPABORT("NONSCF not available") END IF diff --git a/src/qs_ot.F b/src/qs_ot.F index 598749bc9c..2b13565c51 100644 --- a/src/qs_ot.F +++ b/src/qs_ot.F @@ -295,9 +295,8 @@ CONTAINS ! ! compute the P^(-1/2) DO i = 1, k - IF (eig(i) <= 0.0_dp) THEN + IF (eig(i) <= 0.0_dp) & CPABORT("P not positive definite") - END IF IF (eig(i) < 1.0E-8_dp) THEN fun(i) = 0.0_dp ELSE diff --git a/src/qs_ot_types.F b/src/qs_ot_types.F index d301039af0..d184e998fd 100644 --- a/src/qs_ot_types.F +++ b/src/qs_ot_types.F @@ -269,31 +269,25 @@ CONTAINS CALL dbcsr_set(qs_ot_env%matrix_gx, 0.0_dp) - IF (qs_ot_env%use_dx) THEN + IF (qs_ot_env%use_dx) & CALL dbcsr_set(qs_ot_env%matrix_dx, 0.0_dp) - END IF - IF (qs_ot_env%use_gx_old) THEN + IF (qs_ot_env%use_gx_old) & CALL dbcsr_set(qs_ot_env%matrix_gx_old, 0.0_dp) - END IF IF (qs_ot_env%settings%do_rotation) THEN CALL dbcsr_set(qs_ot_env%rot_mat_gx, 0.0_dp) - IF (qs_ot_env%use_dx) THEN + IF (qs_ot_env%use_dx) & CALL dbcsr_set(qs_ot_env%rot_mat_dx, 0.0_dp) - END IF - IF (qs_ot_env%use_gx_old) THEN + IF (qs_ot_env%use_gx_old) & CALL dbcsr_set(qs_ot_env%rot_mat_gx_old, 0.0_dp) - END IF END IF IF (qs_ot_env%settings%do_ener) THEN qs_ot_env%ener_gx(:) = 0.0_dp - IF (qs_ot_env%use_dx) THEN + IF (qs_ot_env%use_dx) & qs_ot_env%ener_dx(:) = 0.0_dp - END IF - IF (qs_ot_env%use_gx_old) THEN + IF (qs_ot_env%use_gx_old) & qs_ot_env%ener_gx_old(:) = 0.0_dp - END IF END IF END SUBROUTINE qs_ot_init diff --git a/src/qs_outer_scf.F b/src/qs_outer_scf.F index 55d7d7b239..1b4a93e52d 100644 --- a/src/qs_outer_scf.F +++ b/src/qs_outer_scf.F @@ -318,11 +318,10 @@ CONTAINS END IF IF (scf_control%outer_scf%cdft_opt_control%broyden_update) THEN ! Perform a Broyden update of the inverse Jacobian J^(-1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF "// & "must be greater than or equal to 3 for Broyden optimizers.") - END IF nvar = SIZE(scf_env%outer_scf%gradient, 1) ALLOCATE (f(nvar, 1), x(nvar, 1)) DO i = 1, nvar @@ -573,37 +572,31 @@ CONTAINS cdft_control%constraint%deallocate_jacobian = scf_env%outer_scf%deallocate_jacobian IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN nvariables = SIZE(scf_env%outer_scf%inv_jacobian, 1) - IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) & ALLOCATE (cdft_control%constraint%inv_jacobian(nvariables, nvariables)) - END IF cdft_control%constraint%inv_jacobian = scf_env%outer_scf%inv_jacobian END IF ! Now switch - IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN + IF (ASSOCIATED(scf_env%outer_scf%energy)) & DEALLOCATE (scf_env%outer_scf%energy) - END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN + IF (ASSOCIATED(scf_env%outer_scf%variables)) & DEALLOCATE (scf_env%outer_scf%variables) - END IF ALLOCATE (scf_env%outer_scf%variables(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN + IF (ASSOCIATED(scf_env%outer_scf%gradient)) & DEALLOCATE (scf_env%outer_scf%gradient) - END IF ALLOCATE (scf_env%outer_scf%gradient(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%count)) THEN + IF (ASSOCIATED(scf_env%outer_scf%count)) & DEALLOCATE (scf_env%outer_scf%count) - END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = 0 ! OT SCF does not need Jacobian scf_env%outer_scf%deallocate_jacobian = .TRUE. - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & DEALLOCATE (scf_env%outer_scf%inv_jacobian) - END IF CASE (ot2cdft) ! OT -> constraint scf_control%outer_scf%have_scf = cdft_control%constraint_control%have_scf @@ -617,32 +610,27 @@ CONTAINS CALL cdft_opt_type_copy(scf_control%outer_scf%cdft_opt_control, & cdft_control%constraint_control%cdft_opt_control) nvariables = SIZE(cdft_control%constraint%variables, 1) - IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN + IF (ASSOCIATED(scf_env%outer_scf%energy)) & DEALLOCATE (scf_env%outer_scf%energy) - END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = cdft_control%constraint%energy - IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN + IF (ASSOCIATED(scf_env%outer_scf%variables)) & DEALLOCATE (scf_env%outer_scf%variables) - END IF ALLOCATE (scf_env%outer_scf%variables(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = cdft_control%constraint%variables - IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN + IF (ASSOCIATED(scf_env%outer_scf%gradient)) & DEALLOCATE (scf_env%outer_scf%gradient) - END IF ALLOCATE (scf_env%outer_scf%gradient(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = cdft_control%constraint%gradient - IF (ASSOCIATED(scf_env%outer_scf%count)) THEN + IF (ASSOCIATED(scf_env%outer_scf%count)) & DEALLOCATE (scf_env%outer_scf%count) - END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = cdft_control%constraint%count scf_env%outer_scf%iter_count = cdft_control%constraint%iter_count scf_env%outer_scf%deallocate_jacobian = cdft_control%constraint%deallocate_jacobian IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & DEALLOCATE (scf_env%outer_scf%inv_jacobian) - END IF ALLOCATE (scf_env%outer_scf%inv_jacobian(nvariables, nvariables)) scf_env%outer_scf%inv_jacobian = cdft_control%constraint%inv_jacobian END IF diff --git a/src/qs_overlap.F b/src/qs_overlap.F index 6007a9739d..857850a5bf 100644 --- a/src/qs_overlap.F +++ b/src/qs_overlap.F @@ -235,7 +235,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSE IF (PRESENT(matrixkp_s)) THEN + ELSEIF (PRESENT(matrixkp_s)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -868,7 +868,7 @@ CONTAINS IF (PRESENT(matrix_p)) THEN dokp = .FALSE. use_cell_mapping = .FALSE. - ELSE IF (PRESENT(matrixkp_p)) THEN + ELSEIF (PRESENT(matrixkp_p)) THEN dokp = .TRUE. CALL get_ks_env(ks_env=ks_env, kpoints=kpoints) CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) diff --git a/src/qs_p_env_methods.F b/src/qs_p_env_methods.F index 7fde38663a..b7e2b9a78c 100644 --- a/src/qs_p_env_methods.F +++ b/src/qs_p_env_methods.F @@ -224,9 +224,8 @@ CONTAINS END DO p_env%orthogonal_orbitals = .FALSE. - IF (PRESENT(orthogonal_orbitals)) THEN + IF (PRESENT(orthogonal_orbitals)) & p_env%orthogonal_orbitals = orthogonal_orbitals - END IF CALL fm_pools_create_fm_vect(ao_mo_fm_pools, elements=p_env%S_psi0, & name="p_env%S_psi0") @@ -266,7 +265,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, p_env%local_rho_set%rho0_mpole) CALL hartree_local_create(p_env%hartree_local) CALL init_coulomb_local(p_env%hartree_local, natom) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_pdos.F b/src/qs_pdos.F index 3f569ade73..5a16f5b080 100644 --- a/src/qs_pdos.F +++ b/src/qs_pdos.F @@ -579,9 +579,8 @@ CONTAINS eval_ref => mos_ref(ispin_ref)%eigenvalues occ_ref => mos_ref(ispin_ref)%occupation_numbers DO imo_ref = 1, nmo_ref - IF (occ_ref(imo_ref) > 1.0e-10_dp) THEN + IF (occ_ref(imo_ref) > 1.0e-10_dp) & hoco_ref(ispin_ref) = MAX(hoco_ref(ispin_ref), eval_ref(imo_ref)) - END IF IF (ABS(occ_ref(imo_ref) - REAL(NINT(occ_ref(imo_ref)), KIND=dp)) > & 1.0e-8_dp) fractional_occupation = .TRUE. END DO @@ -619,12 +618,10 @@ CONTAINS !Adjust energy range for r_ldos DO ildos = 1, n_r_ldos - IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) THEN + IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) & r_ldos_p(ildos)%ldos%eval_range(1) = eigenvalues(1) - END IF - IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) THEN + IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) & r_ldos_p(ildos)%ldos%eval_range(2) = eigenvalues(nmo + nvirt) - END IF END DO IF (output_unit > 0) WRITE (UNIT=output_unit, FMT='(/,(T15,A))') & diff --git a/src/qs_resp.F b/src/qs_resp.F index 13843d37cc..971dd1768c 100644 --- a/src/qs_resp.F +++ b/src/qs_resp.F @@ -396,10 +396,9 @@ CONTAINS r_val=resp_env%rheavies_strength) END IF CALL section_vals_val_get(resp_section, "STRIDE", i_vals=my_stride) - IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) THEN + IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 (the same for X,Y,Z) "// & "or 3 values. Correct your input file.") - END IF IF (SIZE(my_stride) == 1) THEN DO i = 1, 3 resp_env%stride(i) = my_stride(1) @@ -727,9 +726,8 @@ CONTAINS DO j = i + 1, num_atom atom_a = atom_list(i) atom_b = atom_list(j) - IF (atom_a == atom_b) THEN + IF (atom_a == atom_b) & CPABORT("There are atoms doubled in atom list for RESP.") - END IF END DO END DO diff --git a/src/qs_rho0_ggrid.F b/src/qs_rho0_ggrid.F index d3fa12931d..a6a8c57793 100644 --- a/src/qs_rho0_ggrid.F +++ b/src/qs_rho0_ggrid.F @@ -440,10 +440,9 @@ CONTAINS ! END IF !END IF - IF (PRESENT(local_rho_set)) THEN + IF (PRESENT(local_rho_set)) & CALL get_local_rho(local_rho_set, rho0_mpole=rho0_mpole, rho_atom_set=rho_atom_set, & rhoz_cneo_set=rhoz_cneo_set) - END IF ! Q from rho0_mpole of local_rho_set ! for TDDFT forces we need mixed potential / integral space ! potential stored on local_rho_set_2nd diff --git a/src/qs_rho_methods.F b/src/qs_rho_methods.F index f54d7afcd9..7cb0436876 100644 --- a/src/qs_rho_methods.F +++ b/src/qs_rho_methods.F @@ -140,9 +140,8 @@ CONTAINS do_kpoints=do_kpoints, & pw_env=pw_env, & dft_control=dft_control) - IF (PRESENT(pw_env_external)) THEN + IF (PRESENT(pw_env_external)) & pw_env => pw_env_external - END IF nimg = dft_control%nimages @@ -183,9 +182,8 @@ CONTAINS ! rho_ao IF (my_rebuild_ao .OR. (.NOT. ASSOCIATED(rho_ao_kp))) THEN - IF (ASSOCIATED(rho_ao_kp)) THEN + IF (ASSOCIATED(rho_ao_kp)) & CALL dbcsr_deallocate_matrix_set(rho_ao_kp) - END IF ! Create a new density matrix set CALL dbcsr_allocate_matrix_set(rho_ao_kp, nspins, nimg) CALL qs_rho_set(rho, rho_ao_kp=rho_ao_kp) @@ -408,12 +406,12 @@ CONTAINS CALL calculate_harris_density(qs_env, harris_env%rhoin, rho_struct) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSE IF (dft_control%qs_control%semi_empirical .OR. & - dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%semi_empirical .OR. & + dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) - ELSE IF (dft_control%qs_control%lrigpw) THEN + ELSEIF (dft_control%qs_control%lrigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) @@ -429,7 +427,7 @@ CONTAINS CALL set_qs_env(qs_env, lri_density=lri_density) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSE IF (dft_control%qs_control%rigpw) THEN + ELSEIF (dft_control%qs_control%rigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL get_qs_env(qs_env, lri_env=lri_env) diff --git a/src/qs_scf.F b/src/qs_scf.F index 8c9eaf8760..30865f773b 100644 --- a/src/qs_scf.F +++ b/src/qs_scf.F @@ -278,9 +278,8 @@ CONTAINS scf_control%outer_scf%cdft_opt_control%ijacobian(2) = scf_control%outer_scf%cdft_opt_control%ijacobian(2) + 1 IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) .AND. & - scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) THEN + scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) & scf_env%outer_scf%deallocate_jacobian = .TRUE. - END IF END IF END IF ! *** add the converged wavefunction to the wavefunction history @@ -318,9 +317,8 @@ CONTAINS ! *** cleanup CALL scf_env_cleanup(scf_env) - IF (dft_control%qs_control%cdft) THEN + IF (dft_control%qs_control%cdft) & CALL cdft_control_cleanup(dft_control%qs_control%cdft_control) - END IF IF (PRESENT(has_converged)) THEN has_converged = converged @@ -476,11 +474,10 @@ CONTAINS CALL get_results(results, description=description, & values=res_val_3, n_entries=i_tmp) CPASSERT(i_tmp == 3) - IF (ALL(res_val_3(:) <= 0.0)) THEN + IF (ALL(res_val_3(:) <= 0.0)) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)// & ") which is not correctly stored.") - END IF CALL external_comm%set_handle(NINT(res_val_3(1))) END IF ext_master_id = NINT(res_val_3(2)) @@ -581,7 +578,7 @@ CONTAINS IF (tblite_native_mixer) THEN scf_env%iter_param = dft_control%qs_control%xtb_control%tblite_mixer_damping scf_env%iter_method = "TBLite/Diag" - ELSE IF (internal_tblite_mixer) THEN + ELSEIF (internal_tblite_mixer) THEN scf_env%iter_method = "TBLite/Diag" IF (dft_control%qs_control%dftb) THEN scf_env%iter_param = dft_control%qs_control%dftb_control%tblite_mixer_damping @@ -644,9 +641,8 @@ CONTAINS END IF IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) THEN + scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) & t1 = m_walltime() - END IF ! mixing methods have the new density matrix in p_mix_new IF (scf_env%mixing_method > 0) THEN @@ -695,10 +691,9 @@ CONTAINS converged = inner_loop_converged .AND. outer_loop_converged total_scf_steps = total_steps - IF (dft_control%qs_control%cdft) THEN + IF (dft_control%qs_control%cdft) & dft_control%qs_control%cdft_control%total_steps = & - dft_control%qs_control%cdft_control%total_steps + total_steps - END IF + dft_control%qs_control%cdft_control%total_steps + total_steps IF (.NOT. converged) THEN IF (scf_control%ignore_convergence_failure .OR. should_stop) THEN @@ -720,10 +715,8 @@ CONTAINS ! if needed copy mo_coeff dbcsr->fm for later use in post_scf!fm->dbcsr DO ispin = 1, SIZE(mos) !fm -> dbcsr IF (mos(ispin)%use_mo_coeff_b) THEN !fm->dbcsr - IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) THEN - !fm->dbcsr - CPABORT("mo_coeff_b is not allocated") - END IF !fm->dbcsr + IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) & !fm->dbcsr + CPABORT("mo_coeff_b is not allocated") !fm->dbcsr CALL copy_dbcsr_to_fm(mos(ispin)%mo_coeff_b, & !fm->dbcsr mos(ispin)%mo_coeff) !fm -> dbcsr END IF !fm->dbcsr @@ -928,11 +921,10 @@ CONTAINS IF (dft_control%restricted) THEN scf_env%qs_ot_env(1)%restricted = .TRUE. ! requires rotation - IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) THEN + IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) & CALL cp_abort(__LOCATION__, & "Restricted calculation with OT requires orbital rotation. Please "// & "activate the OT%ROTATION keyword!") - END IF ELSE scf_env%qs_ot_env(:)%restricted = .FALSE. END IF @@ -942,9 +934,8 @@ CONTAINS do_rotation = scf_env%qs_ot_env(1)%settings%do_rotation ! only full all needs rotation is_full_all = scf_env%qs_ot_env(1)%settings%preconditioner_type == ot_precond_full_all - IF (do_rotation .AND. is_full_all) THEN + IF (do_rotation .AND. is_full_all) & CPABORT('PRECONDITIONER FULL_ALL is not compatible with ROTATION.') - END IF ! might need the KS matrix to init properly CALL qs_ks_update_qs_env(qs_env, just_energy=.FALSE., & @@ -952,11 +943,10 @@ CONTAINS ! if an old preconditioner is still around (i.e. outer SCF is active), ! remove it if this could be worthwhile - IF (.NOT. reuse_precond) THEN + IF (.NOT. reuse_precond) & CALL restart_preconditioner(qs_env, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & dft_control%nspins) - END IF ! ! preconditioning still needs to be done correctly with has_unit_metric @@ -968,14 +958,13 @@ CONTAINS orthogonality_metric => matrix_s(1)%matrix END IF - IF (.NOT. reuse_precond) THEN + IF (.NOT. reuse_precond) & CALL prepare_preconditioner(qs_env, mos, matrix_ks, matrix_s, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & scf_env%qs_ot_env(1)%settings%precond_solver_type, & scf_env%qs_ot_env(1)%settings%energy_gap, dft_control%nspins, & has_unit_metric=has_unit_metric, & chol_type=scf_env%qs_ot_env(1)%settings%cholesky_type) - END IF IF (reuse_precond) reuse_precond = .FALSE. CALL ot_scf_init(mo_array=mos, matrix_s=orthogonality_metric, & @@ -1214,9 +1203,8 @@ CONTAINS ! usually this means that the electronic structure has already converged to the correct state ! but the constraint optimizer keeps jumping over the optimal solution IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count == 1 & - .AND. cdft_control%total_steps /= 1) THEN + .AND. cdft_control%total_steps /= 1) & cdft_control%nreused = cdft_control%nreused - 1 - END IF ! SCF converged in less than precond_freq steps IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count <= cdft_control%precond_freq .AND. & cdft_control%total_steps /= 1 .AND. cdft_control%nreused < cdft_control%max_reuse) THEN @@ -1368,22 +1356,17 @@ CONTAINS SUBROUTINE cdft_control_cleanup(cdft_control) TYPE(cdft_control_type), POINTER :: cdft_control - IF (ASSOCIATED(cdft_control%constraint%variables)) THEN + IF (ASSOCIATED(cdft_control%constraint%variables)) & DEALLOCATE (cdft_control%constraint%variables) - END IF - IF (ASSOCIATED(cdft_control%constraint%count)) THEN + IF (ASSOCIATED(cdft_control%constraint%count)) & DEALLOCATE (cdft_control%constraint%count) - END IF - IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN + IF (ASSOCIATED(cdft_control%constraint%gradient)) & DEALLOCATE (cdft_control%constraint%gradient) - END IF - IF (ASSOCIATED(cdft_control%constraint%energy)) THEN + IF (ASSOCIATED(cdft_control%constraint%energy)) & DEALLOCATE (cdft_control%constraint%energy) - END IF IF (ASSOCIATED(cdft_control%constraint%inv_jacobian) .AND. & - cdft_control%constraint%deallocate_jacobian) THEN + cdft_control%constraint%deallocate_jacobian) & DEALLOCATE (cdft_control%constraint%inv_jacobian) - END IF END SUBROUTINE cdft_control_cleanup @@ -1455,11 +1438,10 @@ CONTAINS IF (explicit_jacobian) THEN ! Build Jacobian with finite differences cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) THEN + IF (.NOT. ASSOCIATED(cdft_control)) & CALL cp_abort(__LOCATION__, & "Optimizers that need the explicit Jacobian can"// & " only be used together with a valid CDFT constraint.") - END IF ! Redirect output from Jacobian calculation to a new file by creating a temporary logger project_name = logger%iter_info%project_name CALL create_tmp_logger(para_env, project_name, "-JacobianInfo.out", output_unit, tmp_logger) @@ -1555,9 +1537,8 @@ CONTAINS jacobian(i, j) = jacobian(i, j)/dh(j) END DO END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) scf_control%outer_scf%cdft_opt_control%broyden_update = .FALSE. @@ -1648,25 +1629,22 @@ CONTAINS do_linesearch = .FALSE. CASE (broyden_type_1_ls, broyden_type_1_explicit_ls, broyden_type_2_ls, broyden_type_2_explicit_ls) cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) THEN + IF (.NOT. ASSOCIATED(cdft_control)) & CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") - END IF - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & do_linesearch = .TRUE. - END IF END SELECT END SELECT IF (do_linesearch) THEN BLOCK TYPE(mo_set_type), DIMENSION(:), ALLOCATABLE :: mos_ls, mos_stashed cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) THEN + IF (.NOT. ASSOCIATED(cdft_control)) & CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") - END IF CPASSERT(ASSOCIATED(scf_env%outer_scf%inv_jacobian)) CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) alpha = scf_control%outer_scf%cdft_opt_control%newton_step_save @@ -1800,9 +1778,8 @@ CONTAINS IF (i == max_linesearch) continue_ls_exit = .TRUE. ! Exit if constraint target is satisfied to requested tolerance IF (SQRT(MAXVAL(scf_env%outer_scf%gradient(:, scf_env%outer_scf%iter_count + 1)**2)) < & - scf_control%outer_scf%eps_scf) THEN + scf_control%outer_scf%eps_scf) & continue_ls_exit = .TRUE. - END IF ! Exit if line search jumped over the optimal step length IF (sign_changed) continue_ls_exit = .TRUE. END IF @@ -1858,10 +1835,9 @@ CONTAINS "Line search did not converge. CDFT SCF proceeds with fixed step size.") scf_control%outer_scf%cdft_opt_control%newton_step = scf_control%outer_scf%cdft_opt_control%newton_step_save END IF - IF (reached_maxls) THEN + IF (reached_maxls) & CALL cp_warn(__LOCATION__, & "Line search did not converge. CDFT SCF proceeds with lasted iterated step size.") - END IF CALL cp_rm_default_logger() CALL cp_logger_release(tmp_logger) ! Release temporary storage diff --git a/src/qs_scf_csr_write.F b/src/qs_scf_csr_write.F index 557ff151d3..c92135f798 100644 --- a/src/qs_scf_csr_write.F +++ b/src/qs_scf_csr_write.F @@ -594,9 +594,8 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & nomirror = nomirror + 1 - END IF END DO ! create the mirror imgs diff --git a/src/qs_scf_diagonalization.F b/src/qs_scf_diagonalization.F index fc7973f9c5..0c0619c93f 100644 --- a/src/qs_scf_diagonalization.F +++ b/src/qs_scf_diagonalization.F @@ -223,7 +223,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1124,9 +1124,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(subspace_env%mixing_store) - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, para_env) @@ -1378,7 +1378,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1476,7 +1476,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/OTdiag." - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/OTdiag." END IF @@ -1695,7 +1695,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF @@ -1917,11 +1917,10 @@ CONTAINS CALL lanczos_refinement(scf_env%krylov_space, ks, c0, c1, mo_eigenvalues, & nao, eps_iter, ispin, check_moconv_only=my_check_moconv_only) t2 = m_walltime() - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(T8,I3,T16,I5,T24,I6,T33,E12.4,2x,E12.4,T60,F8.3)') & - ispin, iter, scf_env%krylov_space%nmo_conv, & - scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 - END IF + ispin, iter, scf_env%krylov_space%nmo_conv, & + scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 CYCLE ELSE @@ -2039,9 +2038,8 @@ CONTAINS output_unit = cp_print_key_unit_nr(logger, scf_section, "PRINT%DAVIDSON", & extension=".scfLog") - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/T15,A)") '<<<<<<<<< DAVIDSON ITERATIONS <<<<<<<<<<' - END IF IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha diff --git a/src/qs_scf_initialization.F b/src/qs_scf_initialization.F index fd63e14991..71bed6abc6 100644 --- a/src/qs_scf_initialization.F +++ b/src/qs_scf_initialization.F @@ -349,15 +349,13 @@ CONTAINS NULLIFY (outer_scf_history, gradient_history, variable_history) CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) ! Test kpoints - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("CDFT calculation not possible with kpoints") - END IF ! Check that OUTER_SCF section in DFT&SCF is active ! This section must always be active to facilitate ! switching of the CDFT and SCF control parameters in outer_loop_switch - IF (.NOT. scf_control%outer_scf%have_scf) THEN + IF (.NOT. scf_control%outer_scf%have_scf) & CPABORT("Section SCF&OUTER_SCF must be active for CDFT calculations.") - END IF ! Initialize CDFT and outer_loop variables (constraint settings active in scf_control) IF (dft_control%qs_control%cdft_control%constraint_control%have_scf) THEN nhistory = dft_control%qs_control%cdft_control%constraint_control%max_scf + 1 @@ -662,12 +660,10 @@ CONTAINS ! possible for OT gamma point calculations qs_env%requires_mo_derivs = .FALSE. END IF - IF (dft_control%do_xas_calculation) THEN + IF (dft_control%do_xas_calculation) & CPABORT("No XAS implemented with kpoints") - END IF - IF (qs_env%do_rixs) THEN + IF (qs_env%do_rixs) & CPABORT("RIXS not implemented with kpoints") - END IF DO ik = 1, SIZE(kpoints%kp_env) CALL mpools_get(kpoints%mpools, ao_mo_fm_pools=ao_mo_fm_pools) mos_k => kpoints%kp_env(ik)%kpoint_env%mos @@ -798,14 +794,12 @@ CONTAINS IF (scf_control%use_diag) THEN ! sanity check whether combinations are allowed - IF (dft_control%restricted) THEN + IF (dft_control%restricted) & CPABORT("OT only for restricted (ROKS)") - END IF SELECT CASE (scf_control%diagonalization%method) CASE (diag_ot, diag_block_krylov, diag_block_davidson) - IF (.NOT. not_se_or_tb) THEN + IF (.NOT. not_se_or_tb) & CPABORT("TB and SE not possible with OT diagonalization") - END IF END SELECT SELECT CASE (scf_control%diagonalization%method) ! Diagonalization: additional check whether we are in an orthonormal basis @@ -826,39 +820,32 @@ CONTAINS END IF ! OT Diagonalization: not possible with ROKS CASE (diag_ot) - IF (dft_control%roks) THEN + IF (dft_control%roks) & CPABORT("ROKS with OT diagonalization not possible") - END IF - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("OT diagonalization not possible with kpoint calculations") - END IF scf_env%method = ot_diag_method_nr need_coeff_b = .TRUE. ! Block Krylov diagonlization: not possible with ROKS, ! allocation of additional matrices is needed CASE (diag_block_krylov) - IF (dft_control%roks) THEN + IF (dft_control%roks) & CPABORT("ROKS with block PF diagonalization not possible") - END IF - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("Block Krylov diagonalization not possible with kpoint calculations") - END IF scf_env%method = block_krylov_diag_method_nr scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%krylov_space)) THEN + IF (.NOT. ASSOCIATED(scf_env%krylov_space)) & CALL krylov_space_create(scf_env%krylov_space, scf_section) - END IF CALL krylov_space_allocate(scf_env%krylov_space, scf_control, mos) ! Block davidson diagonlization: allocation of additional matrices is needed CASE (diag_block_davidson) - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("Block Davidson diagonalization not possible with kpoint calculations") - END IF scf_env%method = block_davidson_diag_method_nr - IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) THEN + IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) & CALL block_davidson_env_create(scf_env%block_davidson_env, dft_control%nspins, & scf_section) - END IF DO ispin = 1, dft_control%nspins CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff, nao=nao, nmo=nmo) CALL block_davidson_allocate(scf_env%block_davidson_env(ispin), mo_coeff, nao, nmo) @@ -881,29 +868,24 @@ CONTAINS ! Check if subspace diagonlization is requested: allocation of additional matrices is needed IF (scf_control%do_diag_sub) THEN scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%subspace_env)) THEN + IF (.NOT. ASSOCIATED(scf_env%subspace_env)) & CALL diag_subspace_env_create(scf_env%subspace_env, scf_section, & dft_control%qs_control%cutoff) - END IF CALL diag_subspace_allocate(scf_env%subspace_env, qs_env, mos) - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("No subspace diagonlization with kpoint calculation") - END IF END IF ! OT: check if OT is used instead of diagonalization. Not possible with added MOS at the moment - ELSE IF (scf_control%use_ot) THEN + ELSEIF (scf_control%use_ot) THEN scf_env%method = ot_method_nr need_coeff_b = .TRUE. - IF (SUM(ABS(scf_control%added_mos)) > 0) THEN + IF (SUM(ABS(scf_control%added_mos)) > 0) & CPABORT("OT with ADDED_MOS/=0 not implemented") - END IF - IF (dft_control%restricted .AND. dft_control%nspins /= 2) THEN + IF (dft_control%restricted .AND. dft_control%nspins /= 2) & CPABORT("nspin must be 2 for restricted (ROKS)") - END IF - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("OT not possible with kpoint calculations") - END IF - ELSE IF (scf_env%method /= smeagol_method_nr) THEN + ELSEIF (scf_env%method /= smeagol_method_nr) THEN CPABORT("OT or DIAGONALIZATION have to be set") END IF DO ispin = 1, dft_control%nspins @@ -1307,9 +1289,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(scf_env%mixing_store) - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & diff --git a/src/qs_scf_loop_utils.F b/src/qs_scf_loop_utils.F index 148d1bc942..9732a0c488 100644 --- a/src/qs_scf_loop_utils.F +++ b/src/qs_scf_loop_utils.F @@ -172,13 +172,13 @@ CONTAINS "SCF%DIAGONALIZATION if "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE ") - ELSE IF (dft_control%roks) THEN + ELSEIF (dft_control%roks) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE "// & "is not implemented with ROKS") - ELSE IF (scf_control%diagonalization%mom) THEN + ELSEIF (scf_control%diagonalization%mom) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & @@ -342,9 +342,8 @@ CONTAINS scf_control%eps_diis = 0.0_dp END IF - IF (dft_control%roks) THEN + IF (dft_control%roks) & CPABORT("KP code: ROKS method not available: ") - END IF SELECT CASE (scf_env%method) CASE DEFAULT @@ -371,7 +370,7 @@ CONTAINS ELSE IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF diff --git a/src/qs_scf_methods.F b/src/qs_scf_methods.F index cbb13c407d..bfba4f2e90 100644 --- a/src/qs_scf_methods.F +++ b/src/qs_scf_methods.F @@ -197,16 +197,14 @@ CONTAINS CASE (cholesky_reduce) CALL cp_fm_cholesky_reduce(matrix_ks_fm, ortho) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF CASE (cholesky_restore) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -215,17 +213,15 @@ CONTAINS CALL cp_fm_cholesky_restore(work, nao, ortho, matrix_ks_fm, & "SOLVE", pos="LEFT", transa="T") - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF CASE (cholesky_inverse) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -235,19 +231,17 @@ CONTAINS CALL cp_fm_triangular_multiply(ortho, matrix_ks_fm, side="L", transpose_tr=.TRUE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nao, alpha=1.0_dp) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_triangular_multiply(ortho, work, side="L", transpose_tr=.FALSE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nmo, alpha=1.0_dp) CALL cp_fm_to_fm(work, mo_coeff, nmo, 1, 1) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF END SELECT @@ -432,10 +426,9 @@ CONTAINS CALL cp_fm_symm("L", "U", nao, nao_red, 1.0_dp, matrix_ks_fm, ortho_red, 0.0_dp, work_red) CALL parallel_gemm("T", "N", nao_red, nao_red, nao, 1.0_dp, ortho_red, work_red, 0.0_dp, matrix_ks_fm_red) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm_red, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm_red) - END IF CALL cp_fm_create(work_red2, matrix_ks_fm_red%matrix_struct) ALLOCATE (eigenvalues(nao_red)) @@ -447,18 +440,16 @@ CONTAINS ELSE CALL cp_fm_symm("L", "U", nao, nao, 1.0_dp, matrix_ks_fm, ortho, 0.0_dp, work) CALL parallel_gemm("T", "N", nao, nao, nao, 1.0_dp, ortho, work, 0.0_dp, matrix_ks_fm) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL parallel_gemm("N", "N", nao, nmo, nao, 1.0_dp, ortho, work, 0.0_dp, & mo_coeff) END IF - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF END IF @@ -528,9 +519,8 @@ CONTAINS END IF - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF CALL timestop(handle) diff --git a/src/qs_scf_output.F b/src/qs_scf_output.F index 60afbc842b..203abdc458 100644 --- a/src/qs_scf_output.F +++ b/src/qs_scf_output.F @@ -252,13 +252,11 @@ CONTAINS occup_stats_occ_threshold = 1e-6_dp IF (SIZE(tmpstringlist) > 0) THEN ! the lone_keyword_c_vals doesn't work as advertised, handle it manually print_occup_stats = .TRUE. - IF (LEN_TRIM(tmpstringlist(1)) > 0) THEN + IF (LEN_TRIM(tmpstringlist(1)) > 0) & READ (tmpstringlist(1), *) print_occup_stats - END IF END IF - IF (SIZE(tmpstringlist) > 1) THEN + IF (SIZE(tmpstringlist) > 1) & READ (tmpstringlist(2), *) occup_stats_occ_threshold - END IF logger => cp_get_default_logger() print_mo_info = (cp_print_key_should_output(logger%iter_info, dft_section, "PRINT%MO") /= 0) @@ -703,25 +701,22 @@ CONTAINS "Two-electron integral energy [eV]: ", energy%hartree*evolt, & "Electronic energy [eV]: ", & (energy%core + 0.5_dp*energy%hartree)*evolt - IF (energy%dispersion /= 0.0_dp) THEN + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy [eV]: ", energy%dispersion*evolt - END IF - ELSE IF (dft_control%qs_control%dftb) THEN + "Dispersion energy [eV]: ", energy%dispersion*evolt + ELSEIF (dft_control%qs_control%dftb) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "Dispersion energy: ", energy%dispersion - IF (energy%dftb3 /= 0.0_dp) THEN + IF (energy%dftb3 /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "DFTB3 3rd order energy: ", energy%dftb3 - END IF - IF (energy%efield /= 0.0_dp) THEN + "DFTB3 3rd order energy: ", energy%dftb3 + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF - ELSE IF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & @@ -738,31 +733,28 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN + ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "DFTB3 3rd order energy: ", energy%dftb3, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) THEN + IF (dft_control%qs_control%xtb_control%xb_interaction) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - END IF - ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN + "Correction for halogen bonding: ", energy%xtb_xb_inter + ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN CPABORT("gfn_typ 2 NYA") ELSE CPABORT("invalid gfn_typ") END IF END IF - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF - IF (energy%efield /= 0.0_dp) THEN + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield ELSE IF (dft_control%do_admm) THEN exc_energy = energy%exc + energy%exc_aux_fit @@ -800,27 +792,22 @@ CONTAINS "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", exc_energy END IF - IF (energy%e_hartree /= 0.0_dp) THEN + IF (energy%e_hartree /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,/,T3,A,T56,F25.14)") & - "Coulomb Electron-Electron Interaction Energy ", & - "- Already included in the total Hartree term ", energy%e_hartree - END IF - IF (energy%ex /= 0.0_dp) THEN + "Coulomb Electron-Electron Interaction Energy ", & + "- Already included in the total Hartree term ", energy%e_hartree + IF (energy%ex /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Hartree-Fock Exchange energy: ", energy%ex - END IF - IF (energy%dispersion /= 0.0_dp) THEN + "Hartree-Fock Exchange energy: ", energy%ex + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - END IF - IF (energy%gcp /= 0.0_dp) THEN + "Dispersion energy: ", energy%dispersion + IF (energy%gcp /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - END IF - IF (energy%efield /= 0.0_dp) THEN + "gCP energy: ", energy%gcp + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield IF (gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "GAPW| Exc from hard and soft atomic rho1: ", exc1_energy, & @@ -1213,10 +1200,9 @@ CONTAINS WRITE (output_unit, '(A,L7)') & " Precompute gradients : ", cdft_control%becke_control%in_memory WRITE (output_unit, '(A)') " " - IF (cdft_control%becke_control%adjust) THEN + IF (cdft_control%becke_control%adjust) & WRITE (output_unit, '(A)') & - " Using atomic radii to generate a heteronuclear charge partitioning" - END IF + " Using atomic radii to generate a heteronuclear charge partitioning" WRITE (output_unit, '(A)') " " IF (.NOT. cdft_control%becke_control%cavity_confine) THEN WRITE (output_unit, '(A)') & diff --git a/src/qs_scf_post_gpw.F b/src/qs_scf_post_gpw.F index a4fe7a7a25..16cd43613c 100644 --- a/src/qs_scf_post_gpw.F +++ b/src/qs_scf_post_gpw.F @@ -903,9 +903,9 @@ CONTAINS IF (p_loc_homo) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSE IF (dft_control%restricted & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN + ELSEIF (dft_control%restricted & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN CPABORT("ROKS works only with LOCALIZE METHOD NONE or JACOBI") ELSE ALLOCATE (occupied_orbs(dft_control%nspins)) @@ -1053,7 +1053,7 @@ CONTAINS IF (p_loc_mixed) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSE IF (dft_control%restricted) THEN + ELSEIF (dft_control%restricted) THEN IF (output_unit > 0) WRITE (output_unit, *) & " Unclear how we define MOs / localization in the restricted case... skipping" ELSE @@ -2277,7 +2277,7 @@ CONTAINS CALL section_vals_val_get(dft_section, "PRINT%DOS%NLUMO", i_val=nlumo_dos) IF (nlumo_dos == -1) THEN nlumo_required = -1 - ELSE IF (nlumo_required /= -1) THEN + ELSEIF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_dos) END IF END IF @@ -2285,7 +2285,7 @@ CONTAINS IF (defer_molden) THEN IF (nlumo_molden == -1) THEN nlumo_required = -1 - ELSE IF (nlumo_required /= -1) THEN + ELSEIF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_molden) END IF END IF @@ -3539,11 +3539,10 @@ CONTAINS IF (do_radius) THEN radius_type = radius_user CALL section_vals_val_get(input_section, "ATOMIC_RADII", r_vals=radii) - IF (.NOT. SIZE(radii) == nkind) THEN + IF (.NOT. SIZE(radii) == nkind) & CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF ELSE radius_type = radius_covalent END IF diff --git a/src/qs_scf_post_scf.F b/src/qs_scf_post_scf.F index 57ef526d5b..5287b69456 100644 --- a/src/qs_scf_post_scf.F +++ b/src/qs_scf_post_scf.F @@ -55,15 +55,15 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CALL scf_post_calculation_se(qs_env) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL wfn_localization_tb(qs_env, "DFTB") CALL scf_post_calculation_tb(qs_env, "DFTB", .FALSE.) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL wfn_localization_tb(qs_env, "xTB") CALL scf_post_calculation_tb(qs_env, "xTB", .FALSE.) - ELSE IF (dft_control%qs_control%ofgpw) THEN + ELSEIF (dft_control%qs_control%ofgpw) THEN CPWARN("No properties from PRINT section available for OFGPW methods") - ELSE IF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN + ELSEIF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN CALL optimize_lri_basis(qs_env) ELSE IF (PRESENT(wf_type)) THEN diff --git a/src/qs_scf_wfn_mix.F b/src/qs_scf_wfn_mix.F index 5fa98ca6f2..0830d2bd0a 100644 --- a/src/qs_scf_wfn_mix.F +++ b/src/qs_scf_wfn_mix.F @@ -193,11 +193,10 @@ CONTAINS ELSE IF (orig_type == wfn_mix_orig_external) THEN CALL section_vals_val_get(update_section, "ORIG_EXT_FILE_NAME", i_rep_section=i_rep, & c_val=read_file_name) - IF (read_file_name == "EMPTY") THEN + IF (read_file_name == "EMPTY") & CALL cp_abort(__LOCATION__, & "If ORIG_TYPE is set to EXTERNAL, a file name should be set in ORIG_EXT_FILE_NAME "// & "so that it can be used as the orginal MO.") - END IF ALLOCATE (mos_orig_ext(SIZE(mos))) DO ispin = 1, SIZE(mos) @@ -206,10 +205,9 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(read_file_name), exist=is_file) - IF (.NOT. is_file) THEN + IF (.NOT. is_file) & CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(read_file_name)) - END IF CALL open_file(file_name=read_file_name, & file_action="READ", & @@ -263,12 +261,10 @@ CONTAINS IF (my_for_rtp) THEN DO ispin = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) THEN + IF (mos_new(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) - END IF - IF (mos(1)%use_mo_coeff_b) THEN + IF (mos(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) - END IF END DO ELSE IF (scf_env%method == special_diag_method_nr) THEN @@ -287,13 +283,11 @@ CONTAINS DO ispin = 1, SIZE(mos_new) IF (overwrite_mos) THEN CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) THEN + IF (mos_new(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) - END IF END IF - IF (mos(1)%use_mo_coeff_b) THEN + IF (mos(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) - END IF END DO CALL write_mo_set_to_restart(mos_new, particle_set, dft_section=dft_section, & qs_kind_set=qs_kind_set) diff --git a/src/qs_subsys_types.F b/src/qs_subsys_types.F index 3fb4c80a20..0787f1db4f 100644 --- a/src/qs_subsys_types.F +++ b/src/qs_subsys_types.F @@ -77,15 +77,12 @@ CONTAINS CALL cp_subsys_release(subsys%cp_subsys) CALL cell_release(subsys%cell_ref) - IF (ASSOCIATED(subsys%qs_kind_set)) THEN + IF (ASSOCIATED(subsys%qs_kind_set)) & CALL deallocate_qs_kind_set(subsys%qs_kind_set) - END IF - IF (ASSOCIATED(subsys%energy)) THEN + IF (ASSOCIATED(subsys%energy)) & CALL deallocate_qs_energy(subsys%energy) - END IF - IF (ASSOCIATED(subsys%force)) THEN + IF (ASSOCIATED(subsys%force)) & CALL deallocate_qs_force(subsys%force) - END IF END SUBROUTINE qs_subsys_release diff --git a/src/qs_tddfpt2_densities.F b/src/qs_tddfpt2_densities.F index 63ce4065f6..c9c283e13b 100644 --- a/src/qs_tddfpt2_densities.F +++ b/src/qs_tddfpt2_densities.F @@ -100,9 +100,8 @@ CONTAINS END DO ! take into account that all MOs are doubly occupied in spin-restricted case - IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) THEN + IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) & CALL dbcsr_scale(rho_ij_ao(1)%matrix, 2.0_dp) - END IF CALL get_qs_env(qs_env, dft_control=dft_control) @@ -113,7 +112,7 @@ CONTAINS task_list_external=sub_env%task_list_orb_soft, & para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, local_rho_set=sub_env%local_rho_set, pw_env_sub=sub_env%pw_env) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL qs_rho_update_rho(rho_orb_struct, qs_env, & rho_xc_external=rho_xc_struct, & local_rho_set=sub_env%local_rho_set, & diff --git a/src/qs_tddfpt2_eigensolver.F b/src/qs_tddfpt2_eigensolver.F index 12900d5dbb..dcfa59166d 100644 --- a/src/qs_tddfpt2_eigensolver.F +++ b/src/qs_tddfpt2_eigensolver.F @@ -779,9 +779,8 @@ CONTAINS ! eref = e_virt - e_occ - lambda = e_virt - e_occ - (eref_scale*lambda + (1-eref_scale)*lambda); ! eref_new = e_virt - e_occ - eref_scale*lambda = eref + (1 - eref_scale)*lambda - IF (ABS(eref) < threshold) THEN + IF (ABS(eref) < threshold) & eref = eref + (1.0_dp - eref_scale)*lambda - END IF weights_ldata(irow_local, icol_local) = weights_ldata(irow_local, icol_local)/eref END DO @@ -931,9 +930,8 @@ CONTAINS conv = MAXVAL(ABS(evals_last(1:nstates) - evals(1:nstates))) nvects_exist = nvects_exist + nvects_new - IF (nvects_exist + nvects_new > max_krylov_vects) THEN + IF (nvects_exist + nvects_new > max_krylov_vects) & nvects_new = max_krylov_vects - nvects_exist - END IF IF (iter >= tddfpt_control%niters) nvects_new = 0 IF (conv > tddfpt_control%conv .AND. nvects_new > 0) THEN @@ -984,9 +982,8 @@ CONTAINS IF (iter_unit > 0) THEN nstates_conv = 0 DO istate = 1, nstates - IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) THEN + IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) & nstates_conv = nstates_conv + 1 - END IF END DO WRITE (iter_unit, '(T7,I8,T24,F7.1,T40,ES11.4,T66,I8)') iter, t2 - t1, conv, nstates_conv diff --git a/src/qs_tddfpt2_fhxc.F b/src/qs_tddfpt2_fhxc.F index a8b9dfbad0..6c4ba207e8 100644 --- a/src/qs_tddfpt2_fhxc.F +++ b/src/qs_tddfpt2_fhxc.F @@ -201,8 +201,8 @@ CONTAINS para_env_external=sub_env%para_env, & tddfpt_lri_env=kernel_env%lri_env, & tddfpt_lri_density=kernel_env%lri_density) - ELSE IF (dft_control%qs_control%lrigpw .OR. & - dft_control%qs_control%rigpw) THEN + ELSEIF (dft_control%qs_control%lrigpw .OR. & + dft_control%qs_control%rigpw) THEN CALL qs_rho_update_tddfpt(work_matrices%rho_orb_struct_sub, qs_env, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb, & @@ -216,7 +216,7 @@ CONTAINS para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, work_matrices%local_rho_set, & do_rho0=(.NOT. is_rks_triplets), pw_env_sub=sub_env%pw_env) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL qs_rho_update_rho(work_matrices%rho_orb_struct_sub, qs_env, & rho_xc_external=work_matrices%rho_xc_struct_sub, & local_rho_set=work_matrices%local_rho_set, & @@ -447,7 +447,7 @@ CONTAINS qs_env=qs_env, calculate_forces=.FALSE., gapw=gapw, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb_soft) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN IF (.NOT. is_rks_triplets) THEN CALL integrate_v_rspace(v_rspace=work_matrices%A_ia_rspace_sub(ispin), & hmat=work_matrices%A_ia_munu_sub(ispin), & diff --git a/src/qs_tddfpt2_fhxc_forces.F b/src/qs_tddfpt2_fhxc_forces.F index ca30d1ef23..535be9af2e 100644 --- a/src/qs_tddfpt2_fhxc_forces.F +++ b/src/qs_tddfpt2_fhxc_forces.F @@ -612,7 +612,7 @@ CONTAINS CALL qs_fgxc_analytic(rho, rhox, xc_section, weights, auxbas_pw_pool, & fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) END IF - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, & weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) @@ -633,7 +633,7 @@ CONTAINS IF (gapw .OR. gapw_xc) THEN IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, ex_env%local_rho_set%rho_atom_set, & local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, & @@ -820,7 +820,7 @@ CONTAINS END IF IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd derivatives of EXC not available") - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, & is_rks_triplets, weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau) @@ -909,7 +909,7 @@ CONTAINS IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, rho_atom_set, & rho_atom_set_f, rho_atom_set_g, & @@ -1562,7 +1562,7 @@ CONTAINS hfx, rbeta, spinfac, xfac REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tcharge, tv REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: gtcharge - REAL(KIND=dp), DIMENSION(3) :: fij, focoul, fodeb, foexch, rij + REAL(KIND=dp), DIMENSION(3) :: fij, fodeb, rij REAL(KIND=dp), DIMENSION(:, :), POINTER :: gab, pblock TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell @@ -1654,9 +1654,6 @@ CONTAINS cpmos => ex_env%cpmos - focoul = 0.0_dp - foexch = 0.0_dp - DO ispin = 1, nspins ct => work%ctransformed(ispin) CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf) @@ -1784,7 +1781,7 @@ CONTAINS IF (debug_forces) THEN fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3) CALL para_env%sum(fodeb) - focoul(1:3) = focoul(1:3) + fodeb(1:3) + IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Coul[X] ", fodeb END IF norb = nactive(ispin) ! forces from Lowdin charge derivative @@ -1993,7 +1990,7 @@ CONTAINS IF (debug_forces) THEN fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3) CALL para_env%sum(fodeb) - foexch(1:3) = foexch(1:3) + fodeb(1:3) + IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Exch[X] ", fodeb END IF END IF ! @@ -2002,11 +1999,6 @@ CONTAINS DEALLOCATE (tv) END DO - IF (debug_forces) THEN - IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Coul[X] ", focoul - IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Exch[X] ", foexch - END IF - CALL cp_fm_release(xtransformed) DEALLOCATE (tcharge, gtcharge) DEALLOCATE (first_sgf, last_sgf) diff --git a/src/qs_tddfpt2_forces.F b/src/qs_tddfpt2_forces.F index dc5dff3a35..35fc7b95f1 100644 --- a/src/qs_tddfpt2_forces.F +++ b/src/qs_tddfpt2_forces.F @@ -907,7 +907,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole) CALL hartree_local_create(hartree_local) CALL init_coulomb_local(hartree_local, natom) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -1415,7 +1415,6 @@ CONTAINS s_matrix => matrix_s(1, 1)%matrix CALL ao_charges(p_matrix, s_matrix, aocg, para_env) CALL ao_charges(matrix_pe, s_matrix, aocg1, para_env) - IF (nspins == 2) aocg1 = 0.5_dp*aocg1 DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=na) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) @@ -1436,13 +1435,13 @@ CONTAINS mcharge1(iatom) = SUM(charges1(iatom, :)) END DO ! Coulomb Kernel - CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge, & - matrix_pe) + CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge) ! DEALLOCATE (charges, mcharge, charges1, mcharge1) END IF focc = 2.0_dp + IF (nspins == 2) focc = 1.0_dp DO ispin = 1, nspins mos => gs_mos(ispin)%mos_occ CALL cp_fm_get_info(mos, ncol_global=norb) diff --git a/src/qs_tddfpt2_fprint.F b/src/qs_tddfpt2_fprint.F index 4eb8f2ab0e..8f89d0a44a 100644 --- a/src/qs_tddfpt2_fprint.F +++ b/src/qs_tddfpt2_fprint.F @@ -225,9 +225,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=debug_forces) ELSE CALL response_force(qs_env=qs_env, vh_rspace=ex_env%vh_rspace, & @@ -330,9 +330,9 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT| SE not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT| DFTB not available") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) CALL build_xtb_ks_matrix(qs_env, calculate_forces=.TRUE., just_energy=.FALSE.) ELSE diff --git a/src/qs_tddfpt2_methods.F b/src/qs_tddfpt2_methods.F index 0d5e1af192..9ca62a9333 100644 --- a/src/qs_tddfpt2_methods.F +++ b/src/qs_tddfpt2_methods.F @@ -285,15 +285,12 @@ CONTAINS CALL kernel_info(log_unit, dft_control, tddfpt_control, xc_section) IF (do_kpoints) THEN - IF (calc_forces) THEN + IF (calc_forces) & CPABORT("TDDFPT forces are not implemented for k-points") - END IF - IF (do_rixs) THEN + IF (do_rixs) & CPABORT("RIXS/TDDFPT is not implemented for k-points") - END IF - IF (do_soc) THEN + IF (do_soc) & CPABORT("TDDFPT-SOC is not implemented for k-points") - END IF CALL tddfpt_kpoint_independent_particle(qs_env, logger, tddfpt_control) CALL cp_print_key_finished_output(log_unit, & logger, & @@ -344,9 +341,8 @@ CONTAINS ! multiplicity of molecular system IF (nspins > 1) THEN mult = ABS(SIZE(gs_mos(1)%evals_occ) - SIZE(gs_mos(2)%evals_occ)) + 1 - IF (mult > 2) THEN + IF (mult > 2) & CALL cp_warn(__LOCATION__, "There is a convergence issue for multiplicity >= 3") - END IF ELSE IF (tddfpt_control%rks_triplets) THEN mult = 3 @@ -515,7 +511,7 @@ CONTAINS state_change = .FALSE. IF (ex_env%state > 0) THEN my_state = ex_env%state - ELSE IF (ex_env%state < 0) THEN + ELSEIF (ex_env%state < 0) THEN ! state following ALLOCATE (my_mos(nspins)) DO ispin = 1, nspins @@ -638,9 +634,8 @@ CONTAINS END DO DEALLOCATE (gs_mos) - IF (ASSOCIATED(matrix_ks_oep)) THEN + IF (ASSOCIATED(matrix_ks_oep)) & CALL dbcsr_deallocate_matrix_set(matrix_ks_oep) - END IF CALL timestop(handle) @@ -686,27 +681,21 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control, input=input, kpoints=kpoints) IF (dft_control%nimages > 1) THEN - IF (tddfpt_control%kernel /= tddfpt_kernel_none) THEN + IF (tddfpt_control%kernel /= tddfpt_kernel_none) & CPABORT("TDDFPT with k-points currently supports only KERNEL NONE") - END IF CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) THEN + IF (use_real_wfn) & CPABORT("K-point TDDFPT requires complex wavefunctions") - END IF - IF (tddfpt_control%spinflip /= no_sf_tddfpt) THEN + IF (tddfpt_control%spinflip /= no_sf_tddfpt) & CPABORT("Spin-flip TDDFPT is not implemented for k-points") - END IF - IF (tddfpt_control%do_smearing) THEN + IF (tddfpt_control%do_smearing) & CPABORT("Smeared-occupation TDDFPT is not implemented for k-points") - END IF - IF (tddfpt_control%oe_corr /= oe_none) THEN + IF (tddfpt_control%oe_corr /= oe_none) & CPABORT("Orbital-energy-corrected TDDFPT is not implemented for k-points") - END IF IF (tddfpt_control%dipole_form /= 0 .AND. & tddfpt_control%dipole_form /= tddfpt_dipole_velocity .AND. & - tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) THEN + tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) & CPABORT("K-point TDDFPT supports only velocity-form or SCF_MOMENT transition dipoles") - END IF END IF IF (tddfpt_control%nstates <= 0) THEN @@ -721,9 +710,8 @@ CONTAINS IF (dft_control%nimages > 1) THEN IF (tddfpt_control%do_exciton_descriptors .OR. & - tddfpt_control%do_directional_exciton_descriptors) THEN + tddfpt_control%do_directional_exciton_descriptors) & CPABORT("Exciton descriptors are not implemented for k-point TDDFPT") - END IF print_sub => section_vals_get_subs_vals(tddfpt_print_section, "NTO_ANALYSIS") CALL section_vals_get(print_sub, explicit=explicit) IF (explicit) CPABORT("NTO analysis is not implemented for k-point TDDFPT") @@ -1086,15 +1074,13 @@ CONTAINS ntrans_kpoint = 0 DO ispin = 1, nspins nvirt_spin(ispin) = nmo_spin(ispin) - homo_spin(ispin) - IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) THEN + IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) & CPABORT("At least one occupied and one unoccupied MO are required for k-point TDDFPT") - END IF ntrans_kpoint = ntrans_kpoint + homo_spin(ispin)*nvirt_spin(ispin) END DO ntrans_total = nkp*ntrans_kpoint - IF (ntrans_total <= 0) THEN + IF (ntrans_total <= 0) & CPABORT("No independent-particle k-point transitions available") - END IF ALLOCATE (transition_energy(ntrans_total), transition_dipole_re(ntrans_total, nderivs), & transition_dipole_im(ntrans_total, nderivs), oscillator_strength(ntrans_total), & @@ -1157,9 +1143,8 @@ CONTAINS IF (my_kpgrp) THEN CALL get_mo_set(mos_kp(1, ispin), eigenvalues=eigenvalues) CPASSERT(ASSOCIATED(eigenvalues)) - IF (para_env_kp%is_source()) THEN + IF (para_env_kp%is_source()) & eigenvalues_kp(1:nmo_spin(ispin)) = eigenvalues(1:nmo_spin(ispin)) - END IF IF (.NOT. use_scf_moment_dipoles) THEN CALL get_mo_set(mos_kp(1, ispin), mo_coeff=mo_coeff_re) CALL get_mo_set(mos_kp(2, ispin), mo_coeff=mo_coeff_im) @@ -1221,9 +1206,8 @@ CONTAINS trans_index = (ikp - 1)*ntrans_kpoint + spin_offset + & (iocc - 1)*nvirt_spin(ispin) + ivirt - homo_spin(ispin) gap = eigenvalues_kp(ivirt) - eigenvalues_kp(iocc) - IF (gap <= 0.0_dp) THEN + IF (gap <= 0.0_dp) & CPABORT("K-point TDDFPT requires positive occupied-virtual energy gaps") - END IF IF (use_scf_moment_dipoles) THEN oscillator_factor = SQRT(spin_factor*wkp(ikp)) dipole_re = REAL(kpoint_dipole(ispin, ikp, ideriv, iocc, ivirt), KIND=dp) @@ -1261,9 +1245,8 @@ CONTAINS END DO END DO - IF (ANY(transition_energy <= 0.0_dp)) THEN + IF (ANY(transition_energy <= 0.0_dp)) & CPABORT("K-point TDDFPT KERNEL NONE requires positive occupied-virtual energy gaps") - END IF CALL sort(transition_energy, ntrans_total, inds) nstates = MIN(tddfpt_control%nstates, ntrans_total) @@ -1988,7 +1971,7 @@ CONTAINS DO ispin = 1, nspins CPASSERT(.NOT. ASSOCIATED(gs_mos(ispin)%evals_occ_matrix)) END DO - ELSE IF (ewcut) THEN + ELSEIF (ewcut) THEN ! Filter orbitals wrt energy window DO ispin = 1, nspins DO i = 1, gs_mos(ispin)%nmo_occ diff --git a/src/qs_tddfpt2_properties.F b/src/qs_tddfpt2_properties.F index 3f32e85a70..0ea5e1abef 100644 --- a/src/qs_tddfpt2_properties.F +++ b/src/qs_tddfpt2_properties.F @@ -835,9 +835,8 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc - 1 /= para_env%mepos) THEN + IF (iproc - 1 /= para_env%mepos) & CALL recv_handlers(iproc)%wait() - END IF END DO ! compute total number of non-negligible excitations @@ -937,9 +936,8 @@ CONTAINS END IF ! deallocate temporary arrays - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & DEALLOCATE (weights_recv, weights_neg_abs_recv, inds_recv, inds) - END IF END DO DEALLOCATE (weights_local, inds_local) @@ -1527,7 +1525,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(a4,I3.3,I2.2,a11)') "NTO_STATE", istate, i, "_Hole_State" - ELSE IF (iset == 2) THEN + ELSEIF (iset == 2) THEN WRITE (filename, '(a4,I3.3,I2.2,a15)') "NTO_STATE", istate, i, "_Particle_State" END IF mpi_io = .TRUE. @@ -1536,7 +1534,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 - ELSE IF (iset == 2) THEN + ELSEIF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/qs_tddfpt2_restart.F b/src/qs_tddfpt2_restart.F index 4c2e0a02f5..8ed2934237 100644 --- a/src/qs_tddfpt2_restart.F +++ b/src/qs_tddfpt2_restart.F @@ -294,9 +294,8 @@ CONTAINS END DO END DO - IF (para_env_global%is_source()) THEN + IF (para_env_global%is_source()) & CALL close_file(unit_number=iunit) - END IF CALL timestop(handle) @@ -635,13 +634,11 @@ CONTAINS sum_sign_array(icol_global) = sum_sign_array(icol_global) + sign_int IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) THEN + IF (minrow_pos_array(icol_global) > irow_global) & minrow_pos_array(icol_global) = irow_global - END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) THEN + IF (minrow_neg_array(icol_global) > irow_global) & minrow_neg_array(icol_global) = irow_global - END IF END IF END DO diff --git a/src/qs_tddfpt2_stda_types.F b/src/qs_tddfpt2_stda_types.F index c175409e56..333da363e7 100644 --- a/src/qs_tddfpt2_stda_types.F +++ b/src/qs_tddfpt2_stda_types.F @@ -277,9 +277,8 @@ CONTAINS TYPE(stda_kind_type), POINTER :: kind_param - IF (ASSOCIATED(kind_param)) THEN + IF (ASSOCIATED(kind_param)) & CALL deallocate_stda_kind_param(kind_param) - END IF ALLOCATE (kind_param) diff --git a/src/qs_tddfpt2_stda_utils.F b/src/qs_tddfpt2_stda_utils.F index c98d3e93ef..68840bfd85 100644 --- a/src/qs_tddfpt2_stda_utils.F +++ b/src/qs_tddfpt2_stda_utils.F @@ -252,7 +252,7 @@ CONTAINS IF (dr < 1.e-6) THEN ! on site terms gblock(:, :) = gblock(:, :) + eta - ELSE IF (dr > rcut) THEN + ELSEIF (dr > rcut) THEN ! do nothing ELSE IF (dr < rcut - rsmooth) THEN @@ -408,11 +408,10 @@ CONTAINS CALL cp_fm_struct_release(fmstruct=fmstruct) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) THEN + IF (ndep /= 0) & CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") - END IF CALL copy_fm_to_dbcsr(fm_s_half, sm_h) CALL cp_fm_release(fm_s_half) CALL cp_fm_release(fm_work1) diff --git a/src/qs_tddfpt2_subgroups.F b/src/qs_tddfpt2_subgroups.F index 6097231eb9..009f80a27c 100644 --- a/src/qs_tddfpt2_subgroups.F +++ b/src/qs_tddfpt2_subgroups.F @@ -302,9 +302,8 @@ CONTAINS NULLIFY (sub_env%task_list_orb_soft, sub_env%task_list_aux_fit_soft) IF (sub_env%is_mgrid) THEN - IF (tddfpt_control%mgrid_is_explicit) THEN + IF (tddfpt_control%mgrid_is_explicit) & CALL init_tddfpt_mgrid(qs_control, tddfpt_control, mgrid_saved) - END IF IF (ASSOCIATED(weights)) THEN CPABORT('Redefining MGRID and integration weights not compatible') @@ -345,9 +344,8 @@ CONTAINS END IF END IF - IF (tddfpt_control%mgrid_is_explicit) THEN + IF (tddfpt_control%mgrid_is_explicit) & CALL restore_qs_mgrid(qs_control, mgrid_saved) - END IF ELSE CALL pw_env_retain(pw_env_global) sub_env%pw_env => pw_env_global @@ -382,7 +380,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, sub_env%local_rho_set%rho0_mpole) CALL hartree_local_create(sub_env%hartree_local) CALL init_coulomb_local(sub_env%hartree_local, natom) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -450,21 +448,17 @@ CONTAINS CALL timeset(routineN, handle) IF (sub_env%is_mgrid) THEN - IF (ASSOCIATED(sub_env%task_list_aux_fit)) THEN + IF (ASSOCIATED(sub_env%task_list_aux_fit)) & CALL deallocate_task_list(sub_env%task_list_aux_fit) - END IF - IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) THEN + IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) & CALL deallocate_task_list(sub_env%task_list_aux_fit_soft) - END IF - IF (ASSOCIATED(sub_env%task_list_orb)) THEN + IF (ASSOCIATED(sub_env%task_list_orb)) & CALL deallocate_task_list(sub_env%task_list_orb) - END IF - IF (ASSOCIATED(sub_env%task_list_orb_soft)) THEN + IF (ASSOCIATED(sub_env%task_list_orb_soft)) & CALL deallocate_task_list(sub_env%task_list_orb_soft) - END IF CALL release_neighbor_list_sets(sub_env%sab_aux_fit) CALL release_neighbor_list_sets(sub_env%sab_orb) @@ -474,9 +468,8 @@ CONTAINS DEALLOCATE (sub_env%dbcsr_dist) END IF - IF (ASSOCIATED(sub_env%dist_2d)) THEN + IF (ASSOCIATED(sub_env%dist_2d)) & CALL distribution_2d_release(sub_env%dist_2d) - END IF END IF ! GAPW @@ -519,9 +512,8 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) THEN + IF (ALLOCATED(sub_env%group_distribution)) & DEALLOCATE (sub_env%group_distribution) - END IF sub_env%is_split = .FALSE. @@ -586,9 +578,8 @@ CONTAINS END DO ! igrid == 0 if qs_control%cutoff is larger than the largest manually provided cutoff value; ! use the largest actual value - IF (igrid <= 0) THEN + IF (igrid <= 0) & qs_control%cutoff = qs_control%e_cutoff(1) - END IF ELSE qs_control%e_cutoff(1) = qs_control%cutoff DO igrid = 2, ngrids @@ -616,9 +607,8 @@ CONTAINS CALL timeset(routineN, handle) - IF (ASSOCIATED(qs_control%e_cutoff)) THEN + IF (ASSOCIATED(qs_control%e_cutoff)) & DEALLOCATE (qs_control%e_cutoff) - END IF qs_control%commensurate_mgrids = mgrid_saved%commensurate_mgrids qs_control%realspace_mgrids = mgrid_saved%realspace_mgrids diff --git a/src/qs_tddfpt2_types.F b/src/qs_tddfpt2_types.F index 19ea44ddac..0a9790800e 100644 --- a/src/qs_tddfpt2_types.F +++ b/src/qs_tddfpt2_types.F @@ -465,7 +465,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, work_matrices%local_rho_set%rho0_mpole) CALL hartree_local_create(work_matrices%hartree_local) CALL init_coulomb_local(work_matrices%hartree_local, natom) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -939,9 +939,8 @@ CONTAINS CALL cp_fm_release(work_matrices%slambda) DEALLOCATE (work_matrices%slambda) END IF - IF (ASSOCIATED(work_matrices%S_eigenvalues)) THEN + IF (ASSOCIATED(work_matrices%S_eigenvalues)) & DEALLOCATE (work_matrices%S_eigenvalues) - END IF ! Ewald IF (ASSOCIATED(work_matrices%ewald_env)) THEN CALL ewald_env_release(work_matrices%ewald_env) diff --git a/src/qs_tddfpt2_utils.F b/src/qs_tddfpt2_utils.F index 814d6db052..4a98dbc280 100644 --- a/src/qs_tddfpt2_utils.F +++ b/src/qs_tddfpt2_utils.F @@ -297,14 +297,12 @@ CONTAINS CALL section_vals_val_get(print_section, "NAMD_PRINT%PRINT_PHASES", l_val=print_phases) nmo_virt = nao - nmo_occ - IF (nlumo >= 0) THEN + IF (nlumo >= 0) & nmo_virt = MIN(nmo_virt, nlumo) - END IF - IF (nmo_virt <= 0) THEN + IF (nmo_virt <= 0) & CALL cp_abort(__LOCATION__, & 'At least one unoccupied molecular orbital is required to calculate excited states.') - END IF do_eigen = .FALSE. ! diagonalise the Kohn-Sham matrix one more time if the number of available unoccupied states are too small @@ -428,13 +426,11 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) THEN + IF (minrow_pos_array(icol_global) > irow_global) & minrow_pos_array(icol_global) = irow_global - END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) THEN + IF (minrow_neg_array(icol_global) > irow_global) & minrow_neg_array(icol_global) = irow_global - END IF END IF END DO END DO @@ -512,13 +508,11 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) THEN + IF (minrow_pos_array(icol_global) > irow_global) & minrow_pos_array(icol_global) = irow_global - END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) THEN + IF (minrow_neg_array(icol_global) > irow_global) & minrow_neg_array(icol_global) = irow_global - END IF END IF END DO END DO @@ -576,25 +570,20 @@ CONTAINS CALL timeset(routineN, handle) - IF (ALLOCATED(gs_mos%phases_occ)) THEN + IF (ALLOCATED(gs_mos%phases_occ)) & DEALLOCATE (gs_mos%phases_occ) - END IF - IF (ALLOCATED(gs_mos%evals_virt)) THEN + IF (ALLOCATED(gs_mos%evals_virt)) & DEALLOCATE (gs_mos%evals_virt) - END IF - IF (ALLOCATED(gs_mos%evals_occ)) THEN + IF (ALLOCATED(gs_mos%evals_occ)) & DEALLOCATE (gs_mos%evals_occ) - END IF - IF (ALLOCATED(gs_mos%phases_virt)) THEN + IF (ALLOCATED(gs_mos%phases_virt)) & DEALLOCATE (gs_mos%phases_virt) - END IF - IF (ALLOCATED(gs_mos%index_active)) THEN + IF (ALLOCATED(gs_mos%index_active)) & DEALLOCATE (gs_mos%index_active) - END IF IF (ASSOCIATED(gs_mos%evals_occ_matrix)) THEN CALL cp_fm_release(gs_mos%evals_occ_matrix) @@ -697,9 +686,9 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT with SE not possible") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT with DFTB not possible") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., & ext_ks_matrix=matrix_ks_oep) @@ -1143,10 +1132,9 @@ CONTAINS DO istate = 1, nstates IF (ASSOCIATED(evects(1, istate)%matrix_struct)) THEN ! Initial guess vector read from restart file - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(T7,I8,T28,A19,T60,F14.5)') & - istate, "*** restarted ***", evals(istate)*evolt - END IF + istate, "*** restarted ***", evals(istate)*evolt ELSE ! New initial guess vector ! @@ -1178,10 +1166,9 @@ CONTAINS ! Assign initial guess for excitation energy evals(istate) = e_virt_minus_occ(istate) - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(T7,I8,T24,I8,T37,A5,T45,I8,T54,A5,T60,F14.5)') & - istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt - END IF + istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt DO jspin = 1, SIZE(evects, 1) ! .NOT. ASSOCIATED(evects(jspin, istate)%matrix_struct)) diff --git a/src/qs_tensors.F b/src/qs_tensors.F index 01298654b6..ca92892f16 100644 --- a/src/qs_tensors.F +++ b/src/qs_tensors.F @@ -713,7 +713,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -722,7 +722,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1030,7 +1030,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1039,7 +1039,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1262,7 +1262,7 @@ CONTAINS IF (do_kpoints_prv) THEN prefac = 0.5_dp - ELSE IF (nl_3c%sym == symmetric_jk) THEN + ELSEIF (nl_3c%sym == symmetric_jk) THEN IF (jatom == katom) THEN prefac = 0.5_dp ELSE @@ -1548,7 +1548,7 @@ CONTAINS END DO END DO - ELSE IF (nl_3c%sym == symmetric_jk) THEN + ELSEIF (nl_3c%sym == symmetric_jk) THEN !Add the transpose of t3c_der_j to t3c_der_k to get the fully populated tensor CALL dbt_create(t3c_der_k(1, 1, 1), t3c_tmp) DO i_xyz = 1, 3 @@ -1567,7 +1567,7 @@ CONTAINS END DO CALL dbt_destroy(t3c_tmp) - ELSE IF (nl_3c%sym == symmetric_none) THEN + ELSEIF (nl_3c%sym == symmetric_none) THEN DO i_xyz = 1, 3 DO kcell = 1, ncell_RI DO jcell = 1, nimg @@ -1701,7 +1701,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1710,7 +1710,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2238,7 +2238,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2247,7 +2247,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2454,7 +2454,7 @@ CONTAINS ELSE prefac = 1.0_dp END IF - ELSE IF (nl_3c%sym == symmetric_ij) THEN + ELSEIF (nl_3c%sym == symmetric_ij) THEN IF (iatom == jatom) THEN ! factor 0.5 due to double-counting of diagonal blocks ! (we desymmetrize by adding transpose) @@ -2689,13 +2689,13 @@ CONTAINS END DO CALL dbt_destroy(t_3c_tmp) END IF - ELSE IF (nl_3c%sym == symmetric_ij) THEN + ELSEIF (nl_3c%sym == symmetric_ij) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps/2) END DO END DO - ELSE IF (nl_3c%sym == symmetric_none) THEN + ELSEIF (nl_3c%sym == symmetric_none) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps) diff --git a/src/qs_update_s_mstruct.F b/src/qs_update_s_mstruct.F index bee9f33d9e..dd9017adf9 100644 --- a/src/qs_update_s_mstruct.F +++ b/src/qs_update_s_mstruct.F @@ -227,9 +227,8 @@ CONTAINS IF (ASSOCIATED(qs_env%kg_env%subset)) THEN DO isub = 1, qs_env%kg_env%nsubsets - IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) THEN + IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) & CALL deallocate_task_list(qs_env%kg_env%subset(isub)%task_list) - END IF END DO ELSE ALLOCATE (qs_env%kg_env%subset(qs_env%kg_env%nsubsets)) diff --git a/src/qs_vcd_utils.F b/src/qs_vcd_utils.F index 75b0ff3b6c..379326e61d 100644 --- a/src/qs_vcd_utils.F +++ b/src/qs_vcd_utils.F @@ -153,9 +153,8 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "MAGNETIC_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) THEN + IF (reference == use_mom_ref_user) & CPABORT("User-defined reference point should be given explicitly") - END IF END IF CALL get_reference_point(rpoint=vcd_env%magnetic_origin, qs_env=qs_env, & @@ -168,9 +167,8 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "SPATIAL_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) THEN + IF (reference == use_mom_ref_user) & CPABORT("User-defined reference point should be given explicitly") - END IF END IF CALL get_reference_point(rpoint=vcd_env%spatial_origin, qs_env=qs_env, & @@ -826,10 +824,9 @@ CONTAINS + apt_total_nvpt(2, 2, l) & + apt_total_nvpt(3, 3, l))/3._dp DO i = 1, 3 - IF (vcd_env%output_unit > 0) THEN + IF (vcd_env%output_unit > 0) & WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", apt_total_nvpt(i, :, l) - END IF + "NVP | ", apt_total_nvpt(i, :, l) END DO END DO @@ -839,10 +836,9 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'NVP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) THEN + IF (vcd_env%output_unit > 0) & WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) - END IF + "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) END DO END DO @@ -853,10 +849,9 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'MFP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) THEN + IF (vcd_env%output_unit > 0) & WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "MFP | ", vcd_env%aat_atom_mfp(i, :, l) - END IF + "MFP | ", vcd_env%aat_atom_mfp(i, :, l) END DO END DO END IF diff --git a/src/qs_vxc.F b/src/qs_vxc.F index a3410e78ac..924ff307d4 100644 --- a/src/qs_vxc.F +++ b/src/qs_vxc.F @@ -206,13 +206,11 @@ CONTAINS ! test if the real space density is available CPASSERT(ASSOCIATED(rho_struct)) - IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) THEN + IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) & CPABORT("nspins must be 1 or 2") - END IF mspin = SIZE(rho_struct_r) - IF (dft_control%nspins == 2 .AND. mspin == 1) THEN + IF (dft_control%nspins == 2 .AND. mspin == 1) & CPABORT("Spin count mismatch") - END IF ! there are some options related to SIC here. ! Normal DFT computes E(rho_alpha,rho_beta) (or its variant E(2*rho_alpha) for non-LSD) @@ -244,9 +242,8 @@ CONTAINS sic_scaling_b_zero = .FALSE. END IF - IF (PRESENT(pw_env_external)) THEN + IF (PRESENT(pw_env_external)) & pw_env => pw_env_external - END IF CALL pw_env_get(pw_env, xc_pw_pool=xc_pw_pool, auxbas_pw_pool=auxbas_pw_pool) uf_grid = .NOT. pw_grid_compare(auxbas_pw_pool%pw_grid, xc_pw_pool%pw_grid) @@ -762,7 +759,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_struct_g, rho_r, rho_g) - ELSE IF (ASSOCIATED(rho_struct_r)) THEN + ELSEIF (ASSOCIATED(rho_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_struct_r, rho_r, rho_g) ELSE CPABORT("Fine Grid in qs_xc_density requires rho_r or rho_g") @@ -770,7 +767,7 @@ CONTAINS IF (tau_r_valid) THEN IF (tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_struct_g, tau_r, tau_g) - ELSE IF (ASSOCIATED(tau_struct_r)) THEN + ELSEIF (ASSOCIATED(tau_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_struct_r, tau_r, tau_g) ELSE CPABORT("Fine Grid in qs_xc_density requires tau_r or tau_g") diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index 34110e06a9..77ca466195 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -15,8 +15,6 @@ MODULE qs_vxc_atom USE basis_set_types, ONLY: get_gto_basis_set,& gto_basis_set_type USE cp_control_types, ONLY: dft_control_type - USE external_potential_types, ONLY: gth_potential_type,& - sgp_potential_type USE input_constants, ONLY: xc_none USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type,& @@ -122,16 +120,14 @@ CONTAINS INTEGER :: bo(2), gapw_density_partition, handle, & iat, iatom, idir, ikind, ir, jdir, & - myfun, na, natom, nr, nspins, num_pe, & - zatom + myfun, na, natom, nr, nspins, num_pe INTEGER, DIMENSION(2, 3) :: bounds INTEGER, DIMENSION(:), POINTER :: atom_list LOGICAL :: accint, donlcc, evaluate_hard, evaluate_soft, gradient_f, lsd, & my_calculate_forces, nlcc, paw_atom, skala_atom_grid, tau_f, use_virial REAL(dp) :: agr, alpha, density_cut, exc_h, exc_s, & gradient_cut, & - my_adiabatic_rescale_factor, tau_cut, & - zeff + my_adiabatic_rescale_factor, tau_cut REAL(dp), DIMENSION(1, 1, 1) :: tau_d REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d REAL(dp), DIMENSION(3) :: skala_atom_force_h, skala_atom_force_s @@ -144,7 +140,6 @@ CONTAINS TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(dft_control_type), POINTER :: dft_control TYPE(grid_atom_type), POINTER :: grid_atom - TYPE(gth_potential_type), POINTER :: gth_potential TYPE(gto_basis_set_type), POINTER :: basis_1c TYPE(harmonics_atom_type), POINTER :: harmonics TYPE(mp_para_env_type), POINTER :: para_env @@ -156,7 +151,6 @@ CONTAINS TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set TYPE(rho_atom_type), POINTER :: rho_atom TYPE(section_vals_type), POINTER :: input, my_xc_section, xc_fun_section - TYPE(sgp_potential_type), POINTER :: sgp_potential TYPE(tau_basis_cache_type) :: tau_basis_cache TYPE(virial_type), POINTER :: virial TYPE(xc_derivative_set_type) :: deriv_set @@ -171,7 +165,6 @@ CONTAINS NULLIFY (my_kind_set) NULLIFY (atomic_kind_set) NULLIFY (grid_atom) - NULLIFY (gth_potential) NULLIFY (force) NULLIFY (harmonics) NULLIFY (input) @@ -180,7 +173,6 @@ CONTAINS NULLIFY (rho_atom) NULLIFY (my_rho_atom_set) NULLIFY (rho_nlcc) - NULLIFY (sgp_potential) NULLIFY (virial) my_calculate_forces = .FALSE. IF (PRESENT(calculate_forces)) my_calculate_forces = calculate_forces @@ -258,17 +250,11 @@ CONTAINS DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom) - NULLIFY (gth_potential, sgp_potential) CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, & - gth_potential=gth_potential, harmonics=harmonics, & - grid_atom=grid_atom, sgp_potential=sgp_potential, & - zatom=zatom, zeff=zeff) + harmonics=harmonics, grid_atom=grid_atom) CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C") IF (.NOT. paw_atom) CYCLE - IF (skala_atom_grid .AND. & - (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. & - ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE nr = grid_atom%nr na = grid_atom%ng_sphere @@ -996,7 +982,7 @@ CONTAINS lsd = .TRUE. scale_rho = .TRUE. END IF - ELSE IF (PRESENT(do_triplet)) THEN + ELSEIF (PRESENT(do_triplet)) THEN IF (nspins == 1 .AND. do_triplet) lsd = .TRUE. END IF diff --git a/src/qs_wannier90.F b/src/qs_wannier90.F index ad9bb42de0..b2c7989282 100644 --- a/src/qs_wannier90.F +++ b/src/qs_wannier90.F @@ -57,9 +57,8 @@ MODULE qs_wannier90 kpoint_initialize_mo_set,& kpoint_initialize_mos,& rskp_transform - USE kpoint_mo_symmetry_methods, ONLY: kpoint_same_periodic,& - kpoint_transform_scf_mo USE kpoint_types, ONLY: get_kpoint_info,& + kind_rotmat_type,& kpoint_create,& kpoint_env_type,& kpoint_release,& @@ -1169,12 +1168,12 @@ CONTAINS num_candidates = 0 ! Little-group operations can reach the same target k-point; keep the first valid eigenspace. DO isym_try = 1, kpsym%nwred - IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & + IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE num_candidates = num_candidates + 1 - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, & - candidate_reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, & + candidate_reason) IF (.NOT. ok) THEN reason = candidate_reason CYCLE @@ -1192,9 +1191,9 @@ CONTAINS END IF IF (.NOT. ok) THEN IF (source_window) THEN - CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, & - dst_real_full, dst_imag_full, qs_kpoint, & - ikred, isym_try, para_env, ok, candidate_reason) + CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, & + dst_real_full, dst_imag_full, qs_kpoint, & + ikred, isym_try, para_env, ok, candidate_reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, & dst_real, dst_imag, matrix_s, & @@ -1233,15 +1232,15 @@ CONTAINS WRITE (reason, "(A,I0,A,ES9.2,A,I0,A,A32)") & "atom/AO W90 guarded: best/", num_candidates, "=", best_residual, & " k=", ik, " ", TRIM(best_reason) - ELSE IF (.NOT. ok .AND. num_candidates == 0) THEN + ELSEIF (.NOT. ok .AND. num_candidates == 0) THEN reason = "no matching SCF symmetry operation candidate" END IF ELSE reason = "SCF k-point symmetry operation is not available" END IF ELSE - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) END IF IF (ok .AND. sym_index(ik) <= 0) THEN ! Even a direct k-point copy must be a closed H(k),S(k) subspace. This catches @@ -1252,9 +1251,9 @@ CONTAINS ok, reason, aligned_blocks, aligned_max_size, & aligned_min_svalue, candidate_residual) IF (.NOT. ok .AND. source_window) THEN - CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, dst_real_full, & - dst_imag_full, qs_kpoint, ikred, sym_index(ik), & - para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, dst_real_full, & + dst_imag_full, qs_kpoint, ikred, sym_index(ik), & + para_env, ok, reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, dst_real, & dst_imag, matrix_s, matrix_ks, & @@ -1263,7 +1262,7 @@ CONTAINS reason, source_window_min_svalue, & candidate_residual) END IF - ELSE IF (.NOT. ok) THEN + ELSEIF (.NOT. ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real, dst_imag, dst_real, dst_imag, & matrix_s, matrix_ks, kpoint%xkp(1:3, ik), & cell_to_index, sab_nl, ispin, & @@ -1724,8 +1723,8 @@ CONTAINS best_residual = 0.0_dp best_svalue = 0.0_dp IF (sym_index(ik) <= 0) THEN - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) IF (ok) THEN CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, matrix_s, & kpoint%xkp(1:3, ik), cell_to_index, sab_nl, & @@ -1753,14 +1752,14 @@ CONTAINS END IF END IF END IF - ELSE IF (ASSOCIATED(qs_kpoint%kp_sym)) THEN + ELSEIF (ASSOCIATED(qs_kpoint%kp_sym)) THEN kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym IF (ASSOCIATED(kpsym)) THEN DO isym_try = 1, kpsym%nwred - IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & + IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, reason) IF (.NOT. ok) CYCLE CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, & matrix_s, kpoint%xkp(1:3, ik), cell_to_index, & @@ -2616,7 +2615,7 @@ CONTAINS ik_match = 0 DO ik = 1, SIZE(xkp_mesh, 2) - IF (kpoint_same_periodic(xkp_mesh(1:3, ik), xkp_search)) THEN + IF (same_periodic_kpoint(xkp_mesh(1:3, ik), xkp_search)) THEN ik_match = ik RETURN END IF @@ -2624,6 +2623,209 @@ CONTAINS END FUNCTION find_matching_kpoint +! ************************************************************************************************** +!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. +!> \param xkp_a first k-point +!> \param xkp_b second k-point +!> \return true if the k-points are equivalent +! ************************************************************************************************** + LOGICAL FUNCTION same_periodic_kpoint(xkp_a, xkp_b) RESULT(same) + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b + + REAL(KIND=dp), DIMENSION(3) :: diff + + diff(1:3) = xkp_a(1:3) - xkp_b(1:3) + diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) + same = SUM(ABS(diff(1:3))) < 1.0e-8_dp + + END FUNCTION same_periodic_kpoint + +! ************************************************************************************************** +!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. +!> \param src_real real part of source MO coefficients +!> \param src_imag imaginary part of source MO coefficients +!> \param dst_real real part of transformed MO coefficients +!> \param dst_imag imaginary part of transformed MO coefficients +!> \param qs_kpoint SCF k-point object containing symmetry operations +!> \param ikred representative k-point index +!> \param isym symmetry operation index; 0 direct copy, -1 time reversal +!> \param para_env global parallel environment +!> \param success true if the transformation was performed +!> \param reason diagnostic message +! ************************************************************************************************** + SUBROUTINE transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & + isym, para_env, success, reason) + TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: ikred, isym + TYPE(mp_para_env_type), POINTER :: para_env + LOGICAL, INTENT(OUT) :: success + CHARACTER(LEN=*), INTENT(OUT) :: reason + + INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & + nmo, rot_slot, source_atom, source_dim, target_atom, target_dim + INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start + LOGICAL :: reverse_phase, time_reversal + REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & + phase_imag, phase_real, sinkl + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r + REAL(KIND=dp), DIMENSION(3) :: xkp_phase + REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat + TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot + TYPE(kpoint_sym_type), POINTER :: kpsym + + success = .FALSE. + reason = "" + IF (isym == 0) THEN + CALL cp_fm_copy_general(src_real, dst_real, para_env) + CALL cp_fm_copy_general(src_imag, dst_imag, para_env) + success = .TRUE. + RETURN + END IF + + CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) + ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) + CALL cp_fm_get_submatrix(src_real, src_r) + CALL cp_fm_get_submatrix(src_imag, src_i) + dst_r(:, :) = 0.0_dp + dst_i(:, :) = 0.0_dp + + IF (isym == -1) THEN + dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) + dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i) + success = .TRUE. + RETURN + END IF + + IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN + reason = "SCF symmetry operation data are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym + IF (.NOT. ASSOCIATED(kpsym)) THEN + reason = "SCF k-point symmetry operation is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (isym > kpsym%nwred) THEN + reason = "SCF k-point symmetry operation index is out of range" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN + reason = "SCF atom mappings or basis rotation matrices are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + + rot_slot = find_wannier90_rotation_slot(qs_kpoint, kpsym%rotp(isym)) + IF (rot_slot == 0) THEN + reason = "could not match the SCF symmetry operation to a basis rotation" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) + natom = SIZE(qs_kpoint%atype) + ALLOCATE (ao_start(natom), ao_size(natom)) + irow = 1 + DO iatom = 1, natom + ikind = qs_kpoint%atype(iatom) + IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN + reason = "a required basis rotation matrix is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + ao_start(iatom) = irow + ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) + irow = irow + ao_size(iatom) + END DO + IF (irow - 1 /= nao) THEN + reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + + time_reversal = kpsym%rotp(isym) < 0 + reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) + IF (ASSOCIATED(kpsym%phase_mode)) THEN + IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 + END IF + xkp_phase(1:3) = kpsym%xkp(1:3, isym) + DO iatom = 1, natom + source_atom = iatom + target_atom = kpsym%f0(iatom, isym) + ikind = qs_kpoint%atype(source_atom) + rotmat => kind_rot(ikind)%rmat + source_dim = ao_size(source_atom) + target_dim = ao_size(target_atom) + IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN + reason = "basis rotation dimensions do not match the atom/AO symmetry transform" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & + REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & + REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) + IF (ASSOCIATED(kpsym%kgphase)) THEN + arg = arg + kpsym%kgphase(source_atom, isym) + END IF + IF (reverse_phase) arg = -arg + coskl = COS(twopi*arg) + sinkl = SIN(twopi*arg) + DO imo = 1, nmo + DO irow_work = 1, source_dim + irow_source = ao_start(source_atom) + irow_work - 1 + coeff_real = src_r(irow_source, imo) + coeff_imag = src_i(irow_source, imo) + IF (time_reversal) coeff_imag = -coeff_imag + phase_real = coskl*coeff_real - sinkl*coeff_imag + phase_imag = sinkl*coeff_real + coskl*coeff_imag + DO iao = 1, target_dim + irow_target = ao_start(target_atom) + iao - 1 + dst_r(irow_target, imo) = dst_r(irow_target, imo) + & + rotmat(iao, irow_work)*phase_real + dst_i(irow_target, imo) = dst_i(irow_target, imo) + & + rotmat(iao, irow_work)*phase_imag + END DO + END DO + END DO + END DO + + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + success = .TRUE. + + END SUBROUTINE transform_wannier90_scf_mo + +! ************************************************************************************************** +!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. +!> \param qs_kpoint SCF k-point object +!> \param rotp signed operation identifier +!> \return rotation slot, or zero when no slot matches +! ************************************************************************************************** + INTEGER FUNCTION find_wannier90_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: rotp + + INTEGER :: irot, rot_abs + + rot_slot = 0 + rot_abs = ABS(rotp) + IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN + DO irot = 1, SIZE(qs_kpoint%ibrot) + IF (rot_abs == qs_kpoint%ibrot(irot)) THEN + rot_slot = irot + RETURN + END IF + END DO + + END FUNCTION find_wannier90_rotation_slot + ! ************************************************************************************************** !> \brief Infer a tensor-product Wannier90 mesh from explicit fractional k-point coordinates. !> \param kpt_latt explicit k-point coordinates in reciprocal-lattice units diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index e70607cffd..af061e3cea 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -761,9 +761,8 @@ CONTAINS END IF END SELECT - IF (PRESENT(extrapolation_method_nr)) THEN + IF (PRESENT(extrapolation_method_nr)) & extrapolation_method_nr = actual_extrapolation_method_nr - END IF my_orthogonal_wf = .FALSE. SELECT CASE (actual_extrapolation_method_nr) @@ -2306,9 +2305,8 @@ CONTAINS wfi_linear_ps_method_nr, wfi_ps_method_nr, & wfi_aspc_nr, wfi_gext_proj_nr, wfi_gext_proj_qtr_nr) IF (qs_env%wf_history%snapshot_count >= 2) THEN - IF (debug_this_module .AND. io_unit > 0) THEN + IF (debug_this_module .AND. io_unit > 0) & WRITE (io_unit, FMT="(T2,A)") "QS| Purging WFN history" - END IF CALL wfi_create(wf_history, interpolation_method_nr= & dft_control%qs_control%wf_interpolation_method_nr, & extrapolation_order=dft_control%qs_control%wf_extrapolation_order, & diff --git a/src/replica_methods.F b/src/replica_methods.F index b8a1de1b67..0fd4b3b08c 100644 --- a/src/replica_methods.F +++ b/src/replica_methods.F @@ -295,9 +295,8 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) THEN + IF (.NOT. ASSOCIATED(rep_env)) & CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) - END IF NULLIFY (qs_env, dft_control, subsys) CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() diff --git a/src/replica_types.F b/src/replica_types.F index 41f96a58b2..646349fcae 100644 --- a/src/replica_types.F +++ b/src/replica_types.F @@ -206,9 +206,8 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) THEN + IF (.NOT. ASSOCIATED(rep_env)) & CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) - END IF CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() CALL cp_rm_iter_level(iteration_info=logger%iter_info, & diff --git a/src/response_solver.F b/src/response_solver.F index 34bbcf3164..9985ca3402 100644 --- a/src/response_solver.F +++ b/src/response_solver.F @@ -1244,7 +1244,7 @@ CONTAINS CALL pw_zero(vhxc_rspace) IF (gapw) THEN CALL pw_transfer(v_hartree_rspace_gs, vhxc_rspace) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL pw_transfer(vh_rspace, vhxc_rspace) END IF CALL integrate_v_rspace(v_rspace=vhxc_rspace, & @@ -1795,7 +1795,7 @@ CONTAINS CALL pw_zero(v_xc(ispin)) IF (gapw) THEN ! Hartree potential of response density CALL pw_axpy(v_hartree_rspace_t, v_xc(ispin)) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL pw_axpy(zv_hartree_rspace, v_xc(ispin)) END IF CALL integrate_v_rspace(qs_env=qs_env, & @@ -2771,7 +2771,7 @@ CONTAINS mcharge1(iatom) = SUM(charges1(iatom, :)) END DO ! Coulomb Kernel - CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge, mpa) + CALL xtb_coulomb_hessian(qs_env, matrix_hz, charges1, mcharge1, mcharge) CALL calc_xtb_ehess_force(qs_env, p_matrix, mpa, charges, mcharge, charges1, & mcharge1, debug_forces) ! diff --git a/src/restraint.F b/src/restraint.F index 53c602452a..4b2d6d7738 100644 --- a/src/restraint.F +++ b/src/restraint.F @@ -442,9 +442,9 @@ CONTAINS r0_13(:) = particle_set(index_a)%r - particle_set(index_c)%r r0_23(:) = particle_set(index_b)%r - particle_set(index_c)%r - rab = NORM2(r0_12) - rac = NORM2(r0_13) - rbc = NORM2(r0_23) + rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) + rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) + rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) tab = rab - g3x3_list(ng3x3)%dab tac = rac - g3x3_list(ng3x3)%dac tbc = rbc - g3x3_list(ng3x3)%dbc @@ -508,12 +508,12 @@ CONTAINS r0_24(:) = particle_set(index_b)%r - particle_set(index_d)%r r0_34(:) = particle_set(index_c)%r - particle_set(index_d)%r - rab = NORM2(r0_12) - rac = NORM2(r0_13) - rad = NORM2(r0_14) - rbc = NORM2(r0_23) - rbd = NORM2(r0_24) - rcd = NORM2(r0_34) + rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) + rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) + rad = SQRT(DOT_PRODUCT(r0_14, r0_14)) + rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) + rbd = SQRT(DOT_PRODUCT(r0_24, r0_24)) + rcd = SQRT(DOT_PRODUCT(r0_34, r0_34)) tab = rab - g4x6_list(ng4x6)%dab tac = rac - g4x6_list(ng4x6)%dac diff --git a/src/rpa_grad.F b/src/rpa_grad.F index 2ea5e679e9..a24334cf14 100644 --- a/src/rpa_grad.F +++ b/src/rpa_grad.F @@ -1054,9 +1054,8 @@ CONTAINS mem_per_block = REAL(number_of_elements_per_blk, KIND=dp)*8.0_dp number_of_parallel_channels = MAX(1, MIN(MAXVAL(grid) - 1, FLOOR(mem_real/mem_per_block))) CALL para_env%min(number_of_parallel_channels) - IF (mp2_env%ri_grad%max_parallel_comm > 0) THEN + IF (mp2_env%ri_grad%max_parallel_comm > 0) & number_of_parallel_channels = MIN(number_of_parallel_channels, mp2_env%ri_grad%max_parallel_comm) - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,T75,I6)') 'GRAD_INFO| Number of parallel communication channels:', number_of_parallel_channels @@ -1672,13 +1671,11 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) THEN + IF (ALLOCATED(index2send(pcol_send)%array)) & size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) - END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN + IF (ALLOCATED(index2recv(pcol_recv)%array)) & size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) - END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -1832,13 +1829,11 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) THEN + IF (ALLOCATED(index2send(pcol_send)%array)) & size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) - END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN + IF (ALLOCATED(index2recv(pcol_recv)%array)) & size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) - END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -2278,18 +2273,14 @@ CONTAINS DO ispin = 1, nspins DO pcol = 0, SIZE(sos_mp2_work_occ(ispin)%index2send, 1) - 1 - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - END IF - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - END IF - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) - END IF - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) - END IF END DO DEALLOCATE (sos_mp2_work_occ(ispin)%index2send, & sos_mp2_work_occ(ispin)%index2recv, & @@ -2318,8 +2309,7 @@ CONTAINS mp2_env%ri_grad%P_ij(ispin)%array(:, :) = 0.5_dp*(mp2_env%ri_grad%P_ij(ispin)%array + & TRANSPOSE(mp2_env%ri_grad%P_ij(ispin)%array)) - ! The first index of P_ab has to be distributed within the subgroups, - ! so sum it up first and add the required elements later + ! The first index of P_ab has to be distributed within the subgroups, so sum it up first and add the required elements later CALL para_env%sum(sos_mp2_work_virt(ispin)%P) itmp = get_limit(virtual(ispin), para_env_sub%num_pe, para_env_sub%mepos) diff --git a/src/rpa_gw_kpoints_util.F b/src/rpa_gw_kpoints_util.F index 00699efc4f..460a46aaa6 100644 --- a/src/rpa_gw_kpoints_util.F +++ b/src/rpa_gw_kpoints_util.F @@ -1315,9 +1315,8 @@ CONTAINS ELSE IF (kpoint_weights_W_method == kp_weights_W_tailored .OR. & kpoint_weights_W_method == kp_weights_W_auto) THEN - IF (kpoint_weights_W_method == kp_weights_W_tailored) THEN + IF (kpoint_weights_W_method == kp_weights_W_tailored) & exp_kpoints = qs_env%mp2_env%ri_rpa_im_time%exp_tailored_weights - END IF IF (kpoint_weights_W_method == kp_weights_W_auto) THEN IF (SUM(periodic) == 2) exp_kpoints = -1.0_dp diff --git a/src/rpa_gw_sigma_x.F b/src/rpa_gw_sigma_x.F index 0998afb0ef..d0051d92aa 100644 --- a/src/rpa_gw_sigma_x.F +++ b/src/rpa_gw_sigma_x.F @@ -591,7 +591,7 @@ CONTAINS homo, max_corr_lev_virt, & homo_reduced_bse, virtual_reduced_bse, & homo_startindex_bse, virtual_startindex_bse, & - mp2_env%bse%bse_cutoff_occ, mp2_env%bse%bse_cutoff_empty) + mp2_env) IF (gw_corr_lev_occ == -2) THEN CPWARN("BSE cutoff overwrites user input for CORR_MOS_OCC") gw_corr_lev_occ = homo_reduced_bse diff --git a/src/rpa_im_time.F b/src/rpa_im_time.F index 8081575ae5..5c1054cbb8 100644 --- a/src/rpa_im_time.F +++ b/src/rpa_im_time.F @@ -477,9 +477,8 @@ CONTAINS first_cycle_im_time = .FALSE. - IF (jquad == 1 .AND. flops_2 == 0) THEN + IF (jquad == 1 .AND. flops_2 == 0) & has_mat_P_blocks(i_cell_T, i_mem, j_mem, i_cell_R_1, i_cell_R_2) = .FALSE. - END IF END DO END DO diff --git a/src/rpa_main.F b/src/rpa_main.F index 0c4e4bd14b..294525cce1 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -192,16 +192,15 @@ CONTAINS REAL(KIND=dp), INTENT(OUT) :: Erpa TYPE(mp2_type), INTENT(INOUT) :: mp2_env TYPE(three_dim_real_array), DIMENSION(:), & - INTENT(INOUT) :: BIb_C, BIb_C_gw, BIb_C_bse_ij, & - BIb_C_bse_ab + INTENT(INOUT) :: BIb_C, BIb_C_gw + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & + INTENT(INOUT) :: BIb_C_bse_ij, BIb_C_bse_ab TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub INTEGER, INTENT(INOUT) :: color_sub TYPE(group_dist_d1_type), INTENT(INOUT) :: gd_array TYPE(group_dist_d1_type), DIMENSION(:), & INTENT(INOUT) :: gd_B_virtual - TYPE(group_dist_d1_type), INTENT(INOUT) :: gd_B_all - TYPE(group_dist_d1_type), DIMENSION(:), & - INTENT(INOUT) :: gd_B_occ_bse, gd_B_virt_bse + TYPE(group_dist_d1_type), INTENT(INOUT) :: gd_B_all, gd_B_occ_bse, gd_B_virt_bse TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: mo_coeff TYPE(cp_fm_type), INTENT(IN) :: fm_matrix_PQ TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_matrix_L_kpoints, & @@ -214,9 +213,8 @@ CONTAINS INTEGER, INTENT(IN) :: nmo INTEGER, DIMENSION(:), INTENT(IN) :: homo INTEGER, INTENT(IN) :: dimen_RI, dimen_RI_red - INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, & - bse_lev_virt - INTEGER, INTENT(IN) :: unit_nr + INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt + INTEGER, INTENT(IN) :: bse_lev_virt, unit_nr LOGICAL, INTENT(IN) :: do_ri_sos_laplace_mp2, my_do_gw, & do_im_time, do_bse TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s @@ -235,28 +233,29 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'rpa_ri_compute_en' - INTEGER :: best_integ_group_size, best_num_integ_point, color_rpa_group, dimen_nm_gw, & - dimen_virt_square, handle, handle2, handle3, ierr, iiB, input_num_integ_groups, & - integ_group_size, ispin, jjB, min_integ_group_size, my_group_L_end, my_group_L_size, & - my_group_L_start, my_nm_gw_end, my_nm_gw_size, my_nm_gw_start, ncol_block_mat, ngroup, & - nrow_block_mat, nspins, num_integ_group, num_integ_points, pos_integ_group + INTEGER :: best_integ_group_size, best_num_integ_point, color_rpa_group, dimen_homo_square, & + dimen_nm_gw, dimen_virt_square, handle, handle2, handle3, ierr, iiB, & + input_num_integ_groups, integ_group_size, ispin, jjB, min_integ_group_size, & + my_ab_comb_bse_end, my_ab_comb_bse_size, my_ab_comb_bse_start, my_group_L_end, & + my_group_L_size, my_group_L_start, my_ij_comb_bse_end, my_ij_comb_bse_size, & + my_ij_comb_bse_start, my_nm_gw_end, my_nm_gw_size, my_nm_gw_start, ncol_block_mat, & + ngroup, nrow_block_mat, nspins, num_integ_group, num_integ_points, pos_integ_group INTEGER(KIND=int_8) :: mem - INTEGER, ALLOCATABLE, DIMENSION(:) :: dimen_homo_square, dimen_ia, my_ab_comb_bse_end, & - my_ab_comb_bse_size, my_ab_comb_bse_start, my_ia_end, my_ia_size, my_ia_start, & - my_ij_comb_bse_end, my_ij_comb_bse_size, my_ij_comb_bse_start, virtual + INTEGER, ALLOCATABLE, DIMENSION(:) :: dimen_ia, my_ia_end, my_ia_size, & + my_ia_start, virtual LOGICAL :: do_kpoints_from_Gamma, do_minimax_quad, & my_open_shell, skip_integ_group_opt REAL(KIND=dp) :: allowed_memory, avail_mem, E_Range, Emax, Emin, mem_for_iaK, mem_for_QK, & mem_min, mem_per_group, mem_per_rank, mem_per_repl, mem_real REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Eigenval_kp TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_Q, fm_mat_Q_gemm, fm_mat_S, & - fm_mat_S_ab_bse, fm_mat_S_gw, & + fm_mat_S_gw + TYPE(cp_fm_type), DIMENSION(1) :: fm_mat_R_gw, fm_mat_S_ab_bse, & fm_mat_S_ij_bse - TYPE(cp_fm_type), DIMENSION(1) :: fm_mat_R_gw TYPE(mp_para_env_type), POINTER :: para_env_RPA TYPE(two_dim_real_array), ALLOCATABLE, & - DIMENSION(:) :: BIb_C_2D, BIb_C_2D_bse_ab, & - BIb_C_2D_bse_ij, BIb_C_2D_gw + DIMENSION(:) :: BIb_C_2D, BIb_C_2D_gw + TYPE(two_dim_real_array), DIMENSION(1) :: BIb_C_2D_bse_ab, BIb_C_2D_bse_ij CALL timeset(routineN, handle) @@ -331,20 +330,18 @@ CONTAINS input_num_integ_groups = mp2_env%ri_rpa%rpa_num_integ_groups IF (my_do_gw .AND. do_minimax_quad) THEN IF (num_integ_points > 34) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 30.") - END IF num_integ_points = 30 END IF ELSE IF (do_minimax_quad .AND. num_integ_points > 20) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 20.") - END IF num_integ_points = 20 END IF END IF @@ -526,37 +523,28 @@ CONTAINS CALL timeset(routineN//"_reorder_bse1", handle3) - ALLOCATE (BIb_C_2D_bse_ij(nspins), BIb_C_2D_bse_ab(nspins)) - ALLOCATE (dimen_homo_square(nspins)) - ALLOCATE (my_ij_comb_bse_size(nspins), my_ij_comb_bse_start(nspins), my_ij_comb_bse_end(nspins)) - ALLOCATE (my_ab_comb_bse_size(nspins), my_ab_comb_bse_start(nspins), my_ab_comb_bse_end(nspins)) - + dimen_homo_square = homo(1)**2 ! We do not implement an explicit bse_lev_occ different to homo here, because the small number of occupied levels ! does not critically influence the memory - DO ispin = 1, nspins - dimen_homo_square(ispin) = homo(ispin)**2 - CALL calculate_BIb_C_2D(BIb_C_2D_bse_ij(ispin)%array, BIb_C_bse_ij(ispin)%array, para_env_sub, & - dimen_homo_square(ispin), homo(ispin), homo(ispin), gd_B_occ_bse(ispin), & - my_ij_comb_bse_size(ispin), my_ij_comb_bse_start(ispin), & - my_ij_comb_bse_end(ispin), my_group_L_size) - DEALLOCATE (BIb_C_bse_ij(ispin)%array) - CALL release_group_dist(gd_B_occ_bse(ispin)) - END DO + CALL calculate_BIb_C_2D(BIb_C_2D_bse_ij(1)%array, BIb_C_bse_ij, para_env_sub, dimen_homo_square, & + homo(1), homo(1), gd_B_occ_bse, & + my_ij_comb_bse_size, my_ij_comb_bse_start, my_ij_comb_bse_end, my_group_L_size) + + DEALLOCATE (BIb_C_bse_ij) + CALL release_group_dist(gd_B_occ_bse) CALL timestop(handle3) CALL timeset(routineN//"_reorder_bse2", handle3) - ! bse_lev_virt(ispin) (hence dimen_virt_square) and gd_B_virt_bse(ispin) are per-spin - DO ispin = 1, nspins - dimen_virt_square = bse_lev_virt(ispin)**2 - CALL calculate_BIb_C_2D(BIb_C_2D_bse_ab(ispin)%array, BIb_C_bse_ab(ispin)%array, para_env_sub, & - dimen_virt_square, bse_lev_virt(ispin), bse_lev_virt(ispin), gd_B_virt_bse(ispin), & - my_ab_comb_bse_size(ispin), my_ab_comb_bse_start(ispin), & - my_ab_comb_bse_end(ispin), my_group_L_size) - DEALLOCATE (BIb_C_bse_ab(ispin)%array) - CALL release_group_dist(gd_B_virt_bse(ispin)) - END DO + dimen_virt_square = bse_lev_virt**2 + + CALL calculate_BIb_C_2D(BIb_C_2D_bse_ab(1)%array, BIb_C_bse_ab, para_env_sub, dimen_virt_square, & + bse_lev_virt, bse_lev_virt, gd_B_virt_bse, & + my_ab_comb_bse_size, my_ab_comb_bse_start, my_ab_comb_bse_end, my_group_L_size) + + DEALLOCATE (BIb_C_bse_ab) + CALL release_group_dist(gd_B_virt_bse) CALL timestop(handle3) @@ -607,21 +595,20 @@ CONTAINS END IF - ! for Bethe-Salpeter, we need other matrix fm_mat_S (per spin; the ab slab dimension is spin-independent) + ! for Bethe-Salpeter, we need other matrix fm_mat_S IF (do_bse) THEN - ALLOCATE (fm_mat_S_ij_bse(nspins), fm_mat_S_ab_bse(nspins)) CALL create_integ_mat(BIb_C_2D_bse_ij, para_env, para_env_sub, color_sub, ngroup, integ_group_size, & - dimen_RI_red, dimen_homo_square, color_rpa_group, & + dimen_RI_red, [dimen_homo_square], color_rpa_group, & mp2_env%block_size_row, mp2_env%block_size_col, unit_nr, & - my_ij_comb_bse_size, my_ij_comb_bse_start, my_ij_comb_bse_end, & + [my_ij_comb_bse_size], [my_ij_comb_bse_start], [my_ij_comb_bse_end], & my_group_L_size, my_group_L_start, my_group_L_end, & para_env_RPA, fm_mat_S_ij_bse, nrow_block_mat, ncol_block_mat, & fm_mat_Q(1)%matrix_struct%context, fm_mat_Q(1)%matrix_struct%context) CALL create_integ_mat(BIb_C_2D_bse_ab, para_env, para_env_sub, color_sub, ngroup, integ_group_size, & - dimen_RI_red, [(bse_lev_virt(ispin)**2, ispin=1, nspins)], color_rpa_group, & + dimen_RI_red, [dimen_virt_square], color_rpa_group, & mp2_env%block_size_row, mp2_env%block_size_col, unit_nr, & - my_ab_comb_bse_size, my_ab_comb_bse_start, my_ab_comb_bse_end, & + [my_ab_comb_bse_size], [my_ab_comb_bse_start], [my_ab_comb_bse_end], & my_group_L_size, my_group_L_start, my_group_L_end, & para_env_RPA, fm_mat_S_ab_bse, nrow_block_mat, ncol_block_mat, & fm_mat_Q(1)%matrix_struct%context, fm_mat_Q(1)%matrix_struct%context) @@ -639,7 +626,7 @@ CONTAINS homo, virtual, dimen_RI, dimen_RI_red, dimen_ia, dimen_nm_gw, & Eigenval_kp, num_integ_points, num_integ_group, color_rpa_group, & fm_matrix_PQ, fm_mat_S, fm_mat_Q_gemm, fm_mat_Q, fm_mat_S_gw, fm_mat_R_gw(1), & - fm_mat_S_ij_bse, fm_mat_S_ab_bse, & + fm_mat_S_ij_bse(1), fm_mat_S_ab_bse(1), & my_do_gw, do_bse, gw_corr_lev_occ, gw_corr_lev_virt, & bse_lev_virt, & do_minimax_quad, & @@ -668,11 +655,8 @@ CONTAINS END IF IF (do_bse) THEN - DO ispin = 1, nspins - CALL cp_fm_release(fm_mat_S_ij_bse(ispin)) - CALL cp_fm_release(fm_mat_S_ab_bse(ispin)) - END DO - DEALLOCATE (fm_mat_S_ij_bse, fm_mat_S_ab_bse) + CALL cp_fm_release(fm_mat_S_ij_bse(1)) + CALL cp_fm_release(fm_mat_S_ab_bse(1)) END IF CALL timestop(handle) @@ -989,9 +973,8 @@ CONTAINS CALL cp_fm_struct_release(fm_struct) - IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) THEN + IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) & CALL cp_blacs_env_release(blacs_env_Q) - END IF END IF ! release blacs_env @@ -1094,11 +1077,11 @@ CONTAINS TYPE(cp_fm_type), INTENT(IN) :: fm_matrix_PQ TYPE(cp_fm_type), DIMENSION(:), INTENT(INOUT) :: fm_mat_S TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_Q_gemm, fm_mat_Q, fm_mat_S_gw - TYPE(cp_fm_type), INTENT(IN) :: fm_mat_R_gw - TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_ij_bse, fm_mat_S_ab_bse + TYPE(cp_fm_type), INTENT(IN) :: fm_mat_R_gw, fm_mat_S_ij_bse, & + fm_mat_S_ab_bse LOGICAL, INTENT(IN) :: my_do_gw, do_bse - INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, & - bse_lev_virt + INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt + INTEGER, INTENT(IN) :: bse_lev_virt LOGICAL, INTENT(IN) :: do_minimax_quad, do_im_time TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: mo_coeff TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_matrix_L_kpoints, & @@ -1153,12 +1136,11 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Eigenval_last, Eigenval_scf, & vec_Sigma_x_gw TYPE(cp_cfm_type) :: cfm_mat_Q - TYPE(cp_fm_type) :: fm_mat_Q_static_bse_gemm, fm_mat_RI_global_work, fm_mat_work, & - fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, & + TYPE(cp_fm_type) :: fm_mat_Q_static_bse_gemm, fm_mat_RI_global_work, fm_mat_S_ia_bse, & + fm_mat_work, fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, & fm_scaled_dm_virt_tau - TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_S_gw_work, fm_mat_S_ia_bse, & - fm_mat_W, fm_mo_coeff_occ, & - fm_mo_coeff_virt + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_mat_S_gw_work, fm_mat_W, & + fm_mo_coeff_occ, fm_mo_coeff_virt TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_mat_L_kpoints, fm_mat_Minv_L_kpoints TYPE(dbcsr_p_type) :: mat_dm, mat_L, mat_M_P_munu_occ, & mat_M_P_munu_virt, mat_MinvVMinv @@ -1351,10 +1333,9 @@ CONTAINS IF (calc_forces .AND. .NOT. do_im_time) CALL rpa_grad_create(rpa_grad, fm_mat_Q(1), & fm_mat_S, homo, virtual, mp2_env, Eigenval(:, 1, :), & unit_nr, do_ri_sos_laplace_mp2) - IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) THEN + IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) & CALL exchange_work%create(qs_env, para_env_sub, mat_munu, dimen_RI_red, & fm_mat_S, fm_mat_Q(1), fm_mat_Q_gemm(1), homo, virtual) - END IF Erpa = 0.0_dp IF (mp2_env%ri_rpa%exchange_correction /= rpa_exchange_none) e_exchange = 0.0_dp first_cycle = .TRUE. @@ -1520,17 +1501,6 @@ CONTAINS fm_mat_Q_gemm(ispin), do_bse, fm_mat_Q_static_bse_gemm, dgemm_counter, & num_integ_points, count_ev_sc_GW) END DO - ! For open-shell BSE: the static screened-Coulomb polarizability is the - ! sum over both spin channels. calc_mat_Q overwrites fm_mat_Q_static_bse_gemm - ! per spin, so rebuild it here as the explicit spin sum at omega=0. - IF (do_bse .AND. nspins > 1 .AND. jquad == num_integ_points .AND. & - count_ev_sc_GW == 1) THEN - CALL cp_fm_set_all(fm_mat_Q_static_bse_gemm, 0.0_dp) - DO ispin = 1, nspins - CALL cp_fm_scale_and_add(1.0_dp, fm_mat_Q_static_bse_gemm, & - 1.0_dp, fm_mat_Q_gemm(ispin)) - END DO - END IF ! For SOS-MP2 we need both matrices separately IF (.NOT. do_ri_sos_laplace_mp2) THEN @@ -1781,31 +1751,25 @@ CONTAINS "BSE@evGW applies W0, i.e. screening with DFT energies to the BSE!") END IF END IF - ! Create a per-spin copy of fm_mat_S for usage in BSE - ALLOCATE (fm_mat_S_ia_bse(nspins)) - DO ispin = 1, nspins - CALL cp_fm_create(fm_mat_S_ia_bse(ispin), fm_mat_S(ispin)%matrix_struct) - CALL cp_fm_to_fm(fm_mat_S(ispin), fm_mat_S_ia_bse(ispin)) - ! Remove energy/frequency factor from 3c-Integral for BSE - IF (iter_sc_gw0 == 1) THEN - CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse(ispin), virtual(ispin), & - Eigenval_last(:, 1, ispin), homo(ispin), omega) - ELSE - CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse(ispin), virtual(ispin), & - Eigenval_scf(:, 1, ispin), homo(ispin), omega) - END IF - END DO + ! Create a copy of fm_mat_S for usage in BSE + CALL cp_fm_create(fm_mat_S_ia_bse, fm_mat_S(1)%matrix_struct) + CALL cp_fm_to_fm(fm_mat_S(1), fm_mat_S_ia_bse) + ! Remove energy/frequency factor from 3c-Integral for BSE + IF (iter_sc_gw0 == 1) THEN + CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse, virtual(1), & + Eigenval_last(:, 1, 1), homo(1), omega) + ELSE + CALL remove_scaling_factor_rpa(fm_mat_S_ia_bse, virtual(1), & + Eigenval_scf(:, 1, 1), homo(1), omega) + END IF ! Main routine for all BSE postprocessing CALL start_bse_calculation(fm_mat_S_ia_bse, fm_mat_S_ij_bse, fm_mat_S_ab_bse, & fm_mat_Q_static_bse_gemm, & Eigenval, Eigenval_scf, & homo, virtual, dimen_RI, dimen_RI_red, bse_lev_virt, & gd_array, color_sub, mp2_env, qs_env, mo_coeff, unit_nr) - ! Release per-spin BSE-copy of fm_mat_S - DO ispin = 1, nspins - CALL cp_fm_release(fm_mat_S_ia_bse(ispin)) - END DO - DEALLOCATE (fm_mat_S_ia_bse) + ! Release BSE-copy of fm_mat_S + CALL cp_fm_release(fm_mat_S_ia_bse) END IF IF (my_do_gw) THEN diff --git a/src/rt_propagation_forces.F b/src/rt_propagation_forces.F index 5d8ffc1854..bb9d1ac65c 100644 --- a/src/rt_propagation_forces.F +++ b/src/rt_propagation_forces.F @@ -122,18 +122,16 @@ CONTAINS IF (rtp%linear_scaling) THEN CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_new(re)%matrix, zero, tmp, & filter_eps=rtp%filter_eps) - IF (rtp%propagate_complex_ks) THEN + IF (rtp%propagate_complex_ks) & CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) - END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) CALL compute_forces(force, tmp, S_der, rho_new(im)%matrix, C_mat, kind_of, atom_of_kind) ELSE CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_ao(ispin)%matrix, zero, tmp) - IF (rtp%propagate_complex_ks) THEN + IF (rtp%propagate_complex_ks) & CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) - END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) CALL compute_forces(force, tmp, S_der, rho_ao_im(ispin)%matrix, C_mat, kind_of, atom_of_kind) END IF diff --git a/src/rt_propagation_types.F b/src/rt_propagation_types.F index 416906664d..ec1e3f4823 100644 --- a/src/rt_propagation_types.F +++ b/src/rt_propagation_types.F @@ -476,15 +476,12 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(rtp%H_last_iter) CALL dbcsr_deallocate_matrix_set(rtp%propagator_matrix) IF (ASSOCIATED(rtp%rho)) THEN - IF (ASSOCIATED(rtp%rho%old)) THEN + IF (ASSOCIATED(rtp%rho%old)) & CALL dbcsr_deallocate_matrix_set(rtp%rho%old) - END IF - IF (ASSOCIATED(rtp%rho%next)) THEN + IF (ASSOCIATED(rtp%rho%next)) & CALL dbcsr_deallocate_matrix_set(rtp%rho%next) - END IF - IF (ASSOCIATED(rtp%rho%new)) THEN + IF (ASSOCIATED(rtp%rho%new)) & CALL dbcsr_deallocate_matrix_set(rtp%rho%new) - END IF DEALLOCATE (rtp%rho) END IF @@ -493,27 +490,20 @@ CONTAINS CALL dbcsr_deallocate_matrix(rtp%S_inv) CALL dbcsr_deallocate_matrix(rtp%S_half) CALL dbcsr_deallocate_matrix(rtp%S_minus_half) - IF (ASSOCIATED(rtp%B_mat)) THEN + IF (ASSOCIATED(rtp%B_mat)) & CALL dbcsr_deallocate_matrix(rtp%B_mat) - END IF - IF (ASSOCIATED(rtp%C_mat)) THEN + IF (ASSOCIATED(rtp%C_mat)) & CALL dbcsr_deallocate_matrix_set(rtp%C_mat) - END IF - IF (ASSOCIATED(rtp%S_der)) THEN + IF (ASSOCIATED(rtp%S_der)) & CALL dbcsr_deallocate_matrix_set(rtp%S_der) - END IF - IF (ASSOCIATED(rtp%SinvH)) THEN + IF (ASSOCIATED(rtp%SinvH)) & CALL dbcsr_deallocate_matrix_set(rtp%SinvH) - END IF - IF (ASSOCIATED(rtp%SinvH_imag)) THEN + IF (ASSOCIATED(rtp%SinvH_imag)) & CALL dbcsr_deallocate_matrix_set(rtp%SinvH_imag) - END IF - IF (ASSOCIATED(rtp%SinvB)) THEN + IF (ASSOCIATED(rtp%SinvB)) & CALL dbcsr_deallocate_matrix_set(rtp%SinvB) - END IF - IF (ASSOCIATED(rtp%history)) THEN + IF (ASSOCIATED(rtp%history)) & CALL rtp_history_release(rtp) - END IF DEALLOCATE (rtp%orders) END SUBROUTINE rt_prop_release @@ -525,18 +515,14 @@ CONTAINS TYPE(rt_prop_type), INTENT(inout) :: rtp IF (ASSOCIATED(rtp%mos)) THEN - IF (ASSOCIATED(rtp%mos%old)) THEN + IF (ASSOCIATED(rtp%mos%old)) & CALL cp_fm_release(rtp%mos%old) - END IF - IF (ASSOCIATED(rtp%mos%new)) THEN + IF (ASSOCIATED(rtp%mos%new)) & CALL cp_fm_release(rtp%mos%new) - END IF - IF (ASSOCIATED(rtp%mos%next)) THEN + IF (ASSOCIATED(rtp%mos%next)) & CALL cp_fm_release(rtp%mos%next) - END IF - IF (ASSOCIATED(rtp%mos%admm)) THEN + IF (ASSOCIATED(rtp%mos%admm)) & CALL cp_fm_release(rtp%mos%admm) - END IF CALL cp_fm_struct_release(rtp%ao_ao_fmstruct) DEALLOCATE (rtp%mos) END IF @@ -607,9 +593,8 @@ CONTAINS IF (ASSOCIATED(rtp%history%s_history)) THEN DO i = 1, SIZE(rtp%history%s_history) - IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) THEN + IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) & CALL dbcsr_deallocate_matrix(rtp%history%s_history(i)%matrix) - END IF END DO DEALLOCATE (rtp%history%s_history) END IF diff --git a/src/rt_propagation_velocity_gauge.F b/src/rt_propagation_velocity_gauge.F index 9ad2819d5c..ee205d1999 100644 --- a/src/rt_propagation_velocity_gauge.F +++ b/src/rt_propagation_velocity_gauge.F @@ -1090,58 +1090,48 @@ CONTAINS na = SIZE(acint_cos, 1) np = SIZE(acint_cos, 2) nb = SIZE(bcint_cos, 1) - ! Re(dV_ab/dRA) = + - ! + + - ! Im(dV_ab/dRA) = - - ! - + + ! Re(dV_ab/dRA) = + + + + ! Im(dV_ab/dRA) = - - + katom = alist_cos_ac%clist(kac)%catom DO idir = 1, 3 IF (iatom <= jatom) THEN ! For fa: - IF (found_real) THEN + IF (found_real) & fa(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & + MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (+MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & - MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) - END IF ! For fb: - IF (found_real) THEN + IF (found_real) & fb(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (-MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))))) - END IF ELSE ! For fa: - IF (found_real) THEN + IF (found_real) & fa(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & + MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (+MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & - MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) - END IF ! For fb - IF (found_real) THEN + IF (found_real) & fb(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (-MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))))) - END IF END IF force_thread(idir, iatom) = force_thread(idir, iatom) + f0*fa(idir) force_thread(idir, katom) = force_thread(idir, katom) - f0*fa(idir) diff --git a/src/scf_control_types.F b/src/scf_control_types.F index 623af5359f..527bb5e81f 100644 --- a/src/scf_control_types.F +++ b/src/scf_control_types.F @@ -302,9 +302,8 @@ CONTAINS END IF DEALLOCATE (scf_control%smear) - IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) THEN + IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) & CALL cdft_opt_type_release(scf_control%outer_scf%cdft_opt_control) - END IF IF (ASSOCIATED(scf_control%gce)) THEN DEALLOCATE (scf_control%gce) @@ -354,7 +353,7 @@ CONTAINS IF (scf_control%use_diag .AND. scf_control%use_ot) THEN ! don't allow both options to be true CPABORT("Don't activate OT and Diagonaliztion together") - ELSE IF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN + ELSEIF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN ! set default to diagonalization scf_control%use_diag = .TRUE. END IF @@ -700,10 +699,9 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T25,A,T71,ES10.2)") & "Smearing width (sigma) [a.u.]:", scf_control%smear%smearing_width, & "Accuracy threshold:", scf_control%smear%eps_fermi_dirac - IF (scf_control%smear%fixed_mag_mom > 0.0_dp) THEN + IF (scf_control%smear%fixed_mag_mom > 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T25,A,T61,F20.1)") & - "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom - END IF + "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom CASE (smear_energy_window) WRITE (UNIT=output_unit, FMT="(T25,A,T71,F10.6)") & "Smear window [a.u.]: ", scf_control%smear%window_size diff --git a/src/scine_utils.F b/src/scine_utils.F index 8bd0ee64ca..208d4b2f0b 100644 --- a/src/scine_utils.F +++ b/src/scine_utils.F @@ -117,15 +117,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSE IF (nc == j + 4) THEN + ELSEIF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 3) THEN + ELSEIF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 2) THEN + ELSEIF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 1) THEN + ELSEIF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j) THEN + ELSEIF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -134,15 +134,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSE IF (nc == j + 4) THEN + ELSEIF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 3) THEN + ELSEIF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 2) THEN + ELSEIF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 1) THEN + ELSEIF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j) THEN + ELSEIF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -151,15 +151,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSE IF (nc == j + 4) THEN + ELSEIF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 3) THEN + ELSEIF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 2) THEN + ELSEIF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 1) THEN + ELSEIF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j) THEN + ELSEIF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO diff --git a/src/se_core_matrix.F b/src/se_core_matrix.F index 10bda9bd4e..2c53f7ca31 100644 --- a/src/se_core_matrix.F +++ b/src/se_core_matrix.F @@ -281,6 +281,24 @@ CONTAINS ! two-centre one-electron term NULLIFY (s_block) +! CALL dbcsr_get_block_p(matrix_s(1)%matrix,& +! irow,icol,s_block,found) +! CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) +! +! if( irow == iatom )then +! R= -rij +! call makeS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,S) +! else +! R= rij +! call makeS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,S) +! endif +! +! do i=1,4 +! do j=1,4 +! s_block(i,j)=S(ix(i),ix(j)) +! enddo +! enddo + CALL dbcsr_get_block_p(matrix_s(1)%matrix, & irow, icol, s_block, found) CPASSERT(ASSOCIATED(s_block)) @@ -301,11 +319,28 @@ CONTAINS atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) +! if( irow == iatom )then +! R= -rij +! call makedS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,dS) +! else +! R= rij +! call makedS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,dS) +! endif + CALL dbcsr_get_block_p(matrix_p(1)%matrix, irow, icol, pabmat, found) CPASSERT(ASSOCIATED(pabmat)) DO icor = 1, 3 force_ab(icor) = 0._dp +! CALL dbcsr_get_block_p(matrix_s(icor+1)%matrix,irow,icol,dsmat,found) +! CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,failure) +! +! do i=1,4 +! do j=1,4 +! dsmat(i,j)=dS(ix(i),ix(j),icor) +! enddo +! enddo + CALL dbcsr_get_block_p(matrix_s(icor + 1)%matrix, irow, icol, dsmat, found) CPASSERT(ASSOCIATED(dsmat)) dsmat = 2._dp*kh*dsmat*pabmat @@ -593,7 +628,7 @@ CONTAINS S(:, :) = 0.0_dp v(:) = R(:) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) IF (rr < 1.0e-20_dp) THEN @@ -971,7 +1006,7 @@ CONTAINS dS(:, :, :) = 0.0_dp v(:) = R(:) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) IF (rr < 1.0e-20_dp) THEN diff --git a/src/semi_empirical_int_ana.F b/src/semi_empirical_int_ana.F index 3698bf1625..d9e33d563a 100644 --- a/src/semi_empirical_int_ana.F +++ b/src/semi_empirical_int_ana.F @@ -548,7 +548,7 @@ CONTAINS (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2)*(-2.0_dp*apdg*(rij - dbi - daj)) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2)*(-2.0_dp*apdg*(rij - dbi - dbj)) END IF - ELSE IF (itype == do_method_pchg) THEN + ELSEIF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp dscale = 0.0_dp @@ -571,15 +571,15 @@ CONTAINS IF (l_denuc) dscale = dscale*(2._dp*xab*EXP(-aab*rija*rija)) - & scale*2._dp*xab*EXP(-aab*rija*rija)*(2.0_dp*aab*rija)*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) & - scale*2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6))*aab*(1.0_dp + 6.0_dp*0.0003_dp*rija**5)*drija & - scale*9.28_dp*EXP(-5.98_dp*rija)*5.98_dp*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) & @@ -1578,7 +1578,8 @@ CONTAINS ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN se_int_screen%ft = taper_eval(se_taper%taper_add, rij) - IF (lgrad) se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) + IF (lgrad) & + se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF ! Integral Values for sp shells only diff --git a/src/semi_empirical_int_debug.F b/src/semi_empirical_int_debug.F index 466d99a3c7..2a77ae1016 100644 --- a/src/semi_empirical_int_debug.F +++ b/src/semi_empirical_int_debug.F @@ -71,7 +71,7 @@ SUBROUTINE check_rotmat_der(sepi, sepj, rjiv, ij_matrix, do_invert) IF (i == 1) matrix => matrix_p IF (i == 2) matrix => matrix_m r0 = rjiv + (-1.0_dp)**(i - 1)*x - r = NORM2(r0) + r = SQRT(DOT_PRODUCT(r0, r0)) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=do_invert) END DO ! SP @@ -218,7 +218,7 @@ SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, in x(imap(j)) = dx DO i = 1, 2 r0 = rijv + (-1.0_dp)**(i - 1)*x - r = NORM2(r0) + r = SQRT(DOT_PRODUCT(r0, r0)) CALL rotmat_create(matrix) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=invert) diff --git a/src/semi_empirical_int_gks.F b/src/semi_empirical_int_gks.F index b6da8aa20d..f285735404 100644 --- a/src/semi_empirical_int_gks.F +++ b/src/semi_empirical_int_gks.F @@ -270,7 +270,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -373,7 +373,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -590,7 +590,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) r1 = 1.0_dp/rr r2 = r1*r1 @@ -807,7 +807,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) diff --git a/src/semi_empirical_int_num.F b/src/semi_empirical_int_num.F index a5cbd768c6..a541863a75 100644 --- a/src/semi_empirical_int_num.F +++ b/src/semi_empirical_int_num.F @@ -619,7 +619,7 @@ CONTAINS (zaf*pai + zbf*pbj)*EXP(-apdg*(rij - dai - dbj)**2) + & (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2) - ELSE IF (itype == do_method_pchg) THEN + ELSEIF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp ELSE @@ -635,11 +635,11 @@ CONTAINS (sepj%z == 1 .AND. (sepi%z == 6 .OR. sepi%z == 7 .OR. sepi%z == 8))) THEN ! Special Case O-H or N-H or C-H scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) ELSE diff --git a/src/semi_empirical_par_utils.F b/src/semi_empirical_par_utils.F index ec1302790b..4ca22c5713 100644 --- a/src/semi_empirical_par_utils.F +++ b/src/semi_empirical_par_utils.F @@ -261,16 +261,16 @@ CONTAINS ELSE IF (l == 0) THEN n = nqs(sep%z) - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN ! Special case for Hydrogen.. If requested allow p-orbitals on it.. IF ((sep%z == 1) .AND. sep%p_orbitals_on_h) THEN n = 1 ELSE n = nqp(sep%z) END IF - ELSE IF (l == 2) THEN + ELSEIF (l == 2) THEN n = nqd(sep%z) - ELSE IF (l == 3) THEN + ELSEIF (l == 3) THEN n = nqf(sep%z) ELSE CPABORT("Invalid l quantum number !") @@ -535,27 +535,24 @@ CONTAINS z1 = sep%sto_exponents(0) z2 = sep%sto_exponents(1) z3 = sep%sto_exponents(2) - IF (z1 <= 0.0_dp) THEN + IF (z1 <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Trying to use s-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of s orbitals! ") - END IF amn = 0.0_dp nsp = nqs(sep%z) IF (sep%natorb >= 4) THEN - IF (z2 <= 0.0_dp) THEN + IF (z2 <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Trying to use p-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of p orbitals! ") - END IF amn(2) = amn_l_low(z1, z2, nsp, nsp, 1) amn(3) = amn_l_low(z2, z2, nsp, nsp, 2) IF (sep%dorb) THEN - IF (z3 <= 0.0_dp) THEN + IF (z3 <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Trying to use d-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of d orbitals! ") - END IF nd = nqd(sep%z) amn(4) = amn_l_low(z1, z3, nsp, nd, 2) amn(5) = amn_l_low(z2, z3, nsp, nd, 1) diff --git a/src/semi_empirical_store_int_types.F b/src/semi_empirical_store_int_types.F index f878234b19..f00537c0de 100644 --- a/src/semi_empirical_store_int_types.F +++ b/src/semi_empirical_store_int_types.F @@ -97,9 +97,8 @@ CONTAINS END IF ! Disk Storage disabled for semi-empirical methods - IF (store_int_env%memory_parameter%do_disk_storage) THEN + IF (store_int_env%memory_parameter%do_disk_storage) & CPABORT("Disk storage for SEMIEMPIRICAL methods disabled! ") - END IF ! Allocate containers/caches for integral storage if requested IF (.NOT. store_int_env%memory_parameter%do_all_on_the_fly .AND. store_int_env%compress) THEN diff --git a/src/semi_empirical_types.F b/src/semi_empirical_types.F index 9157e5f5db..806e85c01c 100644 --- a/src/semi_empirical_types.F +++ b/src/semi_empirical_types.F @@ -833,7 +833,7 @@ CONTAINS ADJUSTR("ACOUL"), "- "//" Slater parameter: ", sep%acoul WRITE (UNIT=output_unit, FMT="(T16,A11,T30,A,T69,I12)") & ADJUSTR("NR"), "- "//" Slater parameter: ", sep%nr - ELSE IF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN + ELSEIF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN ! Standard case DO i = 1, SIZE(sep%bfn1, 1) i_string = cp_to_string(i) diff --git a/src/semi_empirical_utils.F b/src/semi_empirical_utils.F index 4cc9b5e0a9..5c9911931f 100644 --- a/src/semi_empirical_utils.F +++ b/src/semi_empirical_utils.F @@ -305,11 +305,10 @@ CONTAINS END IF ! Check if the element has been defined.. - IF (.NOT. sep%defined) THEN + IF (.NOT. sep%defined) & CALL cp_abort(__LOCATION__, & "Semiempirical type ("//TRIM(sep%name)//") cannot be defined for "// & "the requested parameterization.") - END IF ! Fill 1 center - 2 electron integrals CALL setup_1c_2el_int(sep) diff --git a/src/shg_int/construct_shg.F b/src/shg_int/construct_shg.F index 9de93b969d..b63da9c9c1 100644 --- a/src/shg_int/construct_shg.F +++ b/src/shg_int/construct_shg.F @@ -377,8 +377,7 @@ CONTAINS IF (ma - 1 >= 0) THEN Wamm(0:lamb, 1) = Waux_mat(1:lamb + 1, ipam - 1, ipb) IF (mb > 0) Wamm(0:lamb, 2) = Waux_mat(1:lamb + 1, ipam - 1, imb) - ! order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 - IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) + IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) !order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 IF (ma - 1 > 0 .AND. mb > 0) Wamm(0:lamb, 4) = Waux_mat(1:lamb + 1, imam + 1, imb) END IF !*** Wamp: la-1, ma+1 diff --git a/src/sirius_interface.F b/src/sirius_interface.F index 9b94f8290b..c278a27ee1 100644 --- a/src/sirius_interface.F +++ b/src/sirius_interface.F @@ -327,7 +327,7 @@ CONTAINS symbol=element_symbol, & mass=REAL(mass/massunit, KIND=C_DOUBLE)) - ELSE IF (ASSOCIATED(gth_potential)) THEN + ELSEIF (ASSOCIATED(gth_potential)) THEN ! NULLIFY (atom_grid) CALL allocate_grid_atom(atom_grid) diff --git a/src/skala_gpw_features.F b/src/skala_gpw_features.F index f791c73354..14a0b088a5 100644 --- a/src/skala_gpw_features.F +++ b/src/skala_gpw_features.F @@ -225,9 +225,8 @@ CONTAINS my_requires_grad = .FALSE. IF (PRESENT(requires_grad)) my_requires_grad = requires_grad my_requires_coordinate_grad = .FALSE. - IF (PRESENT(requires_coordinate_grad)) THEN + IF (PRESENT(requires_coordinate_grad)) & my_requires_coordinate_grad = requires_coordinate_grad - END IF my_requires_stress_grad = .FALSE. IF (PRESENT(requires_stress_grad)) my_requires_stress_grad = requires_stress_grad my_use_atom_chunks = .FALSE. @@ -596,9 +595,8 @@ CONTAINS END IF max_local_features = nflat_local - IF (my_atom_partition == skala_gpw_atom_partition_smooth) THEN + IF (my_atom_partition == skala_gpw_atom_partition_smooth) & max_local_features = nflat_local*natom - END IF ALLOCATE (local_owner(max_local_features), & local_source_points(max_local_features), & local_static(nstatic_per_point*max_local_features), & @@ -781,9 +779,8 @@ CONTAINS atom_position(owner) = atom_position(owner) + 1 source_global = global_source_points(ipt) cached_layout%feature_source_points(row) = source_global - IF (cached_layout%global_to_feature(source_global) == 0) THEN + IF (cached_layout%global_to_feature(source_global) == 0) & cached_layout%global_to_feature(source_global) = row - END IF static_base = nstatic_per_point*(ipt - 1) cached_layout%grid_coords(:, row) = global_static(static_base + 1:static_base + 3) cached_layout%grid_weights(row) = global_static(static_base + 4) @@ -1461,18 +1458,14 @@ CONTAINS IF (ALLOCATED(cache%chunk_feature_displs)) DEALLOCATE (cache%chunk_feature_displs) IF (ALLOCATED(cache%chunk_grad_counts)) DEALLOCATE (cache%chunk_grad_counts) IF (ALLOCATED(cache%chunk_grad_displs)) DEALLOCATE (cache%chunk_grad_displs) - IF (ALLOCATED(cache%route_grad_return_recv_counts)) THEN + IF (ALLOCATED(cache%route_grad_return_recv_counts)) & DEALLOCATE (cache%route_grad_return_recv_counts) - END IF - IF (ALLOCATED(cache%route_grad_return_recv_displs)) THEN + IF (ALLOCATED(cache%route_grad_return_recv_displs)) & DEALLOCATE (cache%route_grad_return_recv_displs) - END IF - IF (ALLOCATED(cache%route_grad_return_send_counts)) THEN + IF (ALLOCATED(cache%route_grad_return_send_counts)) & DEALLOCATE (cache%route_grad_return_send_counts) - END IF - IF (ALLOCATED(cache%route_grad_return_send_displs)) THEN + IF (ALLOCATED(cache%route_grad_return_send_displs)) & DEALLOCATE (cache%route_grad_return_send_displs) - END IF IF (ALLOCATED(cache%route_local_dest)) DEALLOCATE (cache%route_local_dest) IF (ALLOCATED(cache%chunk_return_positions)) DEALLOCATE (cache%chunk_return_positions) IF (ALLOCATED(cache%route_point_recv_counts)) DEALLOCATE (cache%route_point_recv_counts) @@ -1495,20 +1488,17 @@ CONTAINS IF (ALLOCATED(cache%local_feature_offsets)) DEALLOCATE (cache%local_feature_offsets) IF (ALLOCATED(cache%local_feature_points)) DEALLOCATE (cache%local_feature_points) IF (ALLOCATED(cache%local_feature_rows)) DEALLOCATE (cache%local_feature_rows) - IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) THEN + IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) & DEALLOCATE (cache%atomic_grid_size_bound_shape) - END IF - IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) THEN + IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) & DEALLOCATE (cache%chunk_atomic_grid_size_bound_shape) - END IF IF (ALLOCATED(cache%atomic_grid_weights)) DEALLOCATE (cache%atomic_grid_weights) IF (ALLOCATED(cache%chunk_atomic_grid_weights)) DEALLOCATE (cache%chunk_atomic_grid_weights) IF (ALLOCATED(cache%chunk_grid_weights)) DEALLOCATE (cache%chunk_grid_weights) IF (ALLOCATED(cache%grid_weights)) DEALLOCATE (cache%grid_weights) IF (ALLOCATED(cache%atom_coords)) DEALLOCATE (cache%atom_coords) - IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) THEN + IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) & DEALLOCATE (cache%chunk_coarse_0_atomic_coords) - END IF IF (ALLOCATED(cache%coarse_0_atomic_coords)) DEALLOCATE (cache%coarse_0_atomic_coords) IF (ALLOCATED(cache%chunk_grid_coords)) DEALLOCATE (cache%chunk_grid_coords) IF (ALLOCATED(cache%grid_coords)) DEALLOCATE (cache%grid_coords) @@ -1602,30 +1592,22 @@ CONTAINS IF (ALLOCATED(features%chunk_grad_counts)) DEALLOCATE (features%chunk_grad_counts) IF (ALLOCATED(features%chunk_grad_displs)) DEALLOCATE (features%chunk_grad_displs) IF (ALLOCATED(features%chunk_return_positions)) DEALLOCATE (features%chunk_return_positions) - IF (ALLOCATED(features%route_grad_return_recv_counts)) THEN + IF (ALLOCATED(features%route_grad_return_recv_counts)) & DEALLOCATE (features%route_grad_return_recv_counts) - END IF - IF (ALLOCATED(features%route_grad_return_recv_displs)) THEN + IF (ALLOCATED(features%route_grad_return_recv_displs)) & DEALLOCATE (features%route_grad_return_recv_displs) - END IF - IF (ALLOCATED(features%route_grad_return_send_counts)) THEN + IF (ALLOCATED(features%route_grad_return_send_counts)) & DEALLOCATE (features%route_grad_return_send_counts) - END IF - IF (ALLOCATED(features%route_grad_return_send_displs)) THEN + IF (ALLOCATED(features%route_grad_return_send_displs)) & DEALLOCATE (features%route_grad_return_send_displs) - END IF - IF (ALLOCATED(features%route_point_recv_counts)) THEN + IF (ALLOCATED(features%route_point_recv_counts)) & DEALLOCATE (features%route_point_recv_counts) - END IF - IF (ALLOCATED(features%route_point_recv_displs)) THEN + IF (ALLOCATED(features%route_point_recv_displs)) & DEALLOCATE (features%route_point_recv_displs) - END IF - IF (ALLOCATED(features%route_point_send_counts)) THEN + IF (ALLOCATED(features%route_point_send_counts)) & DEALLOCATE (features%route_point_send_counts) - END IF - IF (ALLOCATED(features%route_point_send_displs)) THEN + IF (ALLOCATED(features%route_point_send_displs)) & DEALLOCATE (features%route_point_send_displs) - END IF IF (ALLOCATED(features%route_send_local_rows)) DEALLOCATE (features%route_send_local_rows) IF (ALLOCATED(features%feature_index)) DEALLOCATE (features%feature_index) IF (ALLOCATED(features%local_feature_counts)) DEALLOCATE (features%local_feature_counts) @@ -1636,9 +1618,8 @@ CONTAINS IF (ALLOCATED(features%atomic_grid_weights)) DEALLOCATE (features%atomic_grid_weights) IF (ALLOCATED(features%atomic_grid_sizes)) DEALLOCATE (features%atomic_grid_sizes) IF (ALLOCATED(features%coarse_0_atomic_coords)) DEALLOCATE (features%coarse_0_atomic_coords) - IF (ALLOCATED(features%atomic_grid_size_bound_shape)) THEN + IF (ALLOCATED(features%atomic_grid_size_bound_shape)) & DEALLOCATE (features%atomic_grid_size_bound_shape) - END IF features%chunk_feature_count = 0 features%nflat = 0 features%nflat_local = 0 diff --git a/src/skala_gpw_functional.F b/src/skala_gpw_functional.F index ab0d553178..ea71c9ead5 100644 --- a/src/skala_gpw_functional.F +++ b/src/skala_gpw_functional.F @@ -109,7 +109,7 @@ CONTAINS END FUNCTION xc_section_uses_native_skala_grid ! ************************************************************************************************** -!> \brief Return true if the GAUXC subsection requests a model evaluation. +!> \brief Return true if the GAUXC subsection requests a Skala-style model. !> \param xc_section ... !> \return ... ! ************************************************************************************************** @@ -117,20 +117,16 @@ CONTAINS TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section LOGICAL :: uses_gauxc_model - CHARACTER(len=default_path_length) :: model_key, model_name, xc_key, xc_name + CHARACTER(len=default_path_length) :: model_key, model_name TYPE(section_vals_type), POINTER :: gauxc_section uses_gauxc_model = .FALSE. gauxc_section => get_gauxc_section(xc_section) IF (ASSOCIATED(gauxc_section)) THEN CALL section_vals_val_get(gauxc_section, "MODEL", c_val=model_name) - CALL section_vals_val_get(gauxc_section, "FUNCTIONAL", c_val=xc_name) model_key = ADJUSTL(model_name) - xc_key = ADJUSTL(xc_name) CALL uppercase(model_key) - CALL uppercase(xc_key) - uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & - TRIM(model_key) /= TRIM(xc_key)) + uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") END IF END FUNCTION xc_section_uses_gauxc_model @@ -1514,9 +1510,8 @@ CONTAINS CPASSERT(SUM(features%route_point_send_counts) == nroute_points) nroute_grad_per_point = ngrad_per_point - IF (features%uses_collapsed_rks_dynamic) THEN + IF (features%uses_collapsed_rks_dynamic) & nroute_grad_per_point = ncollapsed_grad_per_point - END IF ALLOCATE (send_grad_buffer(MAX(1, nroute_grad_per_point*features%chunk_feature_count)), & recv_grad_buffer(MAX(1, nroute_grad_per_point*nroute_points)), & route_grad_return_send_counts(SIZE(features%route_point_recv_counts)), & diff --git a/src/smeagol_control_types.F b/src/smeagol_control_types.F index 7e63f52054..37cbe5c18a 100644 --- a/src/smeagol_control_types.F +++ b/src/smeagol_control_types.F @@ -58,7 +58,7 @@ MODULE smeagol_control_types REAL(kind=dp) :: to_smeagol_energy_units = 2.0_dp !> number of cell images along i and j cell vectors - INTEGER, DIMENSION(2) :: n_cell_images = [1, 1] + INTEGER, DIMENSION(2) :: n_cell_images = (/1, 1/) !> what lead (bulk transport calculation) INTEGER :: lead_label = smeagol_bulklead_leftright diff --git a/src/smeagol_emtoptions.F b/src/smeagol_emtoptions.F index adb1cc9417..fc1ea616e3 100644 --- a/src/smeagol_emtoptions.F +++ b/src/smeagol_emtoptions.F @@ -179,8 +179,7 @@ MODULE smeagol_emtoptions smeagolglobal_emSTT = torqueflag smeagolglobal_emSTTLin = torquelin - ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, - ! therefore 'EM.TimeReversal' is also enabled. + ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, therefore 'EM.TimeReversal' is also enabled. ! In case of this CP2K+SMEAGOL interface, the default value of 'timereversal' variable is .FALSE. IF (smeagol_control%aux%timereversal) THEN CALL cp_warn(__LOCATION__, & @@ -329,8 +328,7 @@ MODULE smeagol_emtoptions ! current-induced forces ! The value of 'smeagol_control%emforces' is set in qs_energies(). - ! Calculation of forces is enabled automatically for certain run_types - ! (energy_force, geo_opt, md) and disabled otherwise. + ! Calculation of forces is enabled automatically for certain run_types (energy_force, geo_opt, md) and disabled otherwise. IF (smeagol_control%aux%curr_dist) THEN smeagol_control%emforces = .TRUE. END IF @@ -340,9 +338,8 @@ MODULE smeagol_emtoptions IF (.NOT. smeagol_control%aux%isexplicit_GetRhoSingleLead) smeagol_control%aux%GetRhoSingleLead = GetRhoSingleLeadDefault IF (smeagol_control%aux%MinChannelIndex < 1) smeagol_control%aux%MinChannelIndex = 1 - IF (smeagol_control%aux%MaxChannelIndex < 1) THEN + IF (smeagol_control%aux%MaxChannelIndex < 1) & smeagol_control%aux%MaxChannelIndex = smeagol_control%aux%MinChannelIndex + 4 - END IF IF (smeagolglobal_emSTT .AND. smeagolglobal_emSTTLin .AND. smeagol_control%aux%GetRhoSingleLead /= -3) THEN CALL cp_warn(__LOCATION__, & diff --git a/src/smeagol_interface.F b/src/smeagol_interface.F index eccf01abec..556e5b4e67 100644 --- a/src/smeagol_interface.F +++ b/src/smeagol_interface.F @@ -731,13 +731,11 @@ CONTAINS ! first invocation of the subroutine : initialise md_iter_level and md_first_step variables smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "MD") - IF (smeagol_control%aux%md_iter_level <= 0) THEN + IF (smeagol_control%aux%md_iter_level <= 0) & smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "GEO_OPT") - END IF - IF (smeagol_control%aux%md_iter_level <= 0) THEN + IF (smeagol_control%aux%md_iter_level <= 0) & smeagol_control%aux%md_iter_level = 0 - END IF ! index of the first GEO_OPT / MD step IF (smeagol_control%aux%md_iter_level > 0) THEN diff --git a/src/smeagol_matrix_utils.F b/src/smeagol_matrix_utils.F index 1bf43236fc..ad3ea6d6d8 100644 --- a/src/smeagol_matrix_utils.F +++ b/src/smeagol_matrix_utils.F @@ -72,8 +72,7 @@ MODULE smeagol_matrix_utils INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_send = 2 INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_dim2 = nelements_dbcsr_send - ! 128 MiB (to limit memory usage for matrix redistribution) - INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 + INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 ! 128 MiB (to limit memory usage for matrix redistribution) INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_dp = max_mpi_packet_size_bytes/INT(dp_size, kind=int_8) ! a portable way to determine the upper bound for tag value is to call @@ -221,8 +220,7 @@ CONTAINS ! via subroutine arguments, an extra MPI_Allreduce operation is needed each time we call ! replicate_neighbour_list() / get_nnodes_local(). max_ijk_cell_image(3) = -1 - ! bulk-transport calculation expects exactly 3 cell images along transport direction - IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 + IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 ! bulk-transport calculation expects exactly 3 cell images along transport direction ! replicate pair-wise neighbour list. Identical non-zero matrix blocks from cell image along transport direction ! are grouped together if do_merge == .TRUE. @@ -504,10 +502,8 @@ CONTAINS END IF END IF - ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements - ! (should be OK due to SMEAGOL limitation) - ! in principle, it is possible to overcome this limit by using derived datatypes - ! (which will require additional wrapper functions, indeed). + ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements (should be OK due to SMEAGOL limitation) + ! in principle, it is possible to overcome this limit by using derived datatypes (which will require additional wrapper functions, indeed). ! ! pre-post non-blocking receive operations IF (n_nonzero_elements_siesta > 0) THEN @@ -689,13 +685,10 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) DEALLOCATE (offset_per_proc, n_packed_elements_per_proc) - ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, - ! local row index, and column index (in this order). - ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, - ! source MPI rank, and column index. + ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, local row index, and column index (in this order). + ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, source MPI rank, and column index. ! (column indices are in the ascending order within each (row index, source MPI rank) block). - ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : - ! local row index, column index + ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : local row index, column index IF (n_nonzero_elements_siesta > 0) THEN ALLOCATE (reorder_recv_buffer(n_nonzero_elements_siesta)) ALLOCATE (next_nonzero_element_offset(siesta_struct%nrows)) @@ -1030,8 +1023,7 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) - ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root - iproc = siesta_struct%gather_root + iproc = siesta_struct%gather_root ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root IF (n_nonzero_elements_dbcsr > 0) THEN DO inode_proc = 1, nnodes_proc n_image_ind = siesta_struct%n_dbcsr_cell_images_to_merge(inode_proc) @@ -1874,9 +1866,8 @@ CONTAINS ! there is no need to send data to the same MPI process IF (iproc /= mepos) THEN nrequests = nrequests + INT(nelements_per_proc(iproc)/max_nelements_per_packet) - IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) THEN + IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) & nrequests = nrequests + 1 - END IF END IF END DO END FUNCTION get_number_of_mpi_sendrecv_requests diff --git a/src/sockets.c b/src/sockets.c index 067635251f..dc2e00afe6 100644 --- a/src/sockets.c +++ b/src/sockets.c @@ -61,10 +61,7 @@ * \param port The port number for the socket to be created. Low numbers are * often reserved for important channels, so use of numbers of 4 * or more digits is recommended. - * \param host The name of the host server (inet socket), or the full path - * of the UNIX socket file (unix socket). The caller is - * responsible for building this path, e.g. by prepending a - * prefix such as "/tmp/ipi_". + * \param host The name of the host server. * \note Fortran passes an extra argument for the string length, but this is * ignored here for C compatibility. ******************************************************************************/ @@ -108,7 +105,8 @@ void open_connect_socket(int *psockfd, int *inet, int *port, char *host) { // fills up details of the socket address memset(&serv_addr, 0, sizeof(serv_addr)); serv_addr.sun_family = AF_UNIX; - strcpy(serv_addr.sun_path, host); + strcpy(serv_addr.sun_path, "/tmp/qiskit_"); + strcpy(serv_addr.sun_path + 12, host); // creates the socket sockfd = socket(AF_UNIX, SOCK_STREAM, 0); diff --git a/src/start/cp2k.F b/src/start/cp2k.F index 15857c3c7d..8d26c43ea1 100644 --- a/src/start/cp2k.F +++ b/src/start/cp2k.F @@ -167,9 +167,8 @@ PROGRAM cp2k INTEGER :: veclib_max_threads, ierr CALL get_environment_variable("VECLIB_MAXIMUM_THREADS", env_var, status=ierr) veclib_max_threads = 0 - IF (ierr == 0) THEN + IF (ierr == 0) & READ (env_var, *) veclib_max_threads - END IF IF (ierr == 1 .OR. (ierr == 0 .AND. veclib_max_threads > 1)) THEN CALL cp_warn(__LOCATION__, & "macOS' Accelerate framework has its own threading enabled which may interfere"// & @@ -237,9 +236,8 @@ PROGRAM cp2k DO inp_var_idx = 1, SIZE(initial_variables, 2) ! check whether the variable was already set, in this case, overwrite - IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) THEN + IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) & EXIT - END IF END DO IF (inp_var_idx > SIZE(initial_variables, 2)) THEN diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index 9e066384a0..7287947c5d 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -78,7 +78,7 @@ MODULE cp2k_runs do_sirius, do_swarm, do_tamc, do_test, do_tree_mc, do_tree_mc_ana, driver_run, ehrenfest, & energy_force_run, energy_run, geo_opt_run, linear_response_run, mimic_run, mol_dyn_run, & mon_car_run, negf_run, none_run, pint_run, real_time_propagation, rtp_method_bse, & - rtp_method_bse_linearized, tree_mc_run, vib_anal + tree_mc_run, vib_anal USE input_cp2k, ONLY: create_cp2k_root_section USE input_cp2k_check, ONLY: check_cp2k_input USE input_cp2k_global, ONLY: create_global_section @@ -123,7 +123,6 @@ MODULE cp2k_runs USE qs_linres_module, ONLY: linres_calculation USE reference_manager, ONLY: export_references_as_xml USE rt_bse, ONLY: run_propagation_bse - USE rt_bse_linearized, ONLY: run_propagation_linearized_bse USE rt_propagation, ONLY: rt_prop_setup USE swarm, ONLY: run_swarm USE tamc_run, ONLY: qs_tamc @@ -315,9 +314,8 @@ CONTAINS method_name_id /= do_nnp .AND. & method_name_id /= do_embed .AND. & method_name_id /= do_fist .AND. & - method_name_id /= do_ipi) THEN + method_name_id /= do_ipi) & CPABORT("Energy/Force run not available for all methods ") - END IF sublogger => cp_get_default_logger() CALL cp_add_iter_level(sublogger%iter_info, "JUST_ENERGY", & @@ -326,9 +324,8 @@ CONTAINS ! loop over molecules to generate a molecular guess ! this procedure is initiated here to avoid passing globenv deep down ! the subroutine stack - IF (do_mol_loop(force_env=force_env)) THEN + IF (do_mol_loop(force_env=force_env)) & CALL loop_over_molecules(globenv, force_env) - END IF SELECT CASE (globenv%run_type_id) CASE (energy_run) @@ -350,26 +347,21 @@ CONTAINS CASE (do_tamc) CALL qs_tamc(force_env, globenv) CASE (real_time_propagation) - IF (method_name_id /= do_qs) THEN + IF (method_name_id /= do_qs) & CPABORT("Real time propagation needs METHOD QS. ") - END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .TRUE. SELECT CASE (dft_control%rtp_control%rtp_method) - CASE (rtp_method_bse_linearized) - ! Run the linearized TD-BSE method - CALL run_propagation_linearized_bse(force_env) CASE (rtp_method_bse) ! Run the TD-BSE method - CALL run_propagation_bse(force_env) + CALL run_propagation_bse(force_env%qs_env, force_env) CASE default ! Run the TDDFT method CALL rt_prop_setup(force_env) END SELECT CASE (ehrenfest) - IF (method_name_id /= do_qs) THEN + IF (method_name_id /= do_qs) & CPABORT("Ehrenfest dynamics needs METHOD QS ") - END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .FALSE. CALL qs_mol_dyn(force_env, globenv) @@ -377,9 +369,8 @@ CONTAINS CALL do_bsse_calculation(force_env, globenv) CASE (linear_response_run) IF (method_name_id /= do_qs .AND. & - method_name_id /= do_qmmm) THEN + method_name_id /= do_qmmm) & CPABORT("Property calculations by Linear Response only within the QS or QMMM program ") - END IF ! The Ground State is needed, it can be read from Restart CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., linres=.TRUE.) CALL linres_calculation(force_env) @@ -809,9 +800,8 @@ CONTAINS ! change to the new working directory CALL m_chdir(TRIM(farming_env%Job(i)%cwd), ierr) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CPABORT("Failed to change dir to: "//TRIM(farming_env%Job(i)%cwd)) - END IF ! generate a fresh call to cp2k_run IF (new_rank == 0) THEN diff --git a/src/start/cp2k_shell.F b/src/start/cp2k_shell.F index 6dd3ad5438..d1071bc108 100644 --- a/src/start/cp2k_shell.F +++ b/src/start/cp2k_shell.F @@ -541,13 +541,13 @@ CONTAINS TYPE(cp2k_shell_type) :: shell CHARACTER(LEN=*), INTENT(IN) :: arg1 - INTEGER :: ierr, n_atom + INTEGER :: ierr, iostat, n_atom IF (.NOT. parse_env_id(arg1, shell)) RETURN CALL get_natom(shell%env_id, n_atom, ierr) IF (.NOT. my_assert(ierr == 0, 'get_natom failed', shell)) RETURN IF (shell%iw > 0) THEN - WRITE (shell%iw, '(i10)') n_atom + WRITE (shell%iw, '(i10)', iostat=iostat) n_atom CALL m_flush(shell%iw) END IF END SUBROUTINE get_natom_command diff --git a/src/start/input_cp2k_motion.F b/src/start/input_cp2k_motion.F index cb9af737aa..550678a73f 100644 --- a/src/start/input_cp2k_motion.F +++ b/src/start/input_cp2k_motion.F @@ -1692,7 +1692,7 @@ CONTAINS CALL section_create(section, __LOCATION__, name="DRIVER", & description="This section defines the parameters needed to run in i-PI driver mode.", & citations=[Ceriotti2014, Kapil2016], & - n_keywords=4, n_subsections=0, repeats=.FALSE.) + n_keywords=3, n_subsections=0, repeats=.FALSE.) NULLIFY (keyword) CALL keyword_create(keyword, __LOCATION__, name="unix", & @@ -1716,14 +1716,6 @@ CONTAINS CALL section_add_keyword(section, keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="PREFIX", & - description="Prefix used to build the path of the UNIX socket file, "// & - "as /tmp/_. Only relevant if UNIX is set to true.", & - usage="PREFIX ipi", & - default_c_val="ipi") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - CALL keyword_create(keyword, __LOCATION__, name="SLEEP_TIME", & description="Sleeping time while waiting for for driver commands [s].", & usage="SLEEP_TIME 0.1", & diff --git a/src/start/libcp2k.F b/src/start/libcp2k.F index 4ac0f6b73b..85f39e3c5a 100755 --- a/src/start/libcp2k.F +++ b/src/start/libcp2k.F @@ -515,9 +515,8 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=nmo) END BLOCK try @@ -556,15 +555,13 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=norb) - IF (buf_len < norb*norb) THEN + IF (buf_len < norb*norb) & EXIT try - END IF DO i = 0, norb - 1 DO j = 0, norb - 1 @@ -605,9 +602,8 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF nze_count = INT(active_space_env%eri%eri(1)%csr_mat%nze_total, KIND(nze_count)) END BLOCK try @@ -650,14 +646,12 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF ASSOCIATE (nze => active_space_env%eri%eri(1)%csr_mat%nze_total) - IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) THEN + IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) & EXIT try - END IF CALL active_space_env%eri%eri_foreach(1, active_space_env%active_orbitals, eri2array(buf_coords, buf_values)) diff --git a/src/stm_images.F b/src/stm_images.F index a0f6411fcc..d4e1ecb285 100644 --- a/src/stm_images.F +++ b/src/stm_images.F @@ -309,9 +309,8 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) THEN + IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) & WRITE (output_unit, '(T4,A)') "Warning: EFermi+bias below lowest computed occupied MO" - END IF ELSE nmo = SIZE(evals(ispin)%array) DO imo = 1, nmo @@ -321,9 +320,8 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) THEN + IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) & WRITE (output_unit, '(T4,A)') "Warning: E-Fermi+bias above highest computed unoccupied MO" - END IF END IF istates = istates + nstates(ispin) END DO diff --git a/src/subsys/colvar_types.F b/src/subsys/colvar_types.F index 1e390bc3ec..b7c28982d7 100644 --- a/src/subsys/colvar_types.F +++ b/src/subsys/colvar_types.F @@ -501,7 +501,7 @@ CONTAINS SUBROUTINE colvar_setup(colvar) TYPE(colvar_type), INTENT(INOUT) :: colvar - INTEGER :: i, idum, iend, ii, istart, j, np + INTEGER :: i, idum, iend, ii, istart, j, np, stat INTEGER, DIMENSION(:), POINTER :: list SELECT CASE (colvar%type_id) @@ -660,12 +660,11 @@ CONTAINS IF (colvar%plane_plane_angle_param%plane1%type_of_def == plane_def_atoms) np = np + 3 IF (colvar%plane_plane_angle_param%plane2%type_of_def == plane_def_atoms) np = np + 3 ! if np is equal to zero this means that this is not a COLLECTIVE variable.. - IF (np == 0) THEN + IF (np == 0) & CALL cp_abort(__LOCATION__, & "PLANE_PLANE_ANGLE Colvar defined using two normal vectors! This is "// & "not a COLLECTIVE VARIABLE! One of the two planes must be defined "// & "using atomic positions.") - END IF ! Number of real atoms involved in the colvar colvar%n_atom_s = 0 @@ -851,8 +850,8 @@ CONTAINS i = colvar%xyz_outerdiag_param%i_atoms(2) list(2) = i CASE (u_colvar_id) - np = 1 - ALLOCATE (list(np)) + np = 1; ALLOCATE (list(np), stat=stat) + CPASSERT(stat == 0) colvar%n_atom_s = np; list(1) = 1 CASE (Wc_colvar_id) np = 3 @@ -1035,9 +1034,8 @@ CONTAINS idum = idum + 1 i = i_oxygens(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) THEN + IF (ANY(i_hydrogens == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS and HYDROGENS list") - END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1048,12 +1046,10 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens) THEN + IF (i <= n_oxygens) & CPABORT("atoms doubled in OXYGENS list") - END IF - IF (i > n_oxygens) THEN + IF (i > n_oxygens) & CPABORT("atoms doubled in HYDROGENS list") - END IF END IF END DO END DO @@ -1117,20 +1113,17 @@ CONTAINS idum = idum + 1 i = i_oxygens_water(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) THEN + IF (ANY(i_hydrogens == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and HYDROGENS list") - END IF - IF (ANY(i_oxygens_acid == i)) THEN + IF (ANY(i_oxygens_acid == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and OXYGENS_ACID list") - END IF END DO DO ii = 1, n_oxygens_acid idum = idum + 1 i = i_oxygens_acid(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) THEN + IF (ANY(i_hydrogens == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS_ACID and HYDROGENS list") - END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1141,15 +1134,12 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens_water) THEN + IF (i <= n_oxygens_water) & CPABORT("atoms doubled in OXYGENS_WATER list") - END IF - IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) THEN + IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) & CPABORT("atoms doubled in OXYGENS_ACID list") - END IF - IF (i > n_oxygens_water + n_oxygens_acid) THEN + IF (i > n_oxygens_water + n_oxygens_acid) & CPABORT("atoms doubled in HYDROGENS list") - END IF END IF END DO END DO @@ -1364,7 +1354,7 @@ CONTAINS TYPE(colvar_type), INTENT(IN) :: colvar_in INTEGER, INTENT(IN), OPTIONAL :: i_atom_offset - INTEGER :: i, my_offset, ndim, ndim2 + INTEGER :: i, my_offset, ndim, ndim2, stat my_offset = 0 IF (PRESENT(i_atom_offset)) my_offset = i_atom_offset @@ -1417,7 +1407,7 @@ CONTAINS ndim = SIZE(colvar_in%coord_param%c_kinds_to_b) ALLOCATE (colvar_out%coord_param%c_kinds_to_b(ndim)) colvar_out%coord_param%c_kinds_to_b = colvar_in%coord_param%c_kinds_to_b - ELSE IF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN + ELSEIF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_to_b) ALLOCATE (colvar_out%coord_param%i_at_to_b(ndim)) @@ -1625,11 +1615,11 @@ CONTAINS colvar_out%reaction_path_param%align_frames = colvar_in%reaction_path_param%align_frames colvar_out%reaction_path_param%subset = colvar_in%reaction_path_param%subset ndim = SIZE(colvar_in%reaction_path_param%i_rmsd) - ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim)) + ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim), stat=stat) colvar_out%reaction_path_param%i_rmsd = colvar_in%reaction_path_param%i_rmsd ndim = SIZE(colvar_in%reaction_path_param%r_ref, 1) ndim2 = SIZE(colvar_in%reaction_path_param%r_ref, 2) - ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2)) + ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2), stat=stat) colvar_out%reaction_path_param%r_ref = colvar_in%reaction_path_param%r_ref ELSE ndim = SIZE(colvar_in%reaction_path_param%colvar_p) @@ -1852,9 +1842,8 @@ CONTAINS IF (ASSOCIATED(colvar_p)) THEN DO i = 1, SIZE(colvar_p) - IF (ASSOCIATED(colvar_p(i)%colvar)) THEN + IF (ASSOCIATED(colvar_p(i)%colvar)) & CALL colvar_release(colvar_p(i)%colvar) - END IF END DO DEALLOCATE (colvar_p) END IF diff --git a/src/subsys/external_potential_types.F b/src/subsys/external_potential_types.F index 26bc3d047f..dbdf0c557a 100644 --- a/src/subsys/external_potential_types.F +++ b/src/subsys/external_potential_types.F @@ -587,13 +587,11 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) name = potential%name - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & alpha_core_charge = potential%alpha_core_charge - END IF IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & core_charge_radius = potential%core_charge_radius - END IF IF (PRESENT(z)) z = potential%z IF (PRESENT(zeff)) zeff = potential%zeff IF (PRESENT(zeff_correction)) zeff_correction = potential%zeff_correction @@ -765,15 +763,13 @@ CONTAINS IF (PRESENT(name)) name = potential%name IF (PRESENT(aliases)) aliases = potential%aliases - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & alpha_core_charge = potential%alpha_core_charge - END IF IF (PRESENT(alpha_ppl)) alpha_ppl = potential%alpha_ppl IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge IF (PRESENT(cerf_ppl)) cerf_ppl = potential%cerf_ppl - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & core_charge_radius = potential%core_charge_radius - END IF IF (PRESENT(ppl_radius)) ppl_radius = potential%ppl_radius IF (PRESENT(ppnl_radius)) ppnl_radius = potential%ppnl_radius IF (PRESENT(soc_present)) soc_present = potential%soc @@ -1375,10 +1371,9 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1416,10 +1411,9 @@ CONTAINS IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r ELSE @@ -1563,10 +1557,9 @@ CONTAINS ! Read ngau and npol IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) ngau, npol CALL remove_word(line_att) @@ -1586,10 +1579,9 @@ CONTAINS DO igau = 1, ngau IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) alpha(igau), (cval(igau, ipol), ipol=1, npol) ELSE @@ -1783,10 +1775,9 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1827,10 +1818,9 @@ CONTAINS ! distribution and calculate the corresponding coefficient IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2167,10 +2157,9 @@ CONTAINS DO l = 0, lppnl IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2215,15 +2204,13 @@ CONTAINS END IF ELSE IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) THEN + IF (LEN_TRIM(line_att) /= 0) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) hprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2271,15 +2258,13 @@ CONTAINS ! Read non-local parameters for spin-orbit coupling DO i = 1, nprj_ppnl IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) THEN + IF (LEN_TRIM(line_att) /= 0) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) kprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2458,13 +2443,11 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & potential%alpha_core_charge = alpha_core_charge - END IF IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & potential%core_charge_radius = core_charge_radius - END IF IF (PRESENT(z)) potential%z = z IF (PRESENT(zeff)) potential%zeff = zeff IF (PRESENT(zeff_correction)) potential%zeff_correction = zeff_correction @@ -2590,15 +2573,13 @@ CONTAINS POINTER :: hprj_ppnl, kprj_ppnl IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & potential%alpha_core_charge = alpha_core_charge - END IF IF (PRESENT(alpha_ppl)) potential%alpha_ppl = alpha_ppl IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge IF (PRESENT(cerf_ppl)) potential%cerf_ppl = cerf_ppl - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & potential%core_charge_radius = core_charge_radius - END IF IF (PRESENT(ppl_radius)) potential%ppl_radius = ppl_radius IF (PRESENT(ppnl_radius)) potential%ppnl_radius = ppnl_radius IF (PRESENT(lppnl)) potential%lppnl = lppnl diff --git a/src/subsys/molecule_kind_types.F b/src/subsys/molecule_kind_types.F index 9943a66164..232123e92e 100644 --- a/src/subsys/molecule_kind_types.F +++ b/src/subsys/molecule_kind_types.F @@ -365,9 +365,8 @@ CONTAINS END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set)) THEN DO i = 1, SIZE(molecule_kind_set(imolecule_kind)%bend_kind_set) - IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) THEN + IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) & DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs) - END IF END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set) END IF @@ -935,30 +934,24 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T9,A,I6,/,T9,A,(T30,5I10))") & "Number of molecules: ", nmolecule, "Molecule list:", & (molecule_kind%molecule_list(imolecule), imolecule=1, nmolecule) - IF (molecule_kind%nbond > 0) THEN + IF (molecule_kind%nbond > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bonds: ", molecule_kind%nbond - END IF - IF (molecule_kind%nbend > 0) THEN + "Number of bonds: ", molecule_kind%nbond + IF (molecule_kind%nbend > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bends: ", molecule_kind%nbend - END IF - IF (molecule_kind%nub > 0) THEN + "Number of bends: ", molecule_kind%nbend + IF (molecule_kind%nub > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of Urey-Bradley:", molecule_kind%nub - END IF - IF (molecule_kind%ntorsion > 0) THEN + "Number of Urey-Bradley:", molecule_kind%nub + IF (molecule_kind%ntorsion > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of torsions: ", molecule_kind%ntorsion - END IF - IF (molecule_kind%nimpr > 0) THEN + "Number of torsions: ", molecule_kind%ntorsion + IF (molecule_kind%nimpr > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of improper: ", molecule_kind%nimpr - END IF - IF (molecule_kind%nopbend > 0) THEN + "Number of improper: ", molecule_kind%nimpr + IF (molecule_kind%nopbend > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of out opbends: ", molecule_kind%nopbend - END IF + "Number of out opbends: ", molecule_kind%nopbend END IF END IF END SUBROUTINE write_molecule_kind diff --git a/src/subsys/molecule_types.F b/src/subsys/molecule_types.F index 41d097f00c..f300b5d188 100644 --- a/src/subsys/molecule_types.F +++ b/src/subsys/molecule_types.F @@ -212,13 +212,11 @@ CONTAINS DEALLOCATE (gci%colv_list) END IF - IF (ASSOCIATED(gci%g3x3_list)) THEN + IF (ASSOCIATED(gci%g3x3_list)) & DEALLOCATE (gci%g3x3_list) - END IF - IF (ASSOCIATED(gci%g4x6_list)) THEN + IF (ASSOCIATED(gci%g4x6_list)) & DEALLOCATE (gci%g4x6_list) - END IF ! Local information IF (ASSOCIATED(gci%lcolv)) THEN @@ -229,17 +227,14 @@ CONTAINS DEALLOCATE (gci%lcolv) END IF - IF (ASSOCIATED(gci%lg3x3)) THEN + IF (ASSOCIATED(gci%lg3x3)) & DEALLOCATE (gci%lg3x3) - END IF - IF (ASSOCIATED(gci%lg4x6)) THEN + IF (ASSOCIATED(gci%lg4x6)) & DEALLOCATE (gci%lg4x6) - END IF - IF (ASSOCIATED(gci%fixd_list)) THEN + IF (ASSOCIATED(gci%fixd_list)) & DEALLOCATE (gci%fixd_list) - END IF DEALLOCATE (gci) END IF diff --git a/src/surface_dipole.F b/src/surface_dipole.F index ef35421cad..a4271394e8 100644 --- a/src/surface_dipole.F +++ b/src/surface_dipole.F @@ -166,7 +166,7 @@ CONTAINS rhoavsurf(i) = accurate_sum(wf_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), i)) END DO - ELSE IF (idir_surfdip == 2) THEN + ELSEIF (idir_surfdip == 2) THEN isurf = 3 jsurf = 1 @@ -258,7 +258,7 @@ CONTAINS IF (idir_surfdip == 3) THEN vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) = & vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) + vdip - ELSE IF (idir_surfdip == 2) THEN + ELSEIF (idir_surfdip == 2) THEN IF (irho >= bo(1, 2) .AND. irho <= bo(2, 2)) THEN vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) = & vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) + vdip diff --git a/src/swarm/glbopt_history.F b/src/swarm/glbopt_history.F index a217a22a75..81cc126cca 100644 --- a/src/swarm/glbopt_history.F +++ b/src/swarm/glbopt_history.F @@ -213,9 +213,8 @@ CONTAINS ALLOCATE (history%entries(k)%p) history%entries(k)%p = fingerprint - IF (PRESENT(id)) THEN + IF (PRESENT(id)) & history%entries(k)%id = id - END IF history%length = history%length + 1 IF (debug) THEN @@ -223,9 +222,8 @@ CONTAINS DO k = 1, history%length !WRITE(*,*) "history: ", k, "Epot",history%entries(k)%p%Epot IF (k > 1) THEN - IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) THEN + IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) & CPABORT("history_add: history in wrong order") - END IF END IF END DO END IF @@ -376,9 +374,8 @@ CONTAINS INTEGER :: i DO i = 1, history%length - IF (ASSOCIATED(history%entries(i)%p)) THEN + IF (ASSOCIATED(history%entries(i)%p)) & DEALLOCATE (history%entries(i)%p) - END IF END DO DEALLOCATE (history%entries) diff --git a/src/swarm/glbopt_mincrawl.F b/src/swarm/glbopt_mincrawl.F index bbb9eb7133..ce6938ec53 100644 --- a/src/swarm/glbopt_mincrawl.F +++ b/src/swarm/glbopt_mincrawl.F @@ -182,9 +182,8 @@ CONTAINS RETURN END IF - IF (TRIM(status) == "ok") THEN + IF (TRIM(status) == "ok") & CALL mincrawl_register_minima(this, report) - END IF IF (.FALSE.) CALL print_tempdist(best_minima) diff --git a/src/swarm/glbopt_minhop.F b/src/swarm/glbopt_minhop.F index 53c4202532..9bde51b2d7 100644 --- a/src/swarm/glbopt_minhop.F +++ b/src/swarm/glbopt_minhop.F @@ -217,9 +217,8 @@ CONTAINS ! new locally lowest IF (this%iw > 0) WRITE (this%iw, '(A)') " MINHOP| New locally lowest" this%worker_state(wid)%Epot_hop = report_Epot - IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) THEN + IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) & ALLOCATE (this%worker_state(wid)%pos_hop(SIZE(report_positions))) - END IF this%worker_state(wid)%pos_hop(:) = report_positions this%worker_state(wid)%fp_hop = report_fp END IF diff --git a/src/swarm/glbopt_worker.F b/src/swarm/glbopt_worker.F index bcb2f8134a..78e14d9927 100644 --- a/src/swarm/glbopt_worker.F +++ b/src/swarm/glbopt_worker.F @@ -232,9 +232,8 @@ CONTAINS END DO CALL unpack_subsys_particles(worker%subsys, r=positions) - IF (n_fragments > 0 .AND. worker%iw > 0) THEN + IF (n_fragments > 0 .AND. worker%iw > 0) & WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Ran fix_fragmentation times:", n_fragments - END IF ! setup geometry optimization IF (worker%iw > 0) WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Starting local optimisation at trajectory frame ", iframe @@ -293,10 +292,10 @@ CONTAINS DO WHILE (stack_size > 0) i = stack(stack_size); stack_size = stack_size - 1 !pop DO j = 1, n_particles - IF (NORM2(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected + IF (norm(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected IF (.NOT. marked(j)) THEN marked(j) = .TRUE. - stack(stack_size + 1) = j; stack_size = stack_size + 1 !push + stack(stack_size + 1) = j; stack_size = stack_size + 1; !push END IF END IF END DO @@ -315,7 +314,7 @@ CONTAINS IF (marked(i)) CYCLE DO j = 1, n_particles IF (.NOT. marked(j)) CYCLE - d = NORM2(diff(positions, i, j)) + d = norm(diff(positions, i, j)) IF (d < min_dist) THEN min_dist = d cluster_edge = i @@ -325,7 +324,7 @@ CONTAINS END DO dr = diff(positions, cluster_edge, fragment_edge) - s = 1.0 - bondlength/NORM2(dr) + s = 1.0 - bondlength/norm(dr) DO i = 1, n_particles IF (marked(i)) CYCLE positions(3*i - 2:3*i) = positions(3*i - 2:3*i) - s*dr @@ -349,6 +348,19 @@ CONTAINS dr = positions(3*i - 2:3*i) - positions(3*j - 2:3*j) END FUNCTION diff +! ************************************************************************************************** +!> \brief Helper routine for fix_fragmentation, calculates vector norm +!> \param vec ... +!> \return ... +!> \author Ole Schuett +! ************************************************************************************************** + PURE FUNCTION norm(vec) RESULT(res) + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec + REAL(KIND=dp) :: res + + res = SQRT(DOT_PRODUCT(vec, vec)) + END FUNCTION norm + ! ************************************************************************************************** !> \brief Finalizes worker for global optimization !> \param worker ... diff --git a/src/swarm/swarm_master.F b/src/swarm/swarm_master.F index bd627a6d5d..703686c352 100644 --- a/src/swarm/swarm_master.F +++ b/src/swarm/swarm_master.F @@ -261,9 +261,8 @@ CONTAINS IF (.NOT. master%should_stop) THEN CALL external_control(master%should_stop, "SWARM", master%globenv) - IF (master%should_stop .AND. master%iw > 0) THEN + IF (master%should_stop .AND. master%iw > 0) & WRITE (master%iw, *) " SWARM| Received stop from external_control. Quitting." - END IF END IF !IF(unit > 0) & diff --git a/src/swarm/swarm_message.F b/src/swarm/swarm_message.F index 79bc07e666..96418c033a 100644 --- a/src/swarm/swarm_message.F +++ b/src/swarm/swarm_message.F @@ -866,9 +866,8 @@ CONTAINS TYPE(message_entry_type), POINTER :: new_entry - IF (swarm_message_haskey(msg, key)) THEN + IF (swarm_message_haskey(msg, key)) & CPABORT("swarm_message_add_${label}$: key already exists: "//TRIM(key)) - END IF ALLOCATE (new_entry) new_entry%key = key @@ -921,9 +920,8 @@ CONTAINS curr_entry => msg%root DO WHILE (ASSOCIATED(curr_entry)) IF (TRIM(curr_entry%key) == TRIM(key)) THEN - IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) THEN + IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) & CPABORT("swarm_message_get_${label}$: value not associated key: "//TRIM(key)) - END IF #:if label.startswith("1d_") ALLOCATE (value(SIZE(curr_entry%value_${label}$))) #:endif diff --git a/src/swarm/swarm_mpi.F b/src/swarm/swarm_mpi.F index db985c32f6..f1f4842ffe 100644 --- a/src/swarm/swarm_mpi.F +++ b/src/swarm/swarm_mpi.F @@ -133,9 +133,8 @@ CONTAINS !WRITE (*,*) "this is worker ", worker_id, swarm_mpi%worker%mepos, swarm_mpi%worker%num_pe ! collect world-ranks of each worker groups rank-0 node - IF (swarm_mpi%worker%mepos == 0) THEN + IF (swarm_mpi%worker%mepos == 0) & swarm_mpi%wid2group(worker_id) = swarm_mpi%world%mepos - END IF END IF @@ -163,16 +162,14 @@ CONTAINS logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr swarm_mpi%master_output_path = output_unit2path(output_unit) - IF (output_unit /= default_output_unit) THEN + IF (output_unit /= default_output_unit) & CLOSE (output_unit) - END IF END IF CALL swarm_mpi%world%bcast(swarm_mpi%master_output_path) - IF (ASSOCIATED(swarm_mpi%master)) THEN + IF (ASSOCIATED(swarm_mpi%master)) & CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path) - END IF END SUBROUTINE logger_init_master ! ************************************************************************************************** @@ -186,9 +183,8 @@ CONTAINS CHARACTER(LEN=default_path_length) :: output_path output_path = "__STD_OUT__" - IF (output_unit /= default_output_unit) THEN + IF (output_unit /= default_output_unit) & INQUIRE (unit=output_unit, name=output_path) - END IF END FUNCTION output_unit2path ! ************************************************************************************************** @@ -249,10 +245,9 @@ CONTAINS IF (para_env%is_source()) THEN ! open output_unit according to output_path output_unit = default_output_unit - IF (output_path /= "__STD_OUT__") THEN + IF (output_path /= "__STD_OUT__") & CALL open_file(file_name=output_path, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", unit_number=output_unit) - END IF END IF old_logger => cp_get_default_logger() @@ -299,9 +294,8 @@ CONTAINS NULLIFY (logger, old_logger) logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr - IF (output_unit > 0 .AND. output_unit /= default_output_unit) THEN + IF (output_unit > 0 .AND. output_unit /= default_output_unit) & CALL close_file(output_unit) - END IF CALL cp_rm_default_logger() !pops the top-most logger old_logger => cp_get_default_logger() diff --git a/src/swarm/swarm_worker.F b/src/swarm/swarm_worker.F index 13c8f698e8..2b51172354 100644 --- a/src/swarm/swarm_worker.F +++ b/src/swarm/swarm_worker.F @@ -123,9 +123,8 @@ CONTAINS END SELECT END IF - IF (.NOT. swarm_message_haskey(report, "status")) THEN + IF (.NOT. swarm_message_haskey(report, "status")) & CALL swarm_message_add(report, "status", "ok") - END IF END SUBROUTINE swarm_worker_execute diff --git a/src/task_list_methods.F b/src/task_list_methods.F index 5b467db21c..f7983f47a6 100644 --- a/src/task_list_methods.F +++ b/src/task_list_methods.F @@ -1682,7 +1682,8 @@ CONTAINS DO i = 1, desc%group_size ! At the moment we can only offload replicated tasks - IF (load_imbalance(i) > 0) load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) + IF (load_imbalance(i) > 0) & + load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) END DO ! simplest algorithm I can think of of is that the processor with the most @@ -1934,9 +1935,8 @@ CONTAINS DO igrid_level = 1, SIZE(rs_descs) IF (rs_descs(igrid_level)%rs_desc%distributed) THEN - IF (.NOT. skip_load_balance_distributed) THEN + IF (.NOT. skip_load_balance_distributed) & CALL load_balance_distributed(tasks, ntasks, rs_descs, igrid_level, natoms) - END IF CALL get_current_loads(loads(:, igrid_level), rs_descs, igrid_level, ntasks, & tasks, use_reordered_ranks=.FALSE.) @@ -1958,6 +1958,10 @@ CONTAINS END IF END DO + !IF (desc%my_pos==0) THEN + ! WRITE(*,*) "Total replicated load is ",replicated_load + !END IF + ! Now we adjust the rank ordering based on the current loads ! we leave the first distributed level and all the replicated levels in the default order IF (reorder_rs_grid_ranks) THEN @@ -2018,6 +2022,21 @@ CONTAINS ! Now we use the replicated tasks to balance out the rest of the load CALL load_balance_replicated(rs_descs, ntasks, tasks) + !total_loads = 0 + !DO igrid_level=1,SIZE(rs_descs) + ! CALL get_current_loads(loads(:,igrid_level), rs_descs, igrid_level, ntasks, & + ! tasks, use_reordered_ranks=.TRUE.) + ! total_loads = total_loads + loads(:, igrid_level) + !END DO + + !IF (desc%my_pos==0) THEN + ! WRITE(*,*) "" + ! WRITE(*,*) "At the end of the load balancing procedure" + ! WRITE(*,*) "Maximum load:",MAXVAL(total_loads) + ! WRITE(*,*) "Average load:",SUM(total_loads)/SIZE(total_loads) + ! WRITE(*,*) "Minimum load:",MINVAL(total_loads) + !ENDIF + ! given a list of tasks, this will do the needed reshuffle so that all tasks will be local CALL create_local_tasks(rs_descs, ntasks, tasks, ntasks_recv, tasks_recv) @@ -2027,6 +2046,13 @@ CONTAINS ! CALL get_atom_pair(atom_pair_send, tasks, ntasks=ntasks, send=.TRUE., symmetric=symmetric, rs_descs=rs_descs) + ! natom_send=SIZE(atom_pair_send) + ! CALL desc%group%sum(natom_send) + ! IF (desc%my_pos==0) THEN + ! WRITE(*,*) "" + ! WRITE(*,*) "Total number of atomic blocks to be send:",natom_send + ! ENDIF + CALL get_atom_pair(atom_pair_recv, tasks_recv, ntasks=ntasks_recv, send=.FALSE., symmetric=symmetric, rs_descs=rs_descs) ! cleanup, at this point we don't need the original tasks anymore @@ -2833,24 +2859,18 @@ CONTAINS tasks(itask)%subpatch_pattern = 0 ! encode the domain size for this task ! if the bit is set, we need to add the border in that direction - IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) THEN + IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 0) - END IF - IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) THEN + IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 1) - END IF - IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) THEN + IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 2) - END IF - IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) THEN + IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 3) - END IF - IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) THEN + IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 4) - END IF - IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) THEN + IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 5) - END IF itask = itask + 1 END DO END DO diff --git a/src/tblite_interface.F b/src/tblite_interface.F index b0e92fde80..c15de30544 100644 --- a/src/tblite_interface.F +++ b/src/tblite_interface.F @@ -180,9 +180,8 @@ CONTAINS nspin = SIZE(matrix_p, 1) nimg = SIZE(matrix_p, 2) IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN - IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) THEN + IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) & CALL dbcsr_deallocate_matrix_set(tb%rho_ao_kp_ref) - END IF END IF IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN CALL dbcsr_allocate_matrix_set(tb%rho_ao_kp_ref, nspin, nimg) @@ -338,9 +337,8 @@ CONTAINS info = tb%calc%variable_info() IF (info%charge > shell_resolved) CPABORT("tblite: no support for orbital resolved charge") IF (info%dipole > atom_resolved) CPABORT("tblite: no support for shell resolved dipole moment") - IF (info%quadrupole > atom_resolved) THEN + IF (info%quadrupole > atom_resolved) & CPABORT("tblite: no support shell resolved quadrupole moment") - END IF CALL new_wavefunction(tb%wfn, tb%mol%nat, tb%calc%bas%nsh, tb%calc%bas%nao, nSpin, 0.0_dp) CALL get_occupation(tb%mol, tb%calc%bas, tb%calc%h0, tb%wfn%nocc, tb%wfn%n0at, tb%wfn%n0sh) @@ -465,9 +463,8 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT("tblite SCC mixer OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT("tblite SCC mixer MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (max_weight < min_weight) THEN + IF (max_weight < min_weight) & CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") - END IF IF (weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") SELECT CASE (solver) CASE (tblite_solver_gvd, tblite_solver_gvr) @@ -479,7 +476,7 @@ CONTAINS tb%mixer_memory = memory tb%mixer_solver = solver tb%mixer_damping = damping - tb%calc%mixer_input%damping = damping + tb%calc%mixer_damping = damping tb%mixer_omega0 = omega0 tb%mixer_min_weight = min_weight tb%mixer_max_weight = max_weight @@ -1473,9 +1470,8 @@ CONTAINS END IF !compute multipole moments for gfn2 - IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) THEN + IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) & CALL tb_get_multipole(qs_env, tb) - END IF ! output overlap information NULLIFY (logger) @@ -1586,7 +1582,7 @@ CONTAINS CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_GRADIENT", debug_value, STATUS=debug_status) IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_gradient CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_POTENTIAL", debug_value, STATUS=debug_status) - IF (debug_status == 0) READ (debug_value, *) skip_scf_dispersion_potential + IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_potential #endif IF (dft_control%qs_control%do_ls_scf .OR. scf_control%use_ot) THEN use_native_mixer = .FALSE. @@ -1634,10 +1630,9 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSE IF (calculate_forces .AND. nspin > 1) THEN - IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN + ELSEIF (calculate_forces .AND. nspin > 1) THEN + IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) & CPABORT("Missing converged tblite density for UKS/LSD forces") - END IF matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -1928,7 +1923,7 @@ CONTAINS ! LS_SCF and OT optimize the electronic variables directly. Use the ! current shell/multipole response from that density without an ! extra SCC variable mixing step. - ELSE IF (nspin > 1) THEN + ELSEIF (nspin > 1) THEN n_mix_cols = nspin*max_shell IF (do_dipole) n_mix_cols = n_mix_cols + nspin*dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + nspin*quad_n @@ -1992,7 +1987,7 @@ CONTAINS skip_charge_mixing = use_no_mixer IF (skip_charge_mixing) THEN ! - ELSE IF (do_combined_mixing) THEN + ELSEIF (do_combined_mixing) THEN n_mix_cols = max_shell IF (do_dipole) n_mix_cols = n_mix_cols + dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + quad_n @@ -2123,12 +2118,10 @@ CONTAINS CALL tb%calc%coulomb%get_energy(tb%mol, tb%cache, tb%wfn, tb%e_es) END IF IF (ALLOCATED(tb%calc%dispersion)) THEN - IF (.NOT. skip_scf_dispersion_potential) THEN + IF (.NOT. skip_scf_dispersion_potential) & CALL tb%calc%dispersion%get_potential(tb%mol, tb%dcache, tb%wfn, tb%pot) - END IF - IF (.NOT. skip_scf_dispersion_energy) THEN + IF (.NOT. skip_scf_dispersion_energy) & CALL tb%calc%dispersion%get_energy(tb%mol, tb%dcache, tb%wfn, tb%e_scd) - END IF END IF IF (ALLOCATED(tb%calc%interactions)) THEN CALL tb%calc%interactions%get_potential(tb%mol, tb%icache, tb%wfn, tb%pot) @@ -3491,9 +3484,8 @@ CONTAINS kpoint_coordinate = REAL(2*ikp_axis - nkp_grid(i) - 1, KIND=dp)/ & REAL(2*nkp_grid(i), KIND=dp) + kp_shift(i) END IF - IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) THEN + IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) & mesh_has_gamma(i) = .TRUE. - END IF END DO END DO has_multipole_response = ASSOCIATED(tb%dipbra) .OR. ASSOCIATED(tb%quadbra) @@ -3501,7 +3493,7 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSE IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN + ELSEIF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -3941,9 +3933,8 @@ CONTAINS post_processing_output_file = "" IF (LEN_TRIM(ref%grad_file) > 0) grad_file = ref%grad_file IF (LEN_TRIM(ref%json_file) > 0) json_file = ref%json_file - IF (LEN_TRIM(ref%post_processing_output_file) > 0) THEN + IF (LEN_TRIM(ref%post_processing_output_file) > 0) & post_processing_output_file = ref%post_processing_output_file - END IF WRITE (charge_str, "(I0)") dft_control%charge spin = MAX(0, dft_control%multiplicity - 1) @@ -4035,9 +4026,8 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_min_weight_default, & ", while CP2K uses MIN_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_min_weight, "." - IF (ref%stop_on_error) THEN + IF (ref%stop_on_error) & CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MIN_WEIGHT") - END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_max_weight - & tblite_mixer_max_weight_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4046,9 +4036,8 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_max_weight_default, & ", while CP2K uses MAX_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_max_weight, "." - IF (ref%stop_on_error) THEN + IF (ref%stop_on_error) & CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MAX_WEIGHT") - END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_weight_factor - & tblite_mixer_weight_factor_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4058,22 +4047,19 @@ CONTAINS "The native reference run uses tblite's library default ", tblite_mixer_weight_factor_default, & ", while CP2K uses WEIGHT_FACTOR ", & dft_control%qs_control%xtb_control%tblite_mixer_weight_factor, "." - IF (ref%stop_on_error) THEN + IF (ref%stop_on_error) & CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/WEIGHT_FACTOR") - END IF END IF etemp = 300.0_dp - IF (ASSOCIATED(scf_control)) THEN - IF (ASSOCIATED(scf_control%smear)) THEN - IF (scf_control%smear%do_smear) THEN - etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") - IF (scf_control%smear%method /= smear_fermi_dirac) THEN - WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & - "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & - TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." - WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & - "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." - END IF + IF (ASSOCIATED(scf_control) .AND. ASSOCIATED(scf_control%smear)) THEN + IF (scf_control%smear%do_smear) THEN + etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") + IF (scf_control%smear%method /= smear_fermi_dirac) THEN + WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & + "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & + TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." + WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & + "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." END IF END IF END IF @@ -4086,15 +4072,13 @@ CONTAINS etemp_guess_str = " --etemp-guess "//TRIM(ADJUSTL(etemp_guess_val_str)) END IF param_str = "" - IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) THEN + IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) & param_str = " --param "//TRIM(tb_shell_quote(dft_control%qs_control%xtb_control%tblite_param_file)) - END IF spinpol_str = "" IF (dft_control%lsd) spinpol_str = " --spin-polarized" post_processing_str = "" - IF (LEN_TRIM(ref%post_processing) > 0) THEN + IF (LEN_TRIM(ref%post_processing) > 0) & post_processing_str = " --post-processing "//TRIM(tb_shell_quote(ref%post_processing)) - END IF post_processing_output_str = "" IF (LEN_TRIM(post_processing_output_file) > 0) THEN WRITE (UNIT=iounit, FMT="(/,T2,A)") & @@ -4105,9 +4089,8 @@ CONTAINS TRIM(tb_shell_quote(post_processing_output_file)) END IF restart_str = " --no-restart" - IF (LEN_TRIM(ref%restart_file) > 0) THEN + IF (LEN_TRIM(ref%restart_file) > 0) & restart_str = " --restart "//TRIM(tb_shell_quote(ref%restart_file)) - END IF CALL tb_write_reference_gen(qs_env, TRIM(gen_file)) @@ -4155,22 +4138,17 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,A)") "Guess: ", TRIM(guess) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Solver: ", TRIM(solver) WRITE (UNIT=iounit, FMT="(T2,A,L1)") "Spin-pol.: ", dft_control%lsd - IF (ref%efield_active) THEN + IF (ref%efield_active) & WRITE (UNIT=iounit, FMT="(T2,A,3ES16.8,A)") "Efield: ", ref%efield, " V/Angstrom" - END IF - IF (ref%solvation_active) THEN + IF (ref%solvation_active) & WRITE (UNIT=iounit, FMT="(T2,A,A,1X,A)") "Solvation: ", TRIM(solvation_model_name), & - TRIM(ref%solvation_solvent) - END IF - IF (LEN_TRIM(ref%post_processing) > 0) THEN + TRIM(ref%solvation_solvent) + IF (LEN_TRIM(ref%post_processing) > 0) & WRITE (UNIT=iounit, FMT="(T2,A,A)") "Post proc.: ", TRIM(ref%post_processing) - END IF - IF (LEN_TRIM(post_processing_output_file) > 0) THEN + IF (LEN_TRIM(post_processing_output_file) > 0) & WRITE (UNIT=iounit, FMT="(T2,A,A)") "PP output: ", TRIM(post_processing_output_file) - END IF - IF (ref%electronic_temperature_guess > 0.0_dp) THEN + IF (ref%electronic_temperature_guess > 0.0_dp) & WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") "Guess etemp:", etemp_guess, " K" - END IF WRITE (UNIT=iounit, FMT="(T2,A,A)") "Grad file: ", TRIM(grad_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "JSON file: ", TRIM(json_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Log file: ", TRIM(log_file) @@ -4373,9 +4351,8 @@ CONTAINS grad_str = "" IF (ref%guess_cli%grad) grad_str = " --grad" json_str = "" - IF (LEN_TRIM(ref%guess_cli%json_file) > 0) THEN + IF (LEN_TRIM(ref%guess_cli%json_file) > 0) & json_str = " --json "//TRIM(tb_shell_quote(ref%guess_cli%json_file)) - END IF log_file = TRIM(file_base)//".guess.log" command = TRIM(tb_shell_quote(ref%program_name))// & " guess --charge "//TRIM(ADJUSTL(charge_str))// & @@ -4390,44 +4367,38 @@ CONTAINS " "//TRIM(tb_shell_quote(guess_input))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "guess", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) THEN + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) & CALL tb_delete_file(ref%guess_cli%json_file) - END IF END IF IF (ref%param_cli%enabled) THEN method_str = "" - IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) THEN + IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) & method_str = " --method "// & TRIM(tb_reference_method_name(MERGE(ref%param_cli%method, & dft_control%qs_control%xtb_control%tblite_method, & ref%param_cli%method_explicit))) - END IF output_str = "" - IF (LEN_TRIM(ref%param_cli%output_file) > 0) THEN + IF (LEN_TRIM(ref%param_cli%output_file) > 0) & output_str = " --output "//TRIM(tb_shell_quote(ref%param_cli%output_file)) - END IF log_file = TRIM(file_base)//".param.log" command = TRIM(tb_shell_quote(ref%program_name))//" param"// & TRIM(method_str)// & TRIM(output_str) - IF (LEN_TRIM(ref%param_cli%input_file) > 0) THEN + IF (LEN_TRIM(ref%param_cli%input_file) > 0) & command = TRIM(command)//" "//TRIM(tb_shell_quote(ref%param_cli%input_file)) - END IF command = TRIM(command)//" > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "param", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) THEN + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) & CALL tb_delete_file(ref%param_cli%output_file) - END IF END IF IF (ref%fit_cli%enabled) THEN dry_run_str = "" IF (ref%fit_cli%dry_run) dry_run_str = " --dry-run" copy_str = "" - IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN + IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) & copy_str = " --copy "//TRIM(tb_shell_quote(ref%fit_cli%copy_file)) - END IF log_file = TRIM(file_base)//".fit.log" command = TRIM(tb_shell_quote(ref%program_name))//" fit"// & TRIM(dry_run_str)// & @@ -4436,9 +4407,8 @@ CONTAINS " "//TRIM(tb_shell_quote(ref%fit_cli%input_file))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "fit", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) & CALL tb_delete_file(ref%fit_cli%copy_file) - END IF END IF IF (ref%tagdiff_cli%enabled) THEN @@ -4770,9 +4740,8 @@ CONTAINS CALL tb_delete_file(grad_file) CALL tb_delete_file(json_file) CALL tb_delete_file(log_file) - IF (LEN_TRIM(post_processing_output_file) > 0) THEN + IF (LEN_TRIM(post_processing_output_file) > 0) & CALL tb_delete_file(post_processing_output_file) - END IF END SUBROUTINE tb_reference_cleanup diff --git a/src/tblite_scc_mixer.F b/src/tblite_scc_mixer.F index 84a6bf6d4b..237f33576f 100644 --- a/src/tblite_scc_mixer.F +++ b/src/tblite_scc_mixer.F @@ -220,7 +220,7 @@ CONTAINS ALLOCATE (beta(MIN(memory, itn), MIN(memory, itn)), c(MIN(memory, itn), 1)) - omega(it1) = NORM2(dq) + omega(it1) = SQRT(DOT_PRODUCT(dq, dq)) IF (omega(it1) > (wfac/maxw)) THEN omega(it1) = wfac/omega(it1) ELSE @@ -229,7 +229,7 @@ CONTAINS IF (omega(it1) < minw) omega(it1) = minw df(:, it1) = dq - dqlast - inv = MAX(NORM2(df(:, it1)), EPSILON(1.0_wp)) + inv = MAX(SQRT(DOT_PRODUCT(df(:, it1), df(:, it1))), EPSILON(1.0_wp)) inv = 1.0_wp/inv df(:, it1) = inv*df(:, it1) diff --git a/src/tblite_types.F b/src/tblite_types.F index 5ed92fa276..5fb1e505c7 100644 --- a/src/tblite_types.F +++ b/src/tblite_types.F @@ -133,21 +133,16 @@ CONTAINS IF (ALLOCATED(tb_tblite%dcndr)) DEALLOCATE (tb_tblite%dcndr) IF (ALLOCATED(tb_tblite%dcndL)) DEALLOCATE (tb_tblite%dcndL) - IF (ASSOCIATED(tb_tblite%dipbra)) THEN + IF (ASSOCIATED(tb_tblite%dipbra)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%dipbra) - END IF - IF (ASSOCIATED(tb_tblite%dipket)) THEN + IF (ASSOCIATED(tb_tblite%dipket)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%dipket) - END IF - IF (ASSOCIATED(tb_tblite%quadbra)) THEN + IF (ASSOCIATED(tb_tblite%quadbra)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%quadbra) - END IF - IF (ASSOCIATED(tb_tblite%quadket)) THEN + IF (ASSOCIATED(tb_tblite%quadket)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%quadket) - END IF - IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) THEN + IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%rho_ao_kp_ref) - END IF #if defined(__TBLITE) IF (ALLOCATED(tb_tblite%mixer)) DEALLOCATE (tb_tblite%mixer) IF (ALLOCATED(tb_tblite%param)) DEALLOCATE (tb_tblite%param) diff --git a/src/tmc/tmc_analysis.F b/src/tmc/tmc_analysis.F index a8dfda06b5..574ef635c3 100644 --- a/src/tmc/tmc_analysis.F +++ b/src/tmc/tmc_analysis.F @@ -118,15 +118,13 @@ CONTAINS CALL section_vals_val_get(tmc_ana_section, "DENSITY", i_vals=i_arr_tmp) IF (SIZE(i_arr_tmp(:)) == 3) THEN - IF (ANY(i_arr_tmp(:) <= 0)) THEN + IF (ANY(i_arr_tmp(:) <= 0)) & CALL cp_abort(__LOCATION__, "The amount of intervals in each "// & "direction has to be greater than 0.") - END IF nr_bins(:) = i_arr_tmp(:) ELSE IF (SIZE(i_arr_tmp(:)) == 1) THEN - IF (ANY(i_arr_tmp(:) <= 0)) THEN + IF (ANY(i_arr_tmp(:) <= 0)) & CPABORT("The amount of intervals has to be greater than 0.") - END IF nr_bins(:) = i_arr_tmp(1) ELSE IF (SIZE(i_arr_tmp(:)) == 0) THEN nr_bins(:) = 1 @@ -252,15 +250,13 @@ CONTAINS END IF ! init radial distribution function - IF (ASSOCIATED(ana_env%pair_correl)) THEN + IF (ASSOCIATED(ana_env%pair_correl)) & CALL ana_pair_correl_init(ana_pair_correl=ana_env%pair_correl, & atoms=ana_env%atoms, cell=ana_env%cell) - END IF ! init classical dipole moment calculations - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & CALL ana_dipole_moment_init(ana_dip_mom=ana_env%dip_mom, & atoms=ana_env%atoms) - END IF END SUBROUTINE analysis_init ! ************************************************************************************************** @@ -488,21 +484,18 @@ CONTAINS IF (weight_act > 0) THEN ! calculates the 3 dimensional distributed density - IF (ASSOCIATED(ana_env%density_3d)) THEN + IF (ASSOCIATED(ana_env%density_3d)) & CALL calc_density_3d(elem=ana_env%last_elem, & weight=weight_act, atoms=ana_env%atoms, & ana_env=ana_env) - END IF ! calculated the radial distribution function for each atom type - IF (ASSOCIATED(ana_env%pair_correl)) THEN + IF (ASSOCIATED(ana_env%pair_correl)) & CALL calc_paircorrelation(elem=ana_env%last_elem, weight=weight_act, & atoms=ana_env%atoms, ana_env=ana_env) - END IF ! calculates the classical dipole moments - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & CALL calc_dipole_moment(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) - END IF ! calculates the dipole moments analysis and dielectric constant IF (ASSOCIATED(ana_env%dip_ana)) THEN ! in symmetric case use also the dipoles @@ -511,72 +504,64 @@ CONTAINS ! (-x,y,z) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(3) = -ana_env%last_elem%dipole(3) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(3) = -ana_env%dip_mom%last_dip_cl(3) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(:) = -ana_env%last_elem%dipole(:) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(:) = -ana_env%dip_mom%last_dip_cl(:) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! back to (x,y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) - END IF END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) @@ -615,29 +600,24 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) IF (ASSOCIATED(ana_env%density_3d)) THEN - IF (ana_env%density_3d%conf_counter > 0) THEN + IF (ana_env%density_3d%conf_counter > 0) & CALL print_density_3d(ana_env=ana_env) - END IF END IF IF (ASSOCIATED(ana_env%pair_correl)) THEN - IF (ana_env%pair_correl%conf_counter > 0) THEN + IF (ana_env%pair_correl%conf_counter > 0) & CALL print_paircorrelation(ana_env=ana_env) - END IF END IF IF (ASSOCIATED(ana_env%dip_mom)) THEN - IF (ana_env%dip_mom%conf_counter > 0) THEN + IF (ana_env%dip_mom%conf_counter > 0) & CALL print_dipole_moment(ana_env) - END IF END IF IF (ASSOCIATED(ana_env%dip_ana)) THEN - IF (ana_env%dip_ana%conf_counter > 0) THEN + IF (ana_env%dip_ana%conf_counter > 0) & CALL print_dipole_analysis(ana_env) - END IF END IF IF (ASSOCIATED(ana_env%displace)) THEN - IF (ana_env%displace%conf_counter > 0) THEN + IF (ana_env%displace%conf_counter > 0) & CALL print_average_displacement(ana_env) - END IF END IF ! end the timing @@ -711,18 +691,16 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=elem) END IF ! if there was no previous element, create a new temp element to write in - IF (.NOT. ASSOCIATED(elem)) THEN + IF (.NOT. ASSOCIATED(elem)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & nr_dim=nr_dim) - END IF END DO conf_loop END IF ! close the files CALL analyse_files_close(tmc_ana=ana_env) - IF (ASSOCIATED(elem)) THEN + IF (ASSOCIATED(elem)) & CALL deallocate_sub_tree_node(tree_elem=elem) - END IF ! end the timing CALL timestop(handle) @@ -865,12 +843,11 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) THEN + IF (.NOT. flag) & WRITE (file_ptr, FMT='(A8,11A20)') "# conf_nr", "dens_act[g/cm^3]", & - "dens_average[g/cm^3]", "density_variance", & - "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & - "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" - END IF + "dens_average[g/cm^3]", "density_variance", & + "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & + "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" WRITE (file_ptr, FMT="(I8,11F20.10)") ana_env%density_3d%conf_counter + 1 - weight, & SUM(mass_bin(:, :, :))/vol_sub_box/SIZE(mass_bin(:, :, :)), & SUM(ana_env%density_3d%sum_density(:, :, :))/ & @@ -998,12 +975,11 @@ CONTAINS SIZE(ana_env%density_3d%sum_density(:, :, :))/ & REAL(ana_env%density_3d%conf_counter, KIND=dp))**2) WRITE (ana_env%io_unit, FMT="(/,T2,A)") REPEAT("-", 79) - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (ana_env%io_unit, *) "TMC|ANALYSIS_CELL_DENSITY_X= ", & - SUM(ana_env%density_3d%sum_density(:, :, :))/ & - SIZE(ana_env%density_3d%sum_density(:, :, :))/ & - REAL(ana_env%density_3d%conf_counter, KIND=dp) - END IF + SUM(ana_env%density_3d%sum_density(:, :, :))/ & + SIZE(ana_env%density_3d%sum_density(:, :, :))/ & + REAL(ana_env%density_3d%conf_counter, KIND=dp) ! end the timing CALL timestop(handle) END SUBROUTINE print_density_3d @@ -1199,13 +1175,12 @@ CONTAINS END DO CALL close_file(unit_number=file_ptr) - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (*, *) "TMC|ANALYSIS_G_R_"// & - TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & - TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & - SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & - voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) - END IF + TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & + TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & + SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & + voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) END DO ! end the timing @@ -1322,10 +1297,9 @@ CONTAINS SUBROUTINE print_dipole_moment(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (*, *) "TMC|ANALYSIS_FINAL_CLASS_CELL_DIPOLE_MOMENT_X= ", & - ana_env%dip_mom%last_dip_cl(:) - END IF + ana_env%dip_mom%last_dip_cl(:) END SUBROUTINE print_dipole_moment ! ************************************************************************************************** @@ -1353,9 +1327,8 @@ CONTAINS CPASSERT(ASSOCIATED(ana_env%dip_ana)) weight_act = weight - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & weight_act = weight_act/REAL(8.0, KIND=dp) - END IF ! get the volume ALLOCATE (scaled_cell) @@ -1548,14 +1521,12 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "temperature ", cp_to_string(ana_env%temperature) WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "used configurations ", & cp_to_string(REAL(ana_env%dip_ana%conf_counter, KIND=dp)) - IF (ana_env%dip_ana%ana_type == ana_type_ice) THEN + IF (ana_env%dip_ana%ana_type == ana_type_ice) & WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with directions of hexagonal structure" - END IF - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN + "ice analysis with directions of hexagonal structure" + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with symmetrized dipoles in each direction." - END IF + "ice analysis with symmetrized dipoles in each direction." WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "for product of 2 directions(per vol):" DO i = 1, 3 @@ -1636,9 +1607,8 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) THEN + IF (.NOT. flag) & WRITE (file_ptr, *) "# conf squared deviation of the cell" - END IF WRITE (file_ptr, *) elem%nr, disp CALL close_file(unit_number=file_ptr) END IF @@ -1668,10 +1638,9 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "cell root mean square deviation: ", & cp_to_string(SQRT(ana_env%displace%disp/ & REAL(ana_env%displace%conf_counter, KIND=dp))) - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (*, *) "TMC|ANALYSIS_AVERAGE_CELL_DISPLACEMENT_X= ", & - SQRT(ana_env%displace%disp/ & - REAL(ana_env%displace%conf_counter, KIND=dp)) - END IF + SQRT(ana_env%displace%disp/ & + REAL(ana_env%displace%conf_counter, KIND=dp)) END SUBROUTINE print_average_displacement END MODULE tmc_analysis diff --git a/src/tmc/tmc_analysis_types.F b/src/tmc/tmc_analysis_types.F index 49bd263e20..140aeeeb15 100644 --- a/src/tmc/tmc_analysis_types.F +++ b/src/tmc/tmc_analysis_types.F @@ -156,28 +156,22 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_ana)) - IF (ASSOCIATED(tmc_ana%dirs)) THEN + IF (ASSOCIATED(tmc_ana%dirs)) & DEALLOCATE (tmc_ana%dirs) - END IF - IF (ASSOCIATED(tmc_ana%density_3d)) THEN + IF (ASSOCIATED(tmc_ana%density_3d)) & CALL tmc_ana_dens_release(tmc_ana%density_3d) - END IF - IF (ASSOCIATED(tmc_ana%pair_correl)) THEN + IF (ASSOCIATED(tmc_ana%pair_correl)) & CALL tmc_ana_pair_correl_release(tmc_ana%pair_correl) - END IF - IF (ASSOCIATED(tmc_ana%dip_mom)) THEN + IF (ASSOCIATED(tmc_ana%dip_mom)) & CALL tmc_ana_dipole_moment_release(tmc_ana%dip_mom) - END IF - IF (ASSOCIATED(tmc_ana%dip_ana)) THEN + IF (ASSOCIATED(tmc_ana%dip_ana)) & CALL tmc_ana_dipole_analysis_release(tmc_ana%dip_ana) - END IF - IF (ASSOCIATED(tmc_ana%displace)) THEN + IF (ASSOCIATED(tmc_ana%displace)) & CALL tmc_ana_displacement_release(ana_disp=tmc_ana%displace) - END IF DEALLOCATE (tmc_ana) diff --git a/src/tmc/tmc_calculations.F b/src/tmc/tmc_calculations.F index cb0b3bba1b..e0d9a91e12 100644 --- a/src/tmc/tmc_calculations.F +++ b/src/tmc/tmc_calculations.F @@ -178,9 +178,8 @@ CONTAINS tmp_cell%hmat(:, 3) = tmp_cell%hmat(:, 3)*box_scale(3) CALL init_cell(cell=tmp_cell) - IF (PRESENT(scaled_hmat)) THEN + IF (PRESENT(scaled_hmat)) & scaled_hmat(:, :) = tmp_cell%hmat - END IF IF (PRESENT(vec)) THEN vec = pbc(r=vec, cell=tmp_cell) @@ -612,10 +611,9 @@ CONTAINS eff(:) = 0.0_dp DO i = 1, tmc_env%params%nr_temp - IF (tmc_env%m_env%tree_node_count(i) > 0) THEN + IF (tmc_env%m_env%tree_node_count(i) > 0) & eff(i) = tmc_env%params%move_types%mv_count(0, i)/ & (tmc_env%m_env%tree_node_count(i)*1.0_dp) - END IF eff(0) = eff(0) + tmc_env%params%move_types%mv_count(0, i)/ & (SUM(tmc_env%m_env%tree_node_count(1:))*1.0_dp) END DO diff --git a/src/tmc/tmc_cancelation.F b/src/tmc/tmc_cancelation.F index a0a5bf800a..086541c7ea 100644 --- a/src/tmc/tmc_cancelation.F +++ b/src/tmc/tmc_cancelation.F @@ -97,9 +97,8 @@ CONTAINS //cp_to_string(elem%stat)) END SELECT ! set dot color - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=elem, tmc_params=tmc_env%params) - END IF ! add to list IF (need_to_cancel) THEN diff --git a/src/tmc/tmc_dot_tree.F b/src/tmc/tmc_dot_tree.F index 936874ff42..b231aaa2af 100644 --- a/src/tmc/tmc_dot_tree.F +++ b/src/tmc/tmc_dot_tree.F @@ -339,11 +339,10 @@ CONTAINS END IF IF (.NOT. ASSOCIATED(new_element%parent)) THEN - IF (new_element%nr > 1) THEN + IF (new_element%nr > 1) & CALL cp_warn(__LOCATION__, & "try to create dot, but no parent on node "// & cp_to_string(new_element%nr)//"exists") - END IF ELSE CALL create_dot_branch(parent_nr=new_element%parent%nr, & child_nr=new_element%nr, & diff --git a/src/tmc/tmc_file_io.F b/src/tmc/tmc_file_io.F index 71053815d2..6aa7d1b0f0 100644 --- a/src/tmc/tmc_file_io.F +++ b/src/tmc/tmc_file_io.F @@ -301,11 +301,10 @@ CONTAINS CALL open_file(file_name=file_name, file_status="OLD", file_form="UNFORMATTED", & file_action="READ", unit_number=file_ptr) READ (file_ptr) temp_size - IF (temp_size /= SIZE(tmc_env%params%Temp)) THEN + IF (temp_size /= SIZE(tmc_env%params%Temp)) & CALL cp_abort(__LOCATION__, & "the actual specified temperatures does not "// & "fit in amount with the one from restart file ") - END IF ALLOCATE (tmp_temp(temp_size)) READ (file_ptr) tmp_temp(:), & tmc_env%m_env%gt_act%nr, & @@ -324,10 +323,9 @@ CONTAINS job_counts, & timings - IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) THEN + IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) & CALL cp_abort(__LOCATION__, "the temperatures differ from the previous calculation. "// & "There were the following temperatures used:") - END IF IF (ANY(mv_weight_tmp(:) /= tmc_env%params%move_types%mv_weight(:))) THEN CPWARN("The amount of mv types differs between the original and the restart run.") END IF @@ -724,14 +722,13 @@ CONTAINS ! write the different energies ! TODO if necessary - IF (files_conf_missmatch) THEN + IF (files_conf_missmatch) & CALL cp_warn(__LOCATION__, & 'there is a missmatch in the configuration numbering. '// & "Read number of lines (pos|cell|dip)"// & cp_to_string(tmc_ana%lc_traj)//"|"// & cp_to_string(tmc_ana%lc_cell)//"|"// & cp_to_string(tmc_ana%lc_dip)) - END IF ! end the timing CALL timestop(handle) @@ -772,22 +769,20 @@ CONTAINS c_tmp(:) = " " tmc_ana%lc_traj = tmc_ana%lc_traj + 1 READ (tmc_ana%id_traj, '(A)', IOSTAT=status) c_tmp(:) - IF (status > 0) THEN + IF (status > 0) & CALL cp_abort(__LOCATION__, & "configuration header read error at line: "// & cp_to_string(tmc_ana%lc_traj)//": "//c_tmp) - END IF IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK EXIT search_next_conf END IF IF (INDEX(c_tmp, "=") > 0) THEN READ (c_tmp(INDEX(c_tmp, "=") + 1:), *, IOSTAT=status) i_tmp ! read the configuration number - IF (status /= 0) THEN + IF (status /= 0) & CALL cp_abort(__LOCATION__, & "configuration header read error (for conf nr) at line: "// & cp_to_string(tmc_ana%lc_traj)) - END IF IF (i_tmp > conf_nr) THEN ! TODO we could also read the energy ... conf_nr = i_tmp @@ -919,9 +914,8 @@ CONTAINS IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE IF (status > 0) THEN - IF (status /= 0) THEN + IF (status /= 0) & CPABORT("configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell)) - END IF stat = TMC_STATUS_FAILED ELSE IF (elem%nr < 0) elem%nr = conf_nr diff --git a/src/tmc/tmc_master.F b/src/tmc/tmc_master.F index b93d15d0eb..20811cce10 100644 --- a/src/tmc/tmc_master.F +++ b/src/tmc/tmc_master.F @@ -135,10 +135,9 @@ CONTAINS CPASSERT(stat /= TMC_STATUS_FAILED) CPASSERT(work_list(wg)%elem%stat /= status_calc_approx_ener) - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: cancel group "//cp_to_string(wg) - END IF + "TMC|master: cancel group "//cp_to_string(wg) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=para_env, tmc_params=tmc_env%params) work_list(wg)%canceled = .TRUE. @@ -248,9 +247,8 @@ CONTAINS walltime_offset = 20 ! default value the whole program needs to finalize ! initialize the different modules - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL init_draw_trees(tmc_params=tmc_env%params) - END IF !-- initialize variables ! nr_of_job: counting the different task send / received @@ -286,11 +284,10 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_params=tmc_env%params, & elem=init_conf, success=flag, wait_for_message=.TRUE.) - IF (stat /= TMC_STAT_START_CONF_RESULT) THEN + IF (stat /= TMC_STAT_START_CONF_RESULT) & CALL cp_abort(__LOCATION__, & "receiving start configuration failed, received stat "// & cp_to_string(stat)) - END IF ! get the atom names from first energy worker CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & @@ -302,11 +299,10 @@ CONTAINS CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%move_types, & mol_array=init_conf%mol) - IF (ASSOCIATED(tmc_env%params%nmc_move_types)) THEN + IF (ASSOCIATED(tmc_env%params%nmc_move_types)) & CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%nmc_move_types, & mol_array=init_conf%mol) - END IF ! set initial configuration ! set initial random number generator seed (rng seed) @@ -352,17 +348,15 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=init_conf) ! regtest output - IF (tmc_env%params%print_test_output .OR. DEBUG > 0) THEN + IF (tmc_env%params%print_test_output .OR. DEBUG > 0) & WRITE (tmc_env%m_env%io_unit, *) "TMC|first_global_tree_rnd_nr_X= ", & - tmc_env%m_env%gt_head%rnd_nr - END IF + tmc_env%m_env%gt_head%rnd_nr ! calculate the approx energy of the first element (later the exact) IF (tmc_env%m_env%gt_head%conf(1)%elem%stat == status_calc_approx_ener) THEN wg = 1 - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & wg = tmc_env%tmc_comp_set%group_ener_nr + 1 - END IF stat = TMC_STAT_APPROX_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -397,30 +391,27 @@ CONTAINS IF (flag .EQV. .FALSE.) EXIT worker_request_loop ! messages from worker group could be faster then the canceling request IF (worker_info(wg)%canceled .AND. (stat /= TMC_CANCELING_RECEIPT)) THEN - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: recv stat "//cp_to_string(stat)// & - " of canceled worker group" - END IF + "TMC|master: recv stat "//cp_to_string(stat)// & + " of canceled worker group" CYCLE worker_request_loop END IF ! in case of parallel tempering canceled element could be reactivated, ! calculated faster and deleted - IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) THEN + IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) & CALL cp_abort(__LOCATION__, & "no tree elem exist when receiving stat "// & cp_to_string(stat)//"of group"//cp_to_string(wg)) - END IF - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: received stat "//cp_to_string(stat)// & - " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & - " elem"//cp_to_string(worker_info(wg)%elem%nr)// & - " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & - " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled - END IF + "TMC|master: received stat "//cp_to_string(stat)// & + " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & + " elem"//cp_to_string(worker_info(wg)%elem%nr)// & + " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & + " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled SELECT CASE (stat) ! -- FAILED -------------------------- CASE (TMC_STATUS_FAILED) @@ -548,9 +539,8 @@ CONTAINS worker_info(wg)%start_time = m_walltime() - worker_info(wg)%start_time CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay) - IF (.NOT. worker_info(wg)%canceled) THEN + IF (.NOT. worker_info(wg)%canceled) & worker_info(wg)%busy = .FALSE. - END IF ! the first node in tree is always accepted.!. IF (ASSOCIATED(worker_info(wg)%elem, init_conf)) THEN !-- distribute energy of first element to all subtrees @@ -565,10 +555,9 @@ CONTAINS init_conf => NULL() ELSE worker_info(wg)%elem%stat = status_calculated - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(worker_info(wg)%elem, & tmc_params=tmc_env%params) - END IF ! check acceptance of depending nodes ! first (initial) configuration do not have to be checked CALL check_acceptance_of_depending_subtree_nodes(tree_elem=worker_info(wg)%elem, & @@ -589,12 +578,11 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & cancel_count=cancel_count) - IF (DEBUG >= 9) THEN + IF (DEBUG >= 9) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: handled energy result of sub tree ", & - worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & - " with stat", worker_info(wg)%elem%stat - END IF + "TMC|master: handled energy result of sub tree ", & + worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & + " with stat", worker_info(wg)%elem%stat worker_info(wg)%elem => NULL() !-- SCF ENERGY ----------------------- @@ -622,12 +610,11 @@ CONTAINS !-- do tree update (check new results) CALL tree_update(tmc_env=tmc_env, result_acc=flag, & something_updated=l_update_tree) - IF (DEBUG >= 2 .AND. l_update_tree) THEN + IF (DEBUG >= 2 .AND. l_update_tree) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: tree updated "//cp_to_string(l_update_tree)// & - " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & - " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) - END IF + "TMC|master: tree updated "//cp_to_string(l_update_tree)// & + " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & + " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) CALL send_analysis_tasks(ana_list=tmc_env%m_env%analysis_list, & ana_worker_info=ana_worker_info, & @@ -655,15 +642,13 @@ CONTAINS "(incl. delay", walltime_delay, "and offset", walltime_offset, ") left" ELSE ! calculations finished - IF (tmc_env%params%print_test_output) THEN + IF (tmc_env%params%print_test_output) & WRITE (tmc_env%m_env%io_unit, *) "Total energy: ", & - tmc_env%m_env%result_list(1)%elem%potential - END IF + tmc_env%m_env%result_list(1)%elem%potential END IF - IF (tmc_env%m_env%restart_out_step /= 0) THEN + IF (tmc_env%m_env%restart_out_step /= 0) & CALL print_restart_file(tmc_env=tmc_env, job_counts=nr_of_job, & timings=worker_timings_aver) - END IF EXIT task_loop END IF @@ -671,10 +656,9 @@ CONTAINS ! update the rest of the tree (canceling and deleting elements) ! ======================================================================= IF (l_update_tree) THEN - IF (DEBUG >= 2) THEN + IF (DEBUG >= 2) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: start remove elem and cancel calculation" - END IF + "TMC|master: start remove elem and cancel calculation" !-- CLEANING tree nodes beside the path through the tree from ! end_of_clean_tree to tree_ptr ! --> getting back the end of clean tree @@ -696,15 +680,13 @@ CONTAINS worker_counter = worker_counter + 1 wg = MODULO(worker_counter, tmc_env%tmc_comp_set%para_env_m_w%num_pe - 1) + 1 - IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) THEN + IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) & WRITE (tmc_env%m_env%io_unit, *) "all workers are busy" - END IF IF (.NOT. worker_info(wg)%busy) THEN - IF (DEBUG >= 13) THEN + IF (DEBUG >= 13) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: search new task for worker ", wg - END IF + "TMC|master: search new task for worker ", wg ! no group separation IF (tmc_env%tmc_comp_set%group_cc_nr <= 0) THEN ! search next element to calculate the energy @@ -716,7 +698,7 @@ CONTAINS new_elem=gt_elem_tmp, & reactivation_cc_count=reactivation_cc_count) END IF - ELSE IF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN + ELSEIF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN ! specialized groups (groups for exact energy and groups for configurational change) ! creating new element (configurational change group) !-- crate new node, configurational change is handled in tmc_tree module @@ -725,9 +707,8 @@ CONTAINS reactivation_cc_count=reactivation_cc_count) ! element could be already created, hence CC worker has nothing to do for this element ! in next round he will get a task - IF (stat == status_created .OR. stat == status_calculate_energy) THEN + IF (stat == status_created .OR. stat == status_calculate_energy) & stat = TMC_STATUS_WAIT_FOR_NEW_TASK - END IF ELSE ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & @@ -735,11 +716,10 @@ CONTAINS react_count=reactivation_ener_count) END IF - IF (DEBUG >= 10) THEN + IF (DEBUG >= 10) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: send task with elem stat "//cp_to_string(stat)// & - " to group "//cp_to_string(wg) - END IF + "TMC|master: send task with elem stat "//cp_to_string(stat)// & + " to group "//cp_to_string(wg) ! MESSAGE settings: status informations and task for communication SELECT CASE (stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -761,10 +741,9 @@ CONTAINS ! in case of parallel tempering the node can be already be calculating (related to another global tree node !-- send task to calculate system property gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem%stat = status_calculate_energy - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF stat = TMC_STAT_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -830,30 +809,27 @@ CONTAINS WRITE (tmc_env%m_env%io_unit, FMT=*) & "ener prepared ", tree_elem_counters END IF - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & WRITE (tmc_env%m_env%io_unit, *) & - "canceled cc|E: ", nr_of_job(5:6), & - ", reactivated: cc ", & - reactivation_cc_count, & - ", reactivated: E ", & - reactivation_ener_count - END IF + "canceled cc|E: ", nr_of_job(5:6), & + ", reactivated: cc ", & + reactivation_cc_count, & + ", reactivated: E ", & + reactivation_ener_count WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & " Average time for cc/ener calc ", & worker_timings_aver(1), worker_timings_aver(2) - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & - " Average time until cancel cc/ener calc ", & - worker_timings_aver(3), worker_timings_aver(4) - END IF - IF (tmc_env%params%esimate_acc_prob) THEN + " Average time until cancel cc/ener calc ", & + worker_timings_aver(3), worker_timings_aver(4) + IF (tmc_env%params%esimate_acc_prob) & WRITE (tmc_env%m_env%io_unit, *) & - "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & - tmc_env%m_env%estim_corr_wrong(1), & - tmc_env%m_env%estim_corr_wrong(3), " | ", & - tmc_env%m_env%estim_corr_wrong(2), & - tmc_env%m_env%estim_corr_wrong(4) - END IF + "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & + tmc_env%m_env%estim_corr_wrong(1), & + tmc_env%m_env%estim_corr_wrong(3), " | ", & + tmc_env%m_env%estim_corr_wrong(2), & + tmc_env%m_env%estim_corr_wrong(4) WRITE (tmc_env%m_env%io_unit, *) & "Time: ", INT(m_walltime() - run_time_start), "of", & INT(tmc_env%m_env%walltime - walltime_delay - walltime_offset), & @@ -893,11 +869,10 @@ CONTAINS " (MC elements/calculated configuration) global:", & efficiency(0), " sub tree(s): ", efficiency(1:) DEALLOCATE (efficiency) - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & - " (MC elements/created configuration) :", & - tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) - END IF + " (MC elements/created configuration) :", & + tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & " (MC elements/energy calculated configuration):", & tmc_env%m_env%result_count(:)/REAL(nr_of_job(4), KIND=dp) @@ -934,9 +909,8 @@ CONTAINS CALL free_cancelation_list(tmc_env%m_env%cancelation_list) ! -- write final configuration - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL finalize_draw_tree(tmc_params=tmc_env%params) - END IF WRITE (tmc_env%m_env%io_unit, *) "TMC master: all work done." diff --git a/src/tmc/tmc_messages.F b/src/tmc/tmc_messages.F index 26ae8e290c..82b36f4bdb 100644 --- a/src/tmc/tmc_messages.F +++ b/src/tmc/tmc_messages.F @@ -88,9 +88,8 @@ CONTAINS CPASSERT(ASSOCIATED(para_env)) master = .FALSE. - IF (para_env%mepos == MASTER_COMM_ID) THEN + IF (para_env%mepos == MASTER_COMM_ID) & master = .TRUE. - END IF END FUNCTION check_if_group_master ! ************************************************************************************************** @@ -212,12 +211,11 @@ CONTAINS CPABORT("Unable to send message when m_send%info(4) > 0") !TODO send characters CALL para_env%send(m_send%task_char, dest, message_tag) END IF - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " send element info to ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:), " with comm ", & - para_env%get_handle(), " and tag ", message_tag - END IF + " send element info to ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:), " with comm ", & + para_env%get_handle(), " and tag ", message_tag IF (m_send%info(2) > 0) DEALLOCATE (m_send%task_int) IF (m_send%info(3) > 0) DEALLOCATE (m_send%task_real) IF (m_send%info(4) > 0) DEALLOCATE (m_send%task_char) @@ -292,11 +290,10 @@ CONTAINS ! first get message type and sizes CALL para_env%recv(m_send%info, dest, message_tag) END IF - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " recv element info from ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:) - END IF + " recv element info from ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:) !-- receive message integer part IF (m_send%info(2) > 0) THEN ALLOCATE (m_send%task_int(m_send%info(2))) @@ -353,16 +350,14 @@ CONTAINS CASE (TMC_STAT_ENERGY_REQUEST, TMC_STAT_APPROX_ENERGY_REQUEST) CALL read_energy_request_message(elem, m_send, tmc_params) CASE (TMC_STAT_ENERGY_RESULT) - IF (PRESENT(elem_array)) THEN + IF (PRESENT(elem_array)) & CALL read_energy_result_message(elem_array(dest)%elem, m_send, tmc_params) - END IF CASE (TMC_STAT_NMC_REQUEST, TMC_STAT_NMC_BROADCAST, & TMC_STAT_MD_REQUEST, TMC_STAT_MD_BROADCAST) CALL read_NMC_request_massage(msg_type, elem, m_send, tmc_params) CASE (TMC_STAT_NMC_RESULT, TMC_STAT_MD_RESULT) - IF (PRESENT(elem_array)) THEN + IF (PRESENT(elem_array)) & CALL read_NMC_result_massage(msg_type, elem_array(dest)%elem, m_send, tmc_params) - END IF CASE (TMC_STATUS_FAILED, TMC_STATUS_STOP_RECEIPT) ! if task is failed, handle situation in outer routine CASE (TMC_STAT_SCF_STEP_ENER_RECEIVE) @@ -1080,9 +1075,8 @@ CONTAINS counter = 0 !then float array with pos, (vel), random number seed, subbox_center msg_size_real = 1 + SIZE(elem%pos) + 1 + SIZE(elem%rng_seed) + 1 + SIZE(elem%subbox_center(:)) + 1 - IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) THEN - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) - END IF ! the velocities + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) & + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) ! the velocities IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ! box size for NpT ALLOCATE (m_send%task_real(msg_size_real)) @@ -1220,10 +1214,9 @@ CONTAINS + 1 + SIZE(tmc_params%nmc_move_types%mv_count) & + 1 + SIZE(tmc_params%nmc_move_types%acc_count) + 1 IF (DEBUG > 0) msg_size_int = msg_size_int + 1 + 1 + 1 + 1 - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & msg_size_int = msg_size_int + 1 + SIZE(tmc_params%nmc_move_types%subbox_count) & + 1 + SIZE(tmc_params%nmc_move_types%subbox_acc_count) - END IF ALLOCATE (m_send%task_int(msg_size_int)) counter = 1 @@ -1277,9 +1270,8 @@ CONTAINS + 1 ! check bit IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & - msg_type == TMC_STAT_MD_BROADCAST) THEN - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 - END IF ! for MD also: vel, e_kin_befor_md, ekin + msg_type == TMC_STAT_MD_BROADCAST) & + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 ! for MD also: vel, e_kin_befor_md, ekin ALLOCATE (m_send%task_real(msg_size_real)) ! pos @@ -1408,9 +1400,8 @@ CONTAINS msg_type == TMC_STAT_MD_BROADCAST) THEN elem%vel = m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) - IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) THEN + IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) & elem%ekin_before_md = m_send%task_real(counter + 1) - END IF counter = counter + 2 elem%ekin = m_send%task_real(counter + 1) counter = counter + 2 @@ -1424,9 +1415,8 @@ CONTAINS END IF DEALLOCATE (mv_counter, acc_counter) - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & DEALLOCATE (subbox_counter, subbox_acc_counter) - END IF CPASSERT(counter == m_send%info(3)) CPASSERT(m_send%task_int(m_send%info(2)) == message_end_flag) CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) @@ -1574,7 +1564,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_string_length), & - ALLOCATABLE, DIMENSION(:) :: msg + ALLOCATABLE, DIMENSION(:) :: msg(:) INTEGER :: i CPASSERT(ASSOCIATED(para_env)) diff --git a/src/tmc/tmc_move_handle.F b/src/tmc/tmc_move_handle.F index cfa8ab5b31..6354703e49 100644 --- a/src/tmc/tmc_move_handle.F +++ b/src/tmc/tmc_move_handle.F @@ -114,25 +114,22 @@ CONTAINS CALL section_vals_get(nmc_section, explicit=explicit) IF (explicit) THEN ! check the approx potential file, already read - IF (tmc_params%NMC_inp_file == "") THEN + IF (tmc_params%NMC_inp_file == "") & CPABORT("Please specify a valid approximate potential.") - END IF CALL section_vals_val_get(nmc_section, "NR_NMC_STEPS", & i_val=nmc_steps) - IF (nmc_steps <= 0) THEN + IF (nmc_steps <= 0) & CPABORT("Please specify a valid amount of NMC steps (NR_NMC_STEPS {INTEGER}).") - END IF CALL section_vals_val_get(nmc_section, "PROB", r_val=nmc_prob) CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", & r_val=nmc_init_acc_prob) - IF (nmc_init_acc_prob <= 0.0_dp) THEN + IF (nmc_init_acc_prob <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for INIT_ACC_PROB") - END IF move_type_section => section_vals_get_subs_vals(nmc_section, "MOVE_TYPE") CALL section_vals_get(move_type_section, n_repetition=n_NMC_items) @@ -153,11 +150,10 @@ CONTAINS ! initilaize the move array with related sizes, probs, etc. CALL move_types_create(tmc_params%move_types, tmc_params%nr_temp) - IF (mv_prob_sum <= 0.0) THEN + IF (mv_prob_sum <= 0.0) & CALL cp_abort(__LOCATION__, & "The probabilities to perform the moves are "// & "in total less equal 0") - END IF ! get the sizes, probs, etc. for each move type and convert units DO i_tmp = 1, n_items + n_NMC_items @@ -192,18 +188,16 @@ CONTAINS ! move sizes are checked afterwards, because not all moves require a valid move size CALL section_vals_val_get(move_type_section, "PROB", i_rep_section=i_rep, & r_val=mv_prob) - IF (mv_prob < 0.0_dp) THEN + IF (mv_prob < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid move probability (>0.0) "// & "for the move type "//inp_kind_name) - END IF CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", i_rep_section=i_rep, & r_val=init_acc_prob) - IF (init_acc_prob < 0.0_dp) THEN + IF (init_acc_prob < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for the move type "//inp_kind_name) - END IF ! set the related index and perform unit conversion of move sizes SELECT CASE (inp_kind_name) ! atom / molecule translation @@ -284,9 +278,8 @@ CONTAINS CALL section_vals_val_get(move_type_section, "ATOMS", & i_rep_section=i_rep, i_rep_val=i, & c_vals=move_types%atom_lists(i)%atoms) - IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) THEN + IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) & CPABORT("ATOM_SWAP requires minimum two atom kinds selected. ") - END IF END DO END IF ! gaussian adaptation @@ -297,11 +290,10 @@ CONTAINS CPABORT("A unknown move type is selected: "//inp_kind_name) END SELECT ! check for valid move sizes - IF (delta_x < 0.0_dp) THEN + IF (delta_x < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid move size (>0.0) "// & "for the move type "//inp_kind_name) - END IF ! check if not already set IF (move_types%mv_weight(ind) > 0.0) THEN CPABORT("TMC: Each move type can be set only once. ") @@ -349,12 +341,11 @@ CONTAINS move_types%mv_weight(mv_type_mol_rot) > 0.0_dp) THEN ! if there is no molecule information available, ! molecules moves can not be performed - IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) THEN + IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) & CALL cp_abort(__LOCATION__, & "molecule move: there is no molecule "// & "information available. Please specify molecules when "// & "using molecule moves.") - END IF END IF ! for the atom swap move @@ -372,12 +363,11 @@ CONTAINS EXIT ref_loop END IF END DO ref_loop - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "ATOM_SWAP: The selected atom type ("// & TRIM(move_types%atom_lists(list_i)%atoms(atom_j))// & ") is not contained in the system. ") - END IF ! check if not be swapped with the same atom type IF (ANY(move_types%atom_lists(list_i)%atoms(atom_j) == & move_types%atom_lists(list_i)%atoms(atom_j + 1:))) THEN @@ -399,11 +389,10 @@ CONTAINS END IF END DO ref_lop END IF - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "The system contains only a single atom type,"// & " atom_swap is not possible.") - END IF END IF END IF END SUBROUTINE check_moves @@ -419,9 +408,8 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_params)) CALL move_types_release(tmc_params%move_types) - IF (ASSOCIATED(tmc_params%nmc_move_types)) THEN + IF (ASSOCIATED(tmc_params%nmc_move_types)) & CALL move_types_release(tmc_params%nmc_move_types) - END IF END SUBROUTINE finalize_mv_types ! ************************************************************************************************** @@ -772,9 +760,8 @@ CONTAINS CPASSERT(PRESENT(acc)) IF (PRESENT(subbox)) THEN ! only update subbox acceptance - IF (acc) THEN + IF (acc) & move_types%subbox_acc_count(mv_type, conf_moved) = move_types%subbox_acc_count(mv_type, conf_moved) + 1 - END IF move_types%subbox_count(mv_type, conf_moved) = move_types%subbox_count(mv_type, conf_moved) + 1 ! No more to do change_type = 0 @@ -803,9 +790,8 @@ CONTAINS END IF IF (conf_moved > 0) move_types%mv_count(0, conf_moved) = move_types%mv_count(0, conf_moved) + ABS(change_res) - IF (mv_type >= 0 .AND. conf_moved > 0) THEN + IF (mv_type >= 0 .AND. conf_moved > 0) & move_types%mv_count(mv_type, conf_moved) = move_types%mv_count(mv_type, conf_moved) + ABS(change_type) - END IF IF (prob_opt) THEN WHERE (move_types%mv_count > 0) & diff --git a/src/tmc/tmc_moves.F b/src/tmc/tmc_moves.F index a6e1aec153..3f24f4def5 100644 --- a/src/tmc/tmc_moves.F +++ b/src/tmc/tmc_moves.F @@ -124,9 +124,8 @@ CONTAINS ! rng_seed=elem%rng_seed, rng_seed_last_acc=last_acc_elem%rng_seed) !-- atom translation CASE (mv_type_atom_trans) - IF (act_nr_elem_mv == 0) THEN + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = SIZE(elem%pos)/tmc_params%dim_per_elem - END IF ALLOCATE (elem_center(tmc_params%dim_per_elem)) i = 1 move_elements_loop: DO @@ -168,9 +167,8 @@ CONTAINS CASE (mv_type_mol_trans) nr_molec = MAXVAL(elem%mol(:)) ! if all particles should be displaced, set the amount of molecules - IF (act_nr_elem_mv == 0) THEN + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = nr_molec - END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -183,9 +181,8 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) THEN + ) & mol_in_sb(m) = status_ok - END IF END DO ! displace the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -245,9 +242,8 @@ CONTAINS !-- molecule rotation CASE (mv_type_mol_rot) nr_molec = MAXVAL(elem%mol(:)) - IF (act_nr_elem_mv == 0) THEN + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = nr_molec - END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -260,9 +256,8 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) THEN + ) & mol_in_sb(m) = status_ok - END IF END DO ! rotate the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -708,18 +703,16 @@ CONTAINS CALL find_nearest_proton_acceptor_donator(elem=elem, mol=mol, & donor_acceptor=donor_acceptor, tmc_params=tmc_params, & rng_stream=rng_stream) - IF (ANY(mol_arr(:) == mol)) THEN + IF (ANY(mol_arr(:) == mol)) & EXIT chain_completition_loop - END IF mol_arr(counter) = mol END DO chain_completition_loop counter = counter - 1 ! last searched element is equal to one other in list ! just take the loop of molecules out of the chain DO k = 1, counter - IF (mol_arr(k) == mol) THEN + IF (mol_arr(k) == mol) & EXIT - END IF END DO mol_arr(1:counter - k + 1) = mol_arr(k:counter) counter = counter - k + 1 diff --git a/src/tmc/tmc_setup.F b/src/tmc/tmc_setup.F index f110e1c573..5c6ec41642 100644 --- a/src/tmc/tmc_setup.F +++ b/src/tmc/tmc_setup.F @@ -239,9 +239,8 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_energy_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CPABORT("creating force env result in error "//cp_to_string(ierr)) - END IF END IF ! worker for configurational change IF (tmc_env%params%NMC_inp_file /= "" .AND. & @@ -254,18 +253,15 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_NMC_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CPABORT("creating approx force env result in error "//cp_to_string(ierr)) - END IF END IF CALL do_tmc_worker(tmc_env=tmc_env) ! start the worker routine - IF (tmc_env%w_env%env_id_ener > 0) THEN + IF (tmc_env%w_env%env_id_ener > 0) & CALL destroy_force_env(tmc_env%w_env%env_id_ener, ierr) - END IF - IF (tmc_env%w_env%env_id_approx > 0) THEN + IF (tmc_env%w_env%env_id_approx > 0) & CALL destroy_force_env(tmc_env%w_env%env_id_approx, ierr) - END IF CALL cp_rm_default_logger() CALL cp_logger_release(logger_sub) @@ -300,9 +296,8 @@ CONTAINS END DO CALL do_tmc_worker(tmc_env=tmc_env, ana_list=tmc_ana_env_list) ! start the worker routine for analysis DO i = 1, tmc_env%params%nr_temp - IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) THEN + IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=tmc_ana_env_list(i)%temp%last_elem) - END IF CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp) END DO DEALLOCATE (tmc_ana_env_list) @@ -406,19 +401,16 @@ CONTAINS CALL analysis_init(ana_env=ana_list(temp)%temp, nr_dim=nr_dim) ! to allocate the dipole array in tree elements IF (ana_list(temp)%temp%costum_dip_file_name /= & - tmc_default_unspecified_name) THEN + tmc_default_unspecified_name) & tmc_env%params%print_dipole = .TRUE. - END IF - IF (.NOT. ASSOCIATED(elem)) THEN + IF (.NOT. ASSOCIATED(elem)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=elem, nr_dim=nr_dim) - END IF CALL analysis_restart_read(ana_env=ana_list(temp)%temp, & elem=elem) - IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) & CPABORT("uncorrect initialization of the initial configuration") - END IF ! do for all directories DO dir_ind = 1, SIZE(ana_list(temp)%temp%dirs) WRITE (output_unit, FMT='(T2,A,"| ",A,T41,A40)') "TMC_ANA", & @@ -432,31 +424,25 @@ CONTAINS ! remove the last saved element to start with a new file ! there is no weight for this element IF (dir_ind < SIZE(ana_list(temp)%temp%dirs) .AND. & - ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & ana_list(temp)%temp%conf_offset = ana_list(temp)%temp%conf_offset & + ana_list(temp)%temp%last_elem%nr - END IF END DO CALL finalize_tmc_analysis(ana_env=ana_list(temp)%temp) ! write analysis restart file ! if there is something to write ! shifts the last element to actual element - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL analysis_restart_print(ana_env=ana_list(temp)%temp) - END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - END IF - IF (ASSOCIATED(elem)) THEN + IF (ASSOCIATED(elem)) & CALL deallocate_sub_tree_node(tree_elem=elem) - END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - END IF CALL tmc_ana_env_release(ana_list(temp)%temp) END DO @@ -513,9 +499,8 @@ CONTAINS CALL section_vals_val_get(tmc_section, "NR_TEMPERATURE", i_val=nr_temp) CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) THEN + IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) & CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") - END IF IF (nr_temp == 1) THEN nr_temp = SIZE(inp_Temp) ALLOCATE (Temps(nr_temp)) @@ -528,10 +513,9 @@ CONTAINS DO t_act = 2, SIZE(Temps) Temps(t_act) = Temps(t_act - 1) + (tmax - tmin)/(SIZE(Temps) - 1.0_dp) END DO - IF (ANY(Temps < 0.0_dp)) THEN + IF (ANY(Temps < 0.0_dp)) & CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") - END IF END IF ! get multiple directories @@ -612,15 +596,13 @@ CONTAINS CALL section_vals_val_get(tmc_section, "GROUP_ENERGY_NR", i_val=tmc_env%tmc_comp_set%group_ener_nr) CALL section_vals_val_get(tmc_section, "GROUP_CC_SIZE", i_val=tmc_env%tmc_comp_set%group_cc_size) CALL section_vals_val_get(tmc_section, "GROUP_ANALYSIS_NR", i_val=itmp) - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) THEN + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) & tmc_env%tmc_comp_set%ana_on_the_fly = itmp - END IF - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) THEN + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) & CALL cp_abort(__LOCATION__, & "analysing on the fly is up to now not supported for multiple cores. "// & "Restart file witing for this case and temperature "// & "distribution has to be solved.!.") - END IF CALL section_vals_val_get(tmc_section, "RESULT_LIST_IN_MEMORY", l_val=tmc_env%params%USE_REDUCED_TREE) ! swap the variable, because of oposit meaning tmc_env%params%USE_REDUCED_TREE = .NOT. tmc_env%params%USE_REDUCED_TREE @@ -633,24 +615,21 @@ CONTAINS CPABORT("no or a valid NMC input file has to be specified ") ELSE IF (tmc_env%params%NMC_inp_file == "") THEN ! no keyword - IF (tmc_env%tmc_comp_set%group_cc_size > 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_size > 0) & CALL cp_warn(__LOCATION__, & "The configurational groups are deactivated, "// & "because no approximated energy input is specified.") - END IF tmc_env%tmc_comp_set%group_cc_size = 0 ELSE ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%NMC_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) THEN + IF (.NOT. flag .OR. itmp /= 0) & CPABORT("a valid NMC input file has to be specified") - END IF END IF CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) THEN + IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) & CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") - END IF IF (tmc_env%params%nr_temp == 1) THEN tmc_env%params%nr_temp = SIZE(inp_Temp) ALLOCATE (tmc_env%params%Temp(tmc_env%params%nr_temp)) @@ -663,10 +642,9 @@ CONTAINS DO itmp = 2, SIZE(tmc_env%params%Temp) tmc_env%params%Temp(itmp) = tmc_env%params%Temp(itmp - 1) + (tmax - tmin)/(SIZE(tmc_env%params%Temp) - 1.0_dp) END DO - IF (ANY(tmc_env%params%Temp < 0.0_dp)) THEN + IF (ANY(tmc_env%params%Temp < 0.0_dp)) & CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") - END IF END IF CALL section_vals_val_get(tmc_section, "TASK_TYPE", explicit=explicit_key) @@ -733,14 +711,13 @@ CONTAINS tmc_env%m_env%restart_out_file_name = tmc_default_restart_out_file_name tmc_env%m_env%restart_out_step = HUGE(tmc_env%m_env%restart_out_step) END IF - IF (tmc_env%m_env%restart_out_step < 0) THEN + IF (tmc_env%m_env%restart_out_step < 0) & CALL cp_abort(__LOCATION__, & "Please specify a valid value for the frequency "// & "to write restart files (RESTART_OUT #). "// & "# > 0 to define the amount of Markov chain elements in between, "// & "or 0 to deactivate the restart file writing. "// & "Lonely keyword writes restart file only at the end of the run.") - END IF CALL section_vals_val_get(tmc_section, "INFO_OUT_STEP_SIZE", i_val=tmc_env%m_env%info_out_step_size) CALL section_vals_val_get(tmc_section, "DOT_TREE", c_val=tmc_env%params%dot_file_name) @@ -757,15 +734,13 @@ CONTAINS ! the NMC_FILE_NAME is already read in tmc_preread_input CALL section_vals_val_get(tmc_section, "ENERGY_FILE_NAME", c_val=tmc_env%params%energy_inp_file) ! file name keyword without file name - IF (tmc_env%params%energy_inp_file == "") THEN + IF (tmc_env%params%energy_inp_file == "") & CPABORT("a valid exact energy input file has to be specified ") - END IF ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%energy_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) THEN + IF (.NOT. flag .OR. itmp /= 0) & CALL cp_abort(__LOCATION__, "a valid exact energy input file has to be specified, "// & TRIM(tmc_env%params%energy_inp_file)//" does not exist.") - END IF CALL section_vals_val_get(tmc_section, "NUM_MV_ELEM_IN_CELL", i_val=tmc_env%params%nr_elem_mv) @@ -776,12 +751,10 @@ CONTAINS CALL section_vals_val_get(tmc_section, "SUB_BOX", r_vals=r_arr_tmp) IF (SIZE(r_arr_tmp) > 1) THEN - IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) THEN + IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) & CPABORT("The entered sub box sizes does not fit in number of dimensions.") - END IF - IF (ANY(r_arr_tmp <= 0.0_dp)) THEN + IF (ANY(r_arr_tmp <= 0.0_dp)) & CPABORT("The entered sub box lengths should be greater than 0.") - END IF DO itmp = 1, SIZE(tmc_env%params%sub_box_size) tmc_env%params%sub_box_size(itmp) = r_arr_tmp(itmp)/au2a END DO @@ -801,17 +774,14 @@ CONTAINS CALL section_vals_val_get(tmc_section, "PRINT_ONLY_ACC", l_val=tmc_env%params%print_only_diff_conf) CALL section_vals_val_get(tmc_section, "PRINT_COORDS", l_val=tmc_env%params%print_trajectory) CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", l_val=tmc_env%params%print_dipole) - END IF CALL section_vals_val_get(tmc_section, "PRINT_FORCES", explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL section_vals_val_get(tmc_section, "PRINT_FORCES", l_val=tmc_env%params%print_forces) - END IF CALL section_vals_val_get(tmc_section, "PRINT_CELL", explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL section_vals_val_get(tmc_section, "PRINT_CELL", l_val=tmc_env%params%print_cell) - END IF CALL section_vals_val_get(tmc_section, "PRINT_ENERGIES", l_val=tmc_env%params%print_energies) END SUBROUTINE tmc_read_input @@ -880,10 +850,9 @@ CONTAINS - tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr)/ & REAL(tmc_comp_set%group_cc_size, KIND=dp)) - IF (tmc_comp_set%group_cc_nr < 1) THEN + IF (tmc_comp_set%group_cc_nr < 1) & CALL cp_warn(__LOCATION__, & "There are not enougth cores left for creating groups for configurational change.") - END IF IF (flag) success = .FALSE. END IF @@ -1041,10 +1010,9 @@ CONTAINS WRITE (file_nr, FMT=fmt_my) plabel, "cores per group (ener|cc) ", & cp_to_string(tmc_env%tmc_comp_set%group_ener_size)//" | "// & cp_to_string(tmc_env%tmc_comp_set%group_cc_size) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & WRITE (file_nr, FMT=fmt_my) plabel, "Analysis groups ", & - cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) - END IF + cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) IF (SIZE(tmc_env%params%Temp(:)) <= 7) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" @@ -1058,20 +1026,18 @@ CONTAINS cp_to_string(tmc_env%m_env%num_MC_elem) WRITE (file_nr, FMT=fmt_my) plabel, "exact potential input file:", & TRIM(tmc_env%params%energy_inp_file) - IF (tmc_env%params%NMC_inp_file /= "") THEN + IF (tmc_env%params%NMC_inp_file /= "") & WRITE (file_nr, FMT=fmt_my) plabel, "approximate potential input file:", & - TRIM(tmc_env%params%NMC_inp_file) - END IF + TRIM(tmc_env%params%NMC_inp_file) IF (ANY(tmc_env%params%sub_box_size > 0.0_dp)) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" WRITE (c_tmp, FMT="(1000F8.2)") tmc_env%params%sub_box_size(:)*au2a WRITE (file_nr, FMT=fmt_tmp) plabel, "Sub box size [A]", TRIM(c_tmp) END IF - IF (tmc_env%params%pressure > 0.0_dp) THEN + IF (tmc_env%params%pressure > 0.0_dp) & WRITE (file_nr, FMT=fmt_my) plabel, "Pressure [bar]: ", & - cp_to_string(tmc_env%params%pressure*au2bar) - END IF + cp_to_string(tmc_env%params%pressure*au2bar) WRITE (file_nr, FMT=fmt_my) plabel, "Numbers of atoms/molecules moved " WRITE (file_nr, FMT=fmt_my) plabel, " within one conf. change", & cp_to_string(tmc_env%params%nr_elem_mv) diff --git a/src/tmc/tmc_tree_acceptance.F b/src/tmc/tmc_tree_acceptance.F index 8a72ab56e6..939f31563c 100644 --- a/src/tmc/tmc_tree_acceptance.F +++ b/src/tmc/tmc_tree_acceptance.F @@ -490,10 +490,9 @@ CONTAINS END IF END IF - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot_color(gt_tree_element=tmp_gt_list_ptr%gt_elem, & tmc_params=tmc_env%params) - END IF END IF tmp_gt_list_ptr => tmp_gt_list_ptr%next END DO @@ -547,9 +546,8 @@ CONTAINS cp_to_string(stat)) END SELECT - IF (tmc_params%DRAW_TREE) THEN + IF (tmc_params%DRAW_TREE) & CALL create_dot_color(tree_element=ptr, tmc_params=tmc_params) - END IF END IF ! end the timing @@ -687,9 +685,8 @@ CONTAINS !-- hence new configurations can be created on basis of this configuration CASE (status_calculate_MD, status_calculate_NMC_steps, status_calculate_energy, & status_created, status_calc_approx_ener) - IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) THEN + IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) & gt_act_elem%stat = gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat - END IF CASE (status_calculated) CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -757,10 +754,9 @@ CONTAINS tmc_env%m_env%result_count(gt_act_elem%mv_conf) + 1 ! in case of swapped also count the result for ! the other swapped temperature - IF (gt_act_elem%swaped) THEN + IF (gt_act_elem%swaped) & tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) = & - tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 - END IF + tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 ! count also for global tree Markov Chain tmc_env%m_env%result_count(0) = tmc_env%m_env%result_count(0) + 1 @@ -820,16 +816,14 @@ CONTAINS END IF ! result acceptance check !====================================================================== !-- set status accepted or rejected of certain subtree elements - IF (.NOT. gt_act_elem%swaped) THEN + IF (.NOT. gt_act_elem%swaped) & CALL subtree_configuration_stat_change(gt_ptr=gt_act_elem, & stat=gt_act_elem%stat, & tmc_params=tmc_env%params) - END IF - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot_color(gt_tree_element=gt_act_elem, & tmc_params=tmc_env%params) - END IF ! probability update CALL prob_update(move_types=tmc_env%params%move_types, & @@ -841,12 +835,11 @@ CONTAINS result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf, accepted=result_acc, & tmc_params=tmc_env%params) - IF (gt_act_elem%swaped) THEN + IF (gt_act_elem%swaped) & CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf + 1, accepted=result_acc, & tmc_params=tmc_env%params) - END IF ! save for analysis IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1 .AND. result_acc) THEN @@ -886,9 +879,8 @@ CONTAINS ready = .FALSE. IF ((elem%scf_energies_count >= 4) & .AND. (elem%stat /= status_deleted) .AND. (elem%stat /= status_deleted_result) & - .AND. (elem%stat /= status_canceled_ener)) THEN + .AND. (elem%stat /= status_canceled_ener)) & ready = .TRUE. - END IF END FUNCTION ready_for_update_acc_prob ! ************************************************************************************************** @@ -1040,10 +1032,9 @@ CONTAINS IF (tmp_prob >= 0.0_dp) THEN tmp_pt_ptr%gt_elem%prob_acc = tmp_prob !-- speculative canceling for the related direction - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & CALL search_canceling_elements(pt_elem_in=tmp_pt_ptr%gt_elem, & prob=tmp_pt_ptr%gt_elem%prob_acc, tmc_env=tmc_env) - END IF END IF ! get next related global tree pointer diff --git a/src/tmc/tmc_tree_build.F b/src/tmc/tmc_tree_build.F index 62a319f9c0..cea018160d 100644 --- a/src/tmc/tmc_tree_build.F +++ b/src/tmc/tmc_tree_build.F @@ -364,11 +364,10 @@ CONTAINS ! simulated annealing start temperature global_tree%Temp = tmc_env%params%Temp(1) - IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) THEN + IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) & CALL cp_abort(__LOCATION__, & "there is no parallel tempering implementation for simulated annealing implemented "// & "(just one Temp per global tree element.") - END IF !-- IF program is restarted, read restart file IF (tmc_env%m_env%restart_in_file_name /= "") THEN @@ -441,12 +440,10 @@ CONTAINS !-- distribute energy of first element to all subtrees DO i = 1, SIZE(gt_tree_ptr%conf) gt_tree_ptr%conf(i)%elem%stat = status_accepted_result - IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) THEN + IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) & gt_tree_ptr%conf(i)%elem%dipole = gt_tree_ptr%conf(1)%elem%dipole - END IF - IF (tmc_env%m_env%restart_in_file_name == "") THEN + IF (tmc_env%m_env%restart_in_file_name == "") & gt_tree_ptr%conf(i)%elem%potential = gt_tree_ptr%conf(1)%elem%potential - END IF END DO IF (tmc_env%m_env%restart_in_file_name == "") THEN @@ -541,12 +538,10 @@ CONTAINS ((.NOT. n_acc) .AND. ASSOCIATED(tmp_elem%nacc))) THEN !set pointer to the actual element - IF (n_acc) THEN + IF (n_acc) & new_elem => tmp_elem%acc - END IF - IF (.NOT. n_acc) THEN + IF (.NOT. n_acc) & new_elem => tmp_elem%nacc - END IF ! check for existing subtree element CPASSERT(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem)) @@ -575,11 +570,10 @@ CONTAINS CASE (mv_type_MD) new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_MD CASE (mv_type_NMC_moves) - IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) THEN + IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) & CALL cp_warn(__LOCATION__, & "reactivating tree element with wrong status"// & cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat)) - END IF new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_NMC_steps !IF(DEBUG>=1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & @@ -605,14 +599,12 @@ CONTAINS !-- set pointers to and from element one level up !-- paste new gt tree node element at right end IF (n_acc) THEN - IF (ASSOCIATED(tmp_elem%acc)) THEN + IF (ASSOCIATED(tmp_elem%acc)) & CPABORT("creating new subtree element on an occupied acc branch") - END IF tmp_elem%acc => new_elem ELSE - IF (ASSOCIATED(tmp_elem%nacc)) THEN + IF (ASSOCIATED(tmp_elem%nacc)) & CPABORT("creating new subtree element on an occupied nacc branch") - END IF tmp_elem%nacc => new_elem END IF new_elem%parent => tmp_elem @@ -695,10 +687,9 @@ CONTAINS new_elem%prob_acc = tmc_env%params%move_types%acc_prob( & mv_type_swap_conf, new_elem%mv_conf) CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) - END IF ! nothing to do for the workers stat = status_calculated keep_on = .FALSE. @@ -719,11 +710,10 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) - END IF END IF ELSE !-- check if child element in REJECTED direction already exist @@ -735,11 +725,10 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) - END IF END IF END IF ! set approximate probability of acceptance @@ -749,10 +738,9 @@ CONTAINS new_elem%conf(new_elem%mv_conf)%elem%move_type, new_elem%mv_conf) ! add refence and dot CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) - END IF END IF ! swap or no swap END IF ! global tree node already exist. Hence the Subtree node also (it is speculative canceled) END IF ! keep on (checking and creating) @@ -761,9 +749,8 @@ CONTAINS IF (new_elem%stat == status_accepted_result .OR. & new_elem%stat == status_accepted .OR. & new_elem%stat == status_rejected .OR. & - new_elem%stat == status_rejected_result) THEN + new_elem%stat == status_rejected_result) & CPABORT("selected existing RESULT gt node") - END IF !-- set status of global tree element for decision in master routine SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat) CASE (status_rejected_result, status_rejected, status_accepted, & @@ -771,18 +758,16 @@ CONTAINS ! energy is already calculated new_elem%stat = status_calculated stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF CASE (status_calc_approx_ener) new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF END IF CASE (status_calculate_MD, status_calculate_energy, & status_calculate_NMC_steps, status_created) @@ -790,10 +775,9 @@ CONTAINS new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF END IF CASE (status_cancel_ener, status_canceled_ener) ! configuration is already created, @@ -803,10 +787,9 @@ CONTAINS ! creation complete, handle energy calculation at a different position ! (for different worker group) stat = status_calculated - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF CASE (status_cancel_nmc, status_canceled_nmc) ! reactivation canceled element (but with new global tree element) new_elem%conf(new_elem%mv_conf)%elem%stat = & @@ -814,10 +797,9 @@ CONTAINS new_elem%stat = status_calculate_NMC_steps stat = new_elem%conf(new_elem%mv_conf)%elem%stat reactivation_cc_count = reactivation_cc_count + 1 - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & "unknown stat "// & @@ -971,9 +953,8 @@ CONTAINS new_elem%stat = status_calculated ELSE new_elem%stat = status_created - IF (tmc_env%params%NMC_inp_file /= "") THEN + IF (tmc_env%params%NMC_inp_file /= "") & new_elem%stat = status_calc_approx_ener - END IF END IF CASE (mv_type_gausian_adapt) ! still could be implemented @@ -1023,9 +1004,8 @@ CONTAINS ELSE gt_ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params) - END IF !remove pointer from tree parent IF (ASSOCIATED(gt_ptr%parent)) THEN @@ -1080,13 +1060,12 @@ CONTAINS ! if there is still e reference to a global tree pointer, do not deallocate element IF (ASSOCIATED(ptr%gt_nodes_references)) THEN - IF (ASSOCIATED(ptr%parent)) THEN + IF (ASSOCIATED(ptr%parent)) & CALL cp_warn(__LOCATION__, & "try to deallocate subtree element"// & cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr)// & " still with global tree element references e.g."// & cp_to_string(ptr%gt_nodes_references%gt_elem%nr)) - END IF CPASSERT(ASSOCIATED(ptr%gt_nodes_references%gt_elem)) ELSE SELECT CASE (ptr%stat) @@ -1116,9 +1095,8 @@ CONTAINS ELSE ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & CALL create_dot_color(tree_element=ptr, tmc_params=tmc_env%params) - END IF !remove pointer from tree parent IF (ASSOCIATED(ptr%parent)) THEN @@ -1298,21 +1276,19 @@ CONTAINS ! delete element IF (remove_this) THEN !-- mark as deleted and draw it in tree - IF (.NOT. ASSOCIATED(begin_ptr%parent)) THEN + IF (.NOT. ASSOCIATED(begin_ptr%parent)) & CALL cp_abort(__LOCATION__, & "try to remove unused subtree element "// & cp_to_string(begin_ptr%sub_tree_nr)//" "// & cp_to_string(begin_ptr%nr)// & " but parent does not exist") - END IF tmp_ptr => begin_ptr ! check if a working group is still working on this element removed = .TRUE. DO i = 1, SIZE(working_elem_list(:)) IF (ASSOCIATED(working_elem_list(i)%elem)) THEN - IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) THEN + IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) & removed = .FALSE. - END IF END IF END DO IF (removed) THEN @@ -1357,11 +1333,10 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) THEN + IF (ASSOCIATED(actual_ptr%parent)) & CALL remove_result_g_tree(end_of_clean_tree=end_of_clean_tree, & actual_ptr=actual_ptr%parent, & tmc_env=tmc_env) - END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN !-- deallocate node @@ -1401,10 +1376,9 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) THEN + IF (ASSOCIATED(actual_ptr%parent)) & CALL remove_result_s_tree(end_of_clean_tree, actual_ptr%parent, & tmc_env) - END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN @@ -1472,9 +1446,8 @@ CONTAINS actual_ptr=tmp_gt_ptr, tmc_env=tmc_env) !check if something changed, if not no deallocation of result subtree necessary - IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) THEN + IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) & change_trajec = .TRUE. - END IF tmc_env%m_env%gt_head => tmc_env%m_env%gt_clean_end CPASSERT(.NOT. ASSOCIATED(tmc_env%m_env%gt_head%parent)) !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr @@ -1486,9 +1459,8 @@ CONTAINS ! get last checked element in trajectory related to the subtree (resultlist order is NOT subtree order) conf_loop: DO i = 1, SIZE(tmc_env%m_env%result_list) last_acc_st_elem => tmc_env%m_env%result_list(i)%elem - IF (last_acc_st_elem%sub_tree_nr == tree) THEN + IF (last_acc_st_elem%sub_tree_nr == tree) & EXIT conf_loop - END IF END DO conf_loop CPASSERT(last_acc_st_elem%sub_tree_nr == tree) CALL remove_unused_s_tree(begin_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, & diff --git a/src/tmc/tmc_tree_search.F b/src/tmc/tmc_tree_search.F index a2371f3447..5de61a8f44 100644 --- a/src/tmc/tmc_tree_search.F +++ b/src/tmc/tmc_tree_search.F @@ -721,12 +721,10 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) THEN + IF (ASSOCIATED(ptr%acc)) & CALL count_nodes_in_global_tree(ptr%acc, counter) - END IF - IF (ASSOCIATED(ptr%nacc)) THEN + IF (ASSOCIATED(ptr%nacc)) & CALL count_nodes_in_global_tree(ptr%nacc, counter) - END IF END SUBROUTINE count_nodes_in_global_tree ! ************************************************************************************************** @@ -743,11 +741,9 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) THEN + IF (ASSOCIATED(ptr%acc)) & CALL count_nodes_in_tree(ptr%acc, counter) - END IF - IF (ASSOCIATED(ptr%nacc)) THEN + IF (ASSOCIATED(ptr%nacc)) & CALL count_nodes_in_tree(ptr%nacc, counter) - END IF END SUBROUTINE count_nodes_in_tree END MODULE tmc_tree_search diff --git a/src/tmc/tmc_types.F b/src/tmc/tmc_types.F index b7884be56f..02292e1c68 100644 --- a/src/tmc/tmc_types.F +++ b/src/tmc/tmc_types.F @@ -216,28 +216,22 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%params)) DEALLOCATE (tmc_env%params%sub_box_size) - IF (ASSOCIATED(tmc_env%params%Temp)) THEN + IF (ASSOCIATED(tmc_env%params%Temp)) & DEALLOCATE (tmc_env%params%Temp) - END IF - IF (ASSOCIATED(tmc_env%params%cell)) THEN + IF (ASSOCIATED(tmc_env%params%cell)) & DEALLOCATE (tmc_env%params%cell) - END IF - IF (ASSOCIATED(tmc_env%params%atoms)) THEN + IF (ASSOCIATED(tmc_env%params%atoms)) & CALL deallocate_tmc_atom_type(tmc_env%params%atoms) - END IF DEALLOCATE (tmc_env%params) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_sub_group) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_w) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_first_w) - END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_ana) - END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) & CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_only) - END IF DEALLOCATE (tmc_env%tmc_comp_set) @@ -287,9 +281,8 @@ CONTAINS DO i = 1, tmc_env%params%nr_temp tmc_env%m_env%st_heads(i)%elem => NULL() tmc_env%m_env%st_clean_ends(i)%elem => NULL() - IF (tmc_env%params%USE_REDUCED_TREE) THEN + IF (tmc_env%params%USE_REDUCED_TREE) & tmc_env%m_env%result_list(i)%elem => NULL() - END IF END DO tmc_env%m_env%gt_head => NULL() tmc_env%m_env%gt_clean_end => NULL() diff --git a/src/tmc/tmc_worker.F b/src/tmc/tmc_worker.F index bdc50bb514..2e2204d988 100644 --- a/src/tmc/tmc_worker.F +++ b/src/tmc/tmc_worker.F @@ -167,15 +167,13 @@ CONTAINS END IF ! set the communicator in the external control for receiving exit tags ! and sending additional information (e.g. the intermediate scf energies) - IF (tmc_env%params%use_scf_energy_info) THEN + IF (tmc_env%params%use_scf_energy_info) & CALL set_intermediate_info_comm(env_id=itmp, & comm=tmc_env%tmc_comp_set%para_env_m_w) - END IF - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & CALL set_external_comm(comm=tmc_env%tmc_comp_set%para_env_m_w, & in_external_master_id=MASTER_COMM_ID, & in_exit_tag=TMC_CANCELING_MESSAGE) - END IF END IF !-- WORKING LOOP --! master_work_time: DO @@ -189,10 +187,9 @@ CONTAINS result_count=ana_restart_conf, & tmc_params=tmc_env%params, elem=conf) - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & WRITE (tmc_env%w_env%io_unit, *) "worker: group master of group ", & - tmc_env%tmc_comp_set%group_nr, "got task ", work_stat - END IF + tmc_env%tmc_comp_set%group_nr, "got task ", work_stat calc_stat = TMC_STATUS_CALCULATING SELECT CASE (work_stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -211,10 +208,9 @@ CONTAINS para_env=para_env_m_w, & tmc_params=tmc_env%params) CASE (TMC_STATUS_FAILED) - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%w_env%io_unit, *) "master worker of group", & - tmc_env%tmc_comp_set%group_nr, " exit work time." - END IF + tmc_env%tmc_comp_set%group_nr, " exit work time." EXIT master_work_time !-- group master read the CP2K input file, and write data to master CASE (TMC_STAT_START_CONF_REQUEST) @@ -234,11 +230,10 @@ CONTAINS tmc_params=tmc_env%params, elem=conf, & wait_for_message=.TRUE.) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & para_env=tmc_env%tmc_comp_set%para_env_m_first_w) - END IF !-- calculate the approximate energy CASE (TMC_STAT_APPROX_ENERGY_REQUEST) CPASSERT(tmc_env%w_env%env_id_approx > 0) @@ -272,7 +267,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -344,11 +339,10 @@ CONTAINS res_exist=flag, ierr=ierr) IF (.NOT. flag) tmc_env%params%print_dipole = .FALSE. ! TODO maybe let run with the changed option, but inform user properly - IF (.NOT. flag) THEN + IF (.NOT. flag) & CALL cp_abort(__LOCATION__, & "TMC: The requested dipoles are not porvided by the "// & "force environment.") - END IF END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -364,11 +358,10 @@ CONTAINS END SELECT !-- send information back to master - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%w_env%io_unit, *) "worker group ", & - tmc_env%tmc_comp_set%group_nr, & - "calculations done, send result energy", conf%potential - END IF + tmc_env%tmc_comp_set%group_nr, & + "calculations done, send result energy", conf%potential itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & @@ -393,10 +386,9 @@ CONTAINS CALL analysis_init(ana_env=ana_list(itmp)%temp, nr_dim=num_dim) ana_list(itmp)%temp%print_test_output = tmc_env%params%print_test_output - IF (.NOT. ASSOCIATED(conf)) THEN + IF (.NOT. ASSOCIATED(conf)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=conf, nr_dim=num_dim) - END IF CALL analysis_restart_read(ana_env=ana_list(itmp)%temp, & elem=conf) !check if we have the read the file @@ -446,14 +438,12 @@ CONTAINS cp_to_string(work_stat)) END SELECT - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & WRITE (tmc_env%w_env%io_unit, *) "worker: group ", & - tmc_env%tmc_comp_set%group_nr, & - "send back status:", work_stat - END IF - IF (ASSOCIATED(conf)) THEN + tmc_env%tmc_comp_set%group_nr, & + "send back status:", work_stat + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=conf) - END IF END DO master_work_time !-- every other group paricipants---------------------------------------- ELSE @@ -499,7 +489,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -526,9 +516,8 @@ CONTAINS "group participant got unknown working type "// & cp_to_string(work_stat)) END SELECT - IF (ASSOCIATED(conf)) THEN + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=conf) - END IF END DO worker_work_time END IF ! -------------------------------------------------------------------- @@ -536,9 +525,8 @@ CONTAINS IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN DO itmp = 1, tmc_env%params%nr_temp CALL analysis_restart_print(ana_env=ana_list(itmp)%temp) - IF (ASSOCIATED(conf)) THEN + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(itmp)%temp%last_elem) - END IF CALL finalize_tmc_analysis(ana_list(itmp)%temp) END DO END IF @@ -558,10 +546,9 @@ CONTAINS CALL remove_intermediate_info_comm(env_id=itmp) END IF END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) & CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_sub_group, & tmc_params=tmc_env%params) - END IF work_stat = TMC_STATUS_STOP_RECEIPT itmp = MASTER_COMM_ID @@ -576,11 +563,10 @@ CONTAINS tmc_params=tmc_env%params) END IF - IF (DEBUG >= 5) THEN + IF (DEBUG >= 5) & WRITE (tmc_env%w_env%io_unit, *) "worker ", & - tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & - tmc_env%tmc_comp_set%group_nr, "stops working!" - END IF + tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & + tmc_env%tmc_comp_set%group_nr, "stops working!" IF (PRESENT(ana_list)) THEN DO itmp = 1, tmc_env%params%nr_temp @@ -588,9 +574,8 @@ CONTAINS ana_list(itmp)%temp%cell => NULL() END DO END IF - IF (ASSOCIATED(conf)) THEN + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=conf) - END IF IF (ASSOCIATED(ana_restart_conf)) DEALLOCATE (ana_restart_conf) ! end the timing @@ -887,11 +872,10 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & CALL cp_abort(__LOCATION__, & "the intermediate SCF energy request can not be set "// & "employing this force environment! ") - END IF ! set the information values(1) = REAL(comm%get_handle(), KIND=dp) @@ -926,11 +910,10 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & CALL cp_abort(__LOCATION__, & "the SCF intermediate energy communicator can not be "// & "removed! ") - END IF description = "[EXT_SCF_ENER_COMM]" diff --git a/src/topology.F b/src/topology.F index e482a1cb4c..b82782ec0a 100644 --- a/src/topology.F +++ b/src/topology.F @@ -548,12 +548,11 @@ CONTAINS "connectivity type.") END SELECT END DO - IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) THEN + IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) & CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") - END IF ! Merge defined structures section => section_vals_get_subs_vals(subsys_section, "TOPOLOGY%MOL_SET%MERGE_MOLECULES") @@ -661,9 +660,8 @@ CONTAINS i_val=topology%natoms) CALL timestop(handle2) ! Check on atom numbers - IF (topology%natoms <= 0) THEN + IF (topology%natoms <= 0) & CPABORT("No atomic coordinates have been found! ") - END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & "PRINT%TOPOLOGY_INFO") diff --git a/src/topology_amber.F b/src/topology_amber.F index 10425ea382..8f9bbc4361 100644 --- a/src/topology_amber.F +++ b/src/topology_amber.F @@ -184,9 +184,8 @@ CONTAINS END DO ! Trigger error IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) THEN + IF (j /= natom) & CPABORT("Error while reading CRD file. Unexpected end of file.") - END IF ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom j = natom @@ -231,11 +230,10 @@ CONTAINS END DO setup_velocities = .TRUE. IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) THEN + IF (j /= natom) & CALL cp_warn(__LOCATION__, & "No VELOCITY information found in CRD file. Ignoring BOX information. "// & "Please provide the BOX information directly from the main CP2K input! ") - END IF setup_velocities = .FALSE. ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom @@ -259,11 +257,10 @@ CONTAINS IF (my_end) THEN CPWARN_IF(j /= natom, "BOX information missing in CRD file.") ELSE - IF (j /= natom) THEN + IF (j /= natom) & CALL cp_warn(__LOCATION__, & "BOX information found in CRD file. They will be ignored. "// & "Please provide the BOX information directly from the main CP2K input!") - END IF END IF CALL parser_release(parser) CALL cp_print_key_finished_output(iw, logger, subsys_section, & @@ -1063,18 +1060,16 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i1 ! ************************************************************************************************** @@ -1101,30 +1096,26 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i3 ! ************************************************************************************************** @@ -1152,36 +1143,31 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i4 ! ************************************************************************************************** @@ -1211,42 +1197,36 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) !array5 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array5(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i5 ! ************************************************************************************************** @@ -1270,18 +1250,16 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i), lower_to_upper=.TRUE.) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_c1 ! ************************************************************************************************** @@ -1305,18 +1283,16 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_r1 ! ************************************************************************************************** @@ -1345,9 +1321,8 @@ CONTAINS section = TRIM(parser%input_line(indflag:)) ! Input format CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) THEN + IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) & CPABORT("Expecting %FORMAT. Not found! Abort reading of AMBER topology file!") - END IF start_f = INDEX(parser%input_line, "(") end_f = INDEX(parser%input_line, ")") @@ -1371,11 +1346,10 @@ CONTAINS LOGICAL :: found_AMBER_V8 CALL parser_search_string(parser, "%VERSION ", .TRUE., found_AMBER_V8, begin_line=.TRUE.) - IF (.NOT. found_AMBER_V8) THEN + IF (.NOT. found_AMBER_V8) & CALL cp_abort(__LOCATION__, & "This is not an AMBER V.8 PRMTOP format file. Cannot interpret older "// & "AMBER file formats. ") - END IF IF (output_unit > 0) WRITE (output_unit, '(" AMBER_INFO| ",A)') "Amber PrmTop V.8 or greater.", & TRIM(parser%input_line) diff --git a/src/topology_cif.F b/src/topology_cif.F index eb3f9250f3..0100632559 100644 --- a/src/topology_cif.F +++ b/src/topology_cif.F @@ -249,10 +249,9 @@ CONTAINS CALL parser_search_string(parser, "_space_group_symop_operation_xyz", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) END IF - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_warn(__LOCATION__, "The fields (_symmetry_equiv_pos_as_xyz) or "// & "(_space_group_symop_operation_xyz) were not found in CIF file!") - END IF IF (iw > 0) WRITE (iw, '(A,I0)') " CIF_INFO| Number of atoms before applying symmetry operations :: ", natom IF (iw > 0) WRITE (iw, '(A10,1X,3F12.6)') (TRIM(id2str(atom_info%id_atmname(ii))), atom_info%r(1:3, ii), ii=1, natom) isym = 0 @@ -291,6 +290,7 @@ CONTAINS DO jj = 1, natom r2 = atom_info%r(1:3, jj) r = pbc(r1 - r2, cell) + ! SQRT(DOT_PRODUCT(r, r)) <= threshold IF (DOT_PRODUCT(r, r) <= (threshold*threshold)) THEN check = .FALSE. EXIT diff --git a/src/topology_connectivity_util.F b/src/topology_connectivity_util.F index 7518b6dfc0..8506ee4119 100644 --- a/src/topology_connectivity_util.F +++ b/src/topology_connectivity_util.F @@ -74,7 +74,7 @@ CONTAINS inter_bends, inter_bonds, inter_imprs, inter_torsions, inter_ubs, intra_bends, & intra_bonds, intra_imprs, intra_torsions, intra_ubs, inum, ires, istart_mol, istart_typ, & itorsion, ityp, iub, iw, j, j1, j2, j3, j4, jind, last, min_index, natom, nelectron, & - nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit + nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit, stat INTEGER, DIMENSION(:), POINTER :: c_var_a, c_var_b, c_var_c, c_var_d, c_var_type, & first_list, last_list, map_atom_mol, map_atom_type, map_cvar_mol, map_cvars, map_var_mol, & map_vars, molecule_list @@ -225,7 +225,7 @@ CONTAINS found = .TRUE. found_last = .FALSE. imol = ABS(map_atom_mol(i)) - ELSE IF (ikind == topology%nmol_type) THEN + ELSEIF (ikind == topology%nmol_type) THEN found = .TRUE. found_last = .TRUE. imol = ABS(map_atom_mol(natom)) @@ -1057,8 +1057,9 @@ CONTAINS END IF molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + iimpr*SIZE(molecule_kind%molecule_list) - ALLOCATE (impr_list(iimpr)) - ALLOCATE (opbend_list(iimpr)) + ALLOCATE (impr_list(iimpr), STAT=stat) + ALLOCATE (opbend_list(iimpr), STAT=stat) + CPASSERT(stat == 0) iimpr = 0 DO j = bnd_type(1, i), bnd_type(2, i) IF (j == 0) CYCLE diff --git a/src/topology_constraint_util.F b/src/topology_constraint_util.F index 2980507f15..b7d07a8b12 100644 --- a/src/topology_constraint_util.F +++ b/src/topology_constraint_util.F @@ -241,13 +241,11 @@ CONTAINS END IF END IF CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", n_rep_val=nrep) - IF (nrep /= 0) THEN + IF (nrep /= 0) & CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", c_vals=atom_typeh) - END IF CALL section_vals_val_get(hbonds_section, "TARGETS", n_rep_val=nrep) - IF (nrep /= 0) THEN + IF (nrep /= 0) & CALL section_vals_val_get(hbonds_section, "TARGETS", r_vals=hdist) - END IF IF (ASSOCIATED(hdist)) THEN CPASSERT(SIZE(hdist) == SIZE(atom_typeh)) END IF @@ -344,7 +342,7 @@ CONTAINS IF (ishbond) THEN nhdist = nhdist + 1 rvec = particle_set(offset + bond_list(k)%a)%r - particle_set(offset + bond_list(k)%b)%r - rmod = NORM2(rvec) + rmod = SQRT(DOT_PRODUCT(rvec, rvec)) IF (ASSOCIATED(hdist)) THEN IF (SIZE(hdist) > 0) THEN IF (bond_list(k)%a == j) atomic_kind => atom_list(bond_list(k)%b)%atomic_kind @@ -752,13 +750,13 @@ CONTAINS IF (fix_fixed_atom) THEN fixd_list(kk)%restraint%active = cons_info%fixed_restraint(k2loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_k0(k2loc) - ELSE IF (fix_atom_qm) THEN + ELSEIF (fix_atom_qm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_qm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_qm_k0 - ELSE IF (fix_atom_mm) THEN + ELSEIF (fix_atom_mm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_mm_k0 - ELSE IF (fix_atom_molname) THEN + ELSEIF (fix_atom_molname) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mol_restraint(k1loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_mol_k0(k1loc) ELSE @@ -815,9 +813,8 @@ CONTAINS CASE (use_perd_xyz) CPASSERT(SIZE(r) == 3) fixd_list(kk)%coord(1:3) = r(1:3) - IF (ASSOCIATED(topology%cell_muc)) THEN + IF (ASSOCIATED(topology%cell_muc)) & CALL cell_transform_input_cartesian(topology%cell_muc, fixd_list(kk)%coord) - END IF END SELECT ELSE ! Write coord0 value for restraint @@ -1341,12 +1338,11 @@ CONTAINS ! Intramolecular constraint IF (const_mol(i) /= 0) THEN k = const_mol(i) - IF (k > SIZE(molecule_kind_set)) THEN + IF (k > SIZE(molecule_kind_set)) & CALL cp_abort(__LOCATION__, & "A constraint has been specified providing the molecule index. But the"// & " molecule index ("//cp_to_string(k)//") is out of range of the possible"// & " molecule kinds ("//cp_to_string(SIZE(molecule_kind_set))//").") - END IF isize = SIZE(constr_x_mol(k)%constr) CALL reallocate(constr_x_mol(k)%constr, 1, isize + 1) constr_x_mol(k)%constr(isize + 1) = i @@ -1383,14 +1379,13 @@ CONTAINS LOGICAL, INTENT(IN) :: found CHARACTER(LEN=*), INTENT(IN) :: name - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_warn(__LOCATION__, & " MOLNAME ("//TRIM(name)//") was defined for constraints, but this molecule name "// & "is not defined. Please check carefully your PDB, PSF (has priority over PDB) or "// & "input driven CP2K coordinates. In case you may not find the reason for this warning "// & "it may be a good idea to print all molecule information (including kind name) activating "// & "the print_key MOLECULES specific of the SUBSYS%PRINT section. ") - END IF END SUBROUTINE print_warning_molname diff --git a/src/topology_coordinate_util.F b/src/topology_coordinate_util.F index 63584a9429..e2a1b91768 100644 --- a/src/topology_coordinate_util.F +++ b/src/topology_coordinate_util.F @@ -198,9 +198,8 @@ CONTAINS CALL reallocate(mass, 1, counter) CALL reallocate(id_element, 1, counter) CALL reallocate(charge, 1, counter) - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(5X,A,I3)') "Total Number of Atomic Kinds = ", topology%natom_type - END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -339,11 +338,10 @@ CONTAINS END DO my_ignore_outside_box = .FALSE. IF (PRESENT(ignore_outside_box)) my_ignore_outside_box = ignore_outside_box - IF (.NOT. my_ignore_outside_box .AND. .NOT. check) THEN + IF (.NOT. my_ignore_outside_box .AND. .NOT. check) & CALL cp_abort(__LOCATION__, & "A non-periodic calculation has been requested but the system size "// & "exceeds the cell size in at least one of the non-periodic directions!") - END IF IF (do_center) THEN CALL section_vals_val_get(subsys_section, & "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT", explicit=explicit) @@ -638,23 +636,20 @@ CONTAINS ! copy of data, not copy of pointer exclusions(iatom)%list_onfo = ex_onfo_list(iatom)%array1 IF (iw > 0) THEN - IF (ASSOCIATED(list)) THEN + IF (ASSOCIATED(list)) & WRITE (iw, *) "exclusion list_vdw :: ", & - "atom num :", iatom, "exclusion list ::", & - list - END IF + "atom num :", iatom, "exclusion list ::", & + list IF (topology%exclude_vdw /= topology%exclude_ei) THEN - IF (ASSOCIATED(list2)) THEN + IF (ASSOCIATED(list2)) & WRITE (iw, *) "exclusion list_ei :: ", & - "atom num :", iatom, "exclusion list ::", & - list2 - END IF + "atom num :", iatom, "exclusion list ::", & + list2 END IF - IF (ASSOCIATED(exclusions(iatom)%list_onfo)) THEN + IF (ASSOCIATED(exclusions(iatom)%list_onfo)) & WRITE (iw, *) "onfo list :: ", & - "atom num :", iatom, "onfo list ::", & - exclusions(iatom)%list_onfo - END IF + "atom num :", iatom, "onfo list ::", & + exclusions(iatom)%list_onfo END IF END DO ! deallocate onfo diff --git a/src/topology_generate_util.F b/src/topology_generate_util.F index 5e17f4df5a..718c42ac9b 100644 --- a/src/topology_generate_util.F +++ b/src/topology_generate_util.F @@ -1669,7 +1669,7 @@ CONTAINS nvar=nvar, & Ilist=Ilist) Ilist(it_levl) = -1 - ELSE IF (it_levl == max_levl) THEN + ELSEIF (it_levl == max_levl) THEN IF (Ilist(1) > ind) CYCLE Ilist(it_levl) = ind nvar = nvar + 1 diff --git a/src/topology_gromos.F b/src/topology_gromos.F index 743d890308..d3ddfa9858 100644 --- a/src/topology_gromos.F +++ b/src/topology_gromos.F @@ -607,12 +607,10 @@ CONTAINS DEALLOCATE (na) DEALLOCATE (am) DEALLOCATE (ac) - IF (ASSOCIATED(ba)) THEN + IF (ASSOCIATED(ba)) & DEALLOCATE (ba) - END IF - IF (ASSOCIATED(bb)) THEN + IF (ASSOCIATED(bb)) & DEALLOCATE (bb) - END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & diff --git a/src/topology_input.F b/src/topology_input.F index 6aad5946ca..4aa95dfb4b 100644 --- a/src/topology_input.F +++ b/src/topology_input.F @@ -64,9 +64,8 @@ CONTAINS CALL section_vals_val_get(topology_section, "CHARGE_BETA", l_val=topology%charge_beta) CALL section_vals_val_get(topology_section, "CHARGE_EXTENDED", l_val=topology%charge_extended) ival = COUNT([topology%charge_occup, topology%charge_beta, topology%charge_extended]) - IF (ival > 1) THEN + IF (ival > 1) & CPABORT("Only one between can be defined! ") - END IF CALL section_vals_val_get(topology_section, "PARA_RES", l_val=topology%para_res) CALL section_vals_val_get(topology_section, "GENERATE%REORDER", l_val=topology%reorder_atom) CALL section_vals_val_get(topology_section, "GENERATE%CREATE_MOLECULES", l_val=topology%create_molecules) diff --git a/src/topology_multiple_unit_cell.F b/src/topology_multiple_unit_cell.F index 771768035e..bd93f27785 100644 --- a/src/topology_multiple_unit_cell.F +++ b/src/topology_multiple_unit_cell.F @@ -65,21 +65,19 @@ CONTAINS i_vals=multiple_unit_cell) ! Fail is one of the value is set to zero.. - IF (ANY(multiple_unit_cell <= 0)) THEN + IF (ANY(multiple_unit_cell <= 0)) & CALL cp_abort(__LOCATION__, "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL accepts "// & "only integer values greater than zero.") - END IF IF (ANY(multiple_unit_cell /= 1)) THEN ! Check that the setup between CELL and TOPOLOGY is the same CALL section_vals_val_get(subsys_section, "CELL%MULTIPLE_UNIT_CELL", & i_vals=iwork) - IF (ANY(iwork /= multiple_unit_cell)) THEN + IF (ANY(iwork /= multiple_unit_cell)) & CALL cp_abort(__LOCATION__, "The input parameters for "// & "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL and "// & "SUBSYS%CELL%MULTIPLE_UNIT_CELL have to agree.") - END IF cell => topology%cell_muc natoms = topology%natoms*PRODUCT(multiple_unit_cell) @@ -90,10 +88,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(work_section, '_DEFAULT_KEYWORD_', n_rep_val=nrep) check = nrep == natoms - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "The number of available entries in the "// & "VELOCITY section is not compatible with the number of atoms.") - END IF END IF CALL reallocate(topology%atom_info%id_molname, 1, natoms) diff --git a/src/topology_pdb.F b/src/topology_pdb.F index f995d732a2..481169411a 100644 --- a/src/topology_pdb.F +++ b/src/topology_pdb.F @@ -185,20 +185,12 @@ CONTAINS ELSE atom_info%id_resname(natom) = id0 END IF - ! Some information is not always given, so we mark it as used to prevent linters from crying - ! regarding never a never used variable 'istat' READ (UNIT=line(23:26), FMT=*, IOSTAT=istat) atom_info%resid(natom) - MARK_USED(istat) READ (UNIT=line(31:38), FMT=*, IOSTAT=istat) atom_info%r(1, natom) - MARK_USED(istat) READ (UNIT=line(39:46), FMT=*, IOSTAT=istat) atom_info%r(2, natom) - MARK_USED(istat) READ (UNIT=line(47:54), FMT=*, IOSTAT=istat) atom_info%r(3, natom) - MARK_USED(istat) READ (UNIT=line(55:60), FMT=*, IOSTAT=istat) atom_info%occup(natom) - MARK_USED(istat) READ (UNIT=line(61:66), FMT=*, IOSTAT=istat) atom_info%beta(natom) - MARK_USED(istat) READ (UNIT=line(73:76), FMT=*, IOSTAT=istat) strtmp IF (istat == 0) THEN atom_info%id_molname(natom) = str2id(s2s(strtmp)) @@ -217,7 +209,7 @@ CONTAINS IF (topology%charge_occup) atom_info%atm_charge(natom) = atom_info%occup(natom) IF (topology%charge_beta) atom_info%atm_charge(natom) = atom_info%beta(natom) IF (topology%charge_extended) THEN - READ (UNIT=line(81:), FMT=*) atom_info%atm_charge(natom) + READ (UNIT=line(81:), FMT=*, IOSTAT=istat) atom_info%atm_charge(natom) END IF IF (atom_info%id_element(natom) == id0) THEN @@ -318,9 +310,8 @@ CONTAINS CALL section_vals_val_get(print_key, "CHARGE_BETA", l_val=charge_beta) CALL section_vals_val_get(print_key, "CHARGE_EXTENDED", l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) THEN + IF (i > 1) & CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected") - END IF atom_info => topology%atom_info record = cp_print_key_generate_filename(logger, print_key, & @@ -380,9 +371,8 @@ CONTAINS END IF IF (ASSOCIATED(atom_info%atm_charge)) THEN IF (ANY([charge_occup, charge_beta, charge_extended]) .AND. & - (atom_info%atm_charge(i) == -HUGE(0.0_dp))) THEN + (atom_info%atm_charge(i) == -HUGE(0.0_dp))) & CPABORT("No atomic charges found yet (after the topology setup)") - END IF IF (charge_occup) THEN WRITE (UNIT=line(55:60), FMT="(F6.2)") atom_info%atm_charge(i) ELSE IF (charge_beta) THEN diff --git a/src/topology_psf.F b/src/topology_psf.F index ce03e59dae..91aaec84e7 100644 --- a/src/topology_psf.F +++ b/src/topology_psf.F @@ -113,10 +113,9 @@ CONTAINS c_int = 'I8' label = 'PSF' CALL parser_search_string(parser, label, .TRUE., found, begin_line=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "Missing PSF specification line in <"//TRIM(filename)//">") - END IF DO WHILE (parser_test_next_token(parser) /= "EOL") CALL parser_get_object(parser, field) SELECT CASE (field(1:3)) @@ -148,12 +147,11 @@ CONTAINS natom = 0 ELSE CALL parser_get_object(parser, natom) - IF (natom_prev + natom > topology%natoms) THEN + IF (natom_prev + natom > topology%natoms) & CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") - END IF IF (iw > 0) WRITE (iw, '(T2,A,'//TRIM(c_int)//')') 'PSF_INFO| NATOM = ', natom !malloc the memory that we need CALL reallocate(atom_info%id_molname, 1, natom_prev + natom) diff --git a/src/topology_types.F b/src/topology_types.F index 6300d6809b..440becf6d0 100644 --- a/src/topology_types.F +++ b/src/topology_types.F @@ -68,13 +68,12 @@ MODULE topology_types REAL(KIND=dp) :: hbonds_k0 = -1.0_dp ! Restraints control ! Fixed Atoms INTEGER :: nfixed_atoms = -1 - INTEGER, DIMENSION(:), POINTER :: fixed_atoms => NULL(), fixed_type => NULL(), fixed_mol_type => NULL() - LOGICAL, DIMENSION(:), POINTER :: fixed_restraint => NULL() ! Restraints control - REAL(KIND=dp), DIMENSION(:), POINTER :: fixed_k0 => NULL() ! Restraints control + INTEGER, POINTER :: fixed_atoms(:) => NULL(), fixed_type(:) => NULL(), fixed_mol_type(:) => NULL() + LOGICAL, POINTER :: fixed_restraint(:) => NULL() ! Restraints control + REAL(KIND=dp), POINTER :: fixed_k0(:) => NULL() ! Restraints control ! Freeze QM or MM INTEGER :: freeze_qm = -1, freeze_mm = -1, freeze_qm_type = -1, freeze_mm_type = -1 - ! Restraints control - LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. + LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. ! Restraints control REAL(KIND=dp) :: fixed_mm_k0 = -1.0_dp, fixed_qm_k0 = -1.0_dp ! Restraints control ! Freeze with molnames LOGICAL, POINTER :: fixed_mol_restraint(:) => NULL() ! Restraints control @@ -525,9 +524,8 @@ CONTAINS !----------------------------------------------------------------------------- ! 3. DEALLOCATE things in topology%cons_info !----------------------------------------------------------------------------- - IF (ASSOCIATED(topology%cons_info)) THEN + IF (ASSOCIATED(topology%cons_info)) & CALL deallocate_constraint(topology%cons_info) - END IF !----------------------------------------------------------------------------- ! 4. DEALLOCATE things in topology !----------------------------------------------------------------------------- diff --git a/src/topology_util.F b/src/topology_util.F index 0a042423bb..b53ba161c7 100644 --- a/src/topology_util.F +++ b/src/topology_util.F @@ -1207,12 +1207,11 @@ CONTAINS END IF ! This is clearly a user error - IF (.NOT. found .AND. defined_kind_section) THEN + IF (.NOT. found .AND. defined_kind_section) & CALL cp_abort(__LOCATION__, "Element <"//TRIM(element_symbol)// & "> provided for KIND <"//TRIM(atom_name_in)//"> "// & "which cannot be mapped with any standard element label. Please correct your "// & "input file!") - END IF ! Last chance.. are these atom_kinds of AMBER or CHARMM or GROMOS FF ? CALL uppercase(element_symbol) diff --git a/src/topology_xtl.F b/src/topology_xtl.F index 29b87259ff..42f6839993 100644 --- a/src/topology_xtl.F +++ b/src/topology_xtl.F @@ -144,9 +144,8 @@ CONTAINS ! Check for _cell_length_a CALL parser_search_string(parser, "CELL", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field CELL was not found in XTL file! ") - END IF CALL parser_get_next_line(parser, 1) ! CELL LENGTH A CALL parser_get_object(parser, cell_lengths(1)) @@ -179,15 +178,13 @@ CONTAINS ! Check for _atom_site_label CALL parser_search_string(parser, "ATOMS", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field ATOMS was not found in XTL file! ") - END IF CALL parser_get_next_line(parser, 1) ! Paranoic syntax check.. if this fails one should improve the description of XTL files found = (INDEX(parser%input_line, "NAME X Y Z") /= 0) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field ATOMS in XTL file, is not followed by name and coordinates tags! ") - END IF CALL parser_get_next_line(parser, 1) ! Parse real info natom = 0 diff --git a/src/topology_xyz.F b/src/topology_xyz.F index 6f881238c9..b01a1cab08 100644 --- a/src/topology_xyz.F +++ b/src/topology_xyz.F @@ -151,12 +151,11 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) my_end = my_end .OR. (LEN_TRIM(parser%input_line) == 0) IF (my_end) THEN - IF (j /= natom) THEN + IF (j /= natom) & CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format. Very probably the line with title is missing or is empty."// & " Please check the XYZ file and rerun your job!") - END IF EXIT Frames END IF END DO diff --git a/src/torch_c_api.cpp b/src/torch_c_api.cpp index 9293fd6425..9349653ebf 100644 --- a/src/torch_c_api.cpp +++ b/src/torch_c_api.cpp @@ -7,7 +7,6 @@ #if defined(__LIBTORCH) -#include #include #include #include @@ -17,7 +16,6 @@ #include #include -#include #include #include #include @@ -49,38 +47,7 @@ private: ******************************************************************************/ static bool use_cuda_if_available = true; -static bool get_positive_int_env(const char *name, int &value) { - const char *raw = std::getenv(name); - if (raw == nullptr || raw[0] == '\0') { - return false; - } - char *end = nullptr; - const long parsed = std::strtol(raw, &end, 10); - if (end == raw || *end != '\0' || parsed <= 0 || parsed > INT_MAX) { - return false; - } - value = static_cast(parsed); - return true; -} - -static void initialize_torch_threads_from_env() { - static bool initialized = false; - if (initialized) { - return; - } - initialized = true; - - int num_threads = 0; - if (get_positive_int_env("CP2K_TORCH_NUM_THREADS", num_threads)) { - at::set_num_threads(num_threads); - } - if (get_positive_int_env("CP2K_TORCH_NUM_INTEROP_THREADS", num_threads)) { - at::set_num_interop_threads(num_threads); - } -} - static torch::Device get_device() { - initialize_torch_threads_from_env(); if (!use_cuda_if_available || !torch::cuda::is_available()) { return torch::kCPU; } @@ -140,7 +107,6 @@ static torch_c_tensor_t *tensor_from_array(const torch::Dtype dtype, const bool req_grad, const int ndims, const int64_t sizes[], void *source) { - initialize_torch_threads_from_env(); const auto opts = torch::TensorOptions().dtype(dtype).requires_grad(req_grad); const auto sizes_ref = c10::IntArrayRef(sizes, ndims); return new torch_c_tensor_t(torch::from_blob(source, sizes_ref, opts)); diff --git a/src/transport.F b/src/transport.F index f13949bfea..fd9cc1ef24 100644 --- a/src/transport.F +++ b/src/transport.F @@ -381,11 +381,10 @@ CONTAINS CALL timeset(routineN, handle) CALL C_F_PROCPOINTER(transport_env%ext_c_method_ptr, c_method) - IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) THEN + IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) & CALL cp_abort(__LOCATION__, & "MISSING C/C++ ROUTINE: The TRANSPORT section is meant to be used together with an external "// & "program, e.g. the quantum transport code OMEN, that provides CP2K with a density matrix.") - END IF transport_env%params%n_occ = nelectron_spin transport_env%params%n_atoms = natoms diff --git a/src/wannier90.F b/src/wannier90.F index 79dcc46327..24c5901510 100644 --- a/src/wannier90.F +++ b/src/wannier90.F @@ -672,7 +672,7 @@ CONTAINS counter = counter + 1 lmn(1, counter) = l; lmn(2, counter) = m; lmn(3, counter) = n pos = MATMUL(lmn(:, counter), recip_lattice) - dist(counter) = NORM2(pos) + dist(counter) = SQRT(DOT_PRODUCT(pos, pos)) END DO END DO END DO @@ -776,8 +776,8 @@ CONTAINS DO loop_s = 1, num_shells DO loop_b = 1, multi(shell_list(loop_s)) delta = DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_b, loop_s))/ & - NORM2(bvector(:, loop_bn, cur_shell))* & - NORM2(bvector(:, loop_b, loop_s)) + SQRT(DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_bn, cur_shell))* & + DOT_PRODUCT(bvector(:, loop_b, loop_s), bvector(:, loop_b, loop_s))) IF (ABS(ABS(delta) - 1.0_dp) < eps6) lpar = .TRUE. END DO END DO @@ -871,7 +871,7 @@ CONTAINS IF (.NOT. b1sat) THEN IF (shell < search_shells .AND. iprint >= 3) THEN WRITE (stdout, '(1x,a,24x,a1)') '| B1 condition is not satisfied: Adding another shell', '|' - ELSE IF (shell == search_shells) THEN + ELSEIF (shell == search_shells) THEN WRITE (stdout, *) ' ' WRITE (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', search_shells, ' shells' WRITE (stdout, '(1x,a)') 'Your cell might be very long, or you may have an irregular MP grid' diff --git a/src/xas_methods.F b/src/xas_methods.F index f14f3915eb..8258506b41 100644 --- a/src/xas_methods.F +++ b/src/xas_methods.F @@ -316,7 +316,7 @@ CONTAINS WRITE (UNIT=output_unit, FMT="( A , I7, A, I7)") " The sub-set contains states from ", & qs_loc_env%localized_wfn_control%lu_bound_states(1, my_spin), " to ", & qs_loc_env%localized_wfn_control%lu_bound_states(2, my_spin) - ELSE IF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN + ELSEIF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN WRITE (UNIT=output_unit, FMT="( A )") " The sub-set contains states given in the input list" END IF @@ -431,9 +431,8 @@ CONTAINS CALL get_mo_set(mos(my_spin), nmo=nmo) CALL get_xas_env(xas_env, occ_estate=occ_estate, xas_nelectron=xas_nelectron) tmp = xas_nelectron + 1.0_dp - occ_estate - IF (nmo < tmp) THEN + IF (nmo < tmp) & CPABORT("CLS: the required method needs added_mos to the ground state") - END IF ! If the restart file for this atom exists, the mos and the ! occupation numbers are overwritten ! It is necessary that the restart is for the same xas method @@ -725,31 +724,31 @@ CONTAINS nele = REAL(nelectron, dp) - 0.5_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSE IF (xas_control%xas_method == xas_tp_xhh) THEN + ELSEIF (xas_control%xas_method == xas_tp_xhh) THEN occ_estate = 0.5_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 0.5_dp - ELSE IF (xas_control%xas_method == xas_tp_fh) THEN + ELSEIF (xas_control%xas_method == xas_tp_fh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) - 1.0_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSE IF (xas_control%xas_method == xas_tp_xfh) THEN + ELSEIF (xas_control%xas_method == xas_tp_xfh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSE IF (xas_control%xas_method == xes_tp_val) THEN + ELSEIF (xas_control%xas_method == xes_tp_val) THEN occ_estate = xas_control%xes_core_occupation nele = REAL(nelectron, dp) - xas_control%xes_core_occupation occ_homo = xas_control%xes_homo_occupation - ELSE IF (xas_control%xas_method == xas_dscf) THEN + ELSEIF (xas_control%xas_method == xas_dscf) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSE IF (xas_control%xas_method == xas_tp_flex) THEN + ELSEIF (xas_control%xas_method == xas_tp_flex) THEN nele = REAL(xas_control%nel_tot, dp) occ_estate = REAL(xas_control%xas_core_occupation, dp) IF (nele < 0.0_dp) nele = REAL(nelectron, dp) - (1.0_dp - occ_estate) @@ -858,7 +857,7 @@ CONTAINS "xas_env%ostrength_sm-"//TRIM(ADJUSTL(cp_to_string(i)))) CALL dbcsr_set(xas_env%ostrength_sm(i)%matrix, 0.0_dp) END DO - ELSE IF (xas_control%dipole_form == xas_dip_vel) THEN + ELSEIF (xas_control%dipole_form == xas_dip_vel) THEN ! ! prepare for allocation natom = SIZE(particle_set, 1) @@ -919,31 +918,31 @@ CONTAINS IF (xas_control%state_type == xas_1s_type) THEN nq(1) = 1 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_2s_type) THEN + ELSEIF (xas_control%state_type == xas_2s_type) THEN nq(1) = 2 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_2p_type) THEN + ELSEIF (xas_control%state_type == xas_2p_type) THEN nq(1) = 2 lq(1) = 1 - ELSE IF (xas_control%state_type == xas_3s_type) THEN + ELSEIF (xas_control%state_type == xas_3s_type) THEN nq(1) = 3 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_3p_type) THEN + ELSEIF (xas_control%state_type == xas_3p_type) THEN nq(1) = 3 lq(1) = 1 - ELSE IF (xas_control%state_type == xas_3d_type) THEN + ELSEIF (xas_control%state_type == xas_3d_type) THEN nq(1) = 3 lq(1) = 2 - ELSE IF (xas_control%state_type == xas_4s_type) THEN + ELSEIF (xas_control%state_type == xas_4s_type) THEN nq(1) = 4 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_4p_type) THEN + ELSEIF (xas_control%state_type == xas_4p_type) THEN nq(1) = 4 lq(1) = 1 - ELSE IF (xas_control%state_type == xas_4d_type) THEN + ELSEIF (xas_control%state_type == xas_4d_type) THEN nq(1) = 4 lq(1) = 2 - ELSE IF (xas_control%state_type == xas_4f_type) THEN + ELSEIF (xas_control%state_type == xas_4f_type) THEN nq(1) = 4 lq(1) = 3 ELSE @@ -1660,8 +1659,7 @@ CONTAINS END DO END IF - ! Scales down the 2d-array to the minimal size - CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) + CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) ! Scales down the 2d-array to the minimal size ELSE ! Manually selected orbital indices diff --git a/src/xas_restart.F b/src/xas_restart.F index 42864330d3..6ecc1dda59 100644 --- a/src/xas_restart.F +++ b/src/xas_restart.F @@ -183,14 +183,12 @@ CONTAINS READ (rst_unit) nexc_search_read, nexc_atoms_read, occ_estate_read, xas_nelectron_read READ (rst_unit) xas_estate_read - IF (xas_method_read /= xas_method) THEN + IF (xas_method_read /= xas_method) & CPABORT("READ XAS RESTART: restart with different XAS method is not possible.") - END IF - IF (nexc_atoms_read /= nexc_atoms) THEN + IF (nexc_atoms_read /= nexc_atoms) & CALL cp_abort(__LOCATION__, & "READ XAS RESTART: restart with different excited atoms "// & "is not possible. Start instead a new XAS run with the new set of atoms.") - END IF END IF CALL para_env%bcast(xas_estate_read) @@ -208,9 +206,8 @@ CONTAINS CALL cp_fm_set_all(mo_coeff, 0.0_dp) IF (para_env%is_source()) THEN READ (rst_unit) nao_read, nmo_read - IF (nao /= nao_read) THEN + IF (nao /= nao_read) & CPABORT("To change basis is not possible. ") - END IF ALLOCATE (eig_read(nmo_read), occ_read(nmo_read)) eig_read = 0.0_dp occ_read = 0.0_dp @@ -219,11 +216,10 @@ CONTAINS eigenvalues(1:nmo) = eig_read(1:nmo) occupation_numbers(1:nmo) = occ_read(1:nmo) IF (nmo_read > nmo) THEN - IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) THEN + IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) & CALL cp_warn(__LOCATION__, & "The number of occupied MOs on the restart unit is larger than "// & "the allocated MOs.") - END IF END IF DEALLOCATE (eig_read, occ_read) diff --git a/src/xas_tdp_atom.F b/src/xas_tdp_atom.F index faa3fe4633..87df1c0f2a 100644 --- a/src/xas_tdp_atom.F +++ b/src/xas_tdp_atom.F @@ -1186,7 +1186,7 @@ CONTAINS ! Point to the rho_set densities rhoa => rho_set%rhoa rhob => rho_set%rhob - rhoa = 0.0_dp; rhob = 0.0_dp + rhoa = 0.0_dp; rhob = 0.0_dp; IF (do_gga) THEN DO dir = 1, 3 rho_set%drhoa(dir)%array = 0.0_dp diff --git a/src/xas_tdp_correction.F b/src/xas_tdp_correction.F index 05fc8df3b9..91aa6cd919 100644 --- a/src/xas_tdp_correction.F +++ b/src/xas_tdp_correction.F @@ -1880,7 +1880,7 @@ CONTAINS !The SOC corrected KS eigenvalues ALLOCATE (tmp_shifts(ndo_mo, 2)) - ialpha = 1; ibeta = 1 + ialpha = 1; ibeta = 1; DO ido_mo = 1, ndo_so !need to find out whether the eigenvalue corresponds to an alpha or beta spin-orbtial alpha_tot_contrib = REAL(DOT_PRODUCT(evecs(1:ndo_mo, ido_mo), evecs(1:ndo_mo, ido_mo))) diff --git a/src/xas_tdp_kernel.F b/src/xas_tdp_kernel.F index 4c4890a407..8524077535 100644 --- a/src/xas_tdp_kernel.F +++ b/src/xas_tdp_kernel.F @@ -164,8 +164,7 @@ CONTAINS ! Broadcast the integrals to all procs (deleted after all donor states for this atoms are treated) lb = 1; IF (do_sf .AND. .NOT. do_sc) lb = 4 - ub = 2; IF (do_sc) ub = 3 - IF (do_sf) ub = 4 + ub = 2; IF (do_sc) ub = 3; IF (do_sf) ub = 4 DO i = lb, ub IF (.NOT. ASSOCIATED(xas_tdp_env%ri_fxc(ri_atom, i)%array)) THEN ALLOCATE (xas_tdp_env%ri_fxc(ri_atom, i)%array(nsgfp, nsgfp)) @@ -1369,9 +1368,9 @@ CONTAINS ! If on-diagonal quadrants only, can skip jso < iso IF (.NOT. quadrants(2) .AND. jso < iso) CYCLE - i = iso; j = jso + i = iso; j = jso; IF (my_mt) THEN - i = jso; j = iso + i = jso; j = iso; END IF ! Take the product lhs*rhs^T diff --git a/src/xas_tdp_methods.F b/src/xas_tdp_methods.F index 5383697020..4b35c3fb8c 100644 --- a/src/xas_tdp_methods.F +++ b/src/xas_tdp_methods.F @@ -800,9 +800,8 @@ CONTAINS IF (do_uks) nspins = 2 !in roks, same MOs for both spins ! by default, all (doubly occupied) homo are localized - IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) THEN + IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) & xas_tdp_control%n_search = MINVAL(homo) - END IF CALL qs_loc_control_init(qs_loc_env, loc_section, do_homo=.TRUE., do_xas=.TRUE., & nloc_xas=xas_tdp_control%n_search, spin_xas=1) @@ -2650,11 +2649,9 @@ CONTAINS DO ispin = 1, 2 CALL duplicate_mo_set(restart_mos(ispin), mos(1)) - ! Set the new occupation number in the case of spin-independent based calculation - ! since the restart is spin-depedent - IF (SIZE(mos) == 1) THEN + ! Set the new occupation number in the case of spin-independent based calculation since the restart is spin-depedent + IF (SIZE(mos) == 1) & restart_mos(ispin)%occupation_numbers = mos(1)%occupation_numbers/2 - END IF END DO CALL cp_fm_to_fm_submat(msource=lr_coeffs, mtarget=restart_mos(1)%mo_coeff, nrow=nao, & diff --git a/src/xas_tp_scf.F b/src/xas_tp_scf.F index 6ddd2c0d29..cfe95963c8 100644 --- a/src/xas_tp_scf.F +++ b/src/xas_tp_scf.F @@ -545,9 +545,8 @@ CONTAINS END IF END DO ! istate - IF (my_state == 0) THEN + IF (my_state == 0) & CPABORT("Could not identify the core state to be excited") - END IF xas_estate = my_state CALL get_mo_set(mos(my_spin), mo_coeff=mo_coeff) CALL cp_fm_get_submatrix(mo_coeff, vecbuffer, 1, xas_estate, & diff --git a/src/xc/xc.F b/src/xc/xc.F index d7c24f7e27..dde7ee5893 100644 --- a/src/xc/xc.F +++ b/src/xc/xc.F @@ -277,7 +277,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -312,7 +312,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -349,7 +349,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -378,7 +378,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -990,9 +990,8 @@ CONTAINS needs = xc_functionals_get_needs(xc_fun_section, lsd, .TRUE.) IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) THEN + IF (.NOT. ASSOCIATED(tau1_r)) & CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") - END IF ALLOCATE (v_xc_tau(nspins)) DO ispin = 1, nspins CALL pw_pool%create_pw(v_xc_tau(ispin)) @@ -2166,9 +2165,8 @@ CONTAINS END DO END IF - IF (laplace_f .AND. my_gapw) THEN + IF (laplace_f .AND. my_gapw) & CPABORT("Laplace-dependent functional not implemented with GAPW!") - END IF IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) CALL allocate_pw(virial_pw, pw_pool, bo) @@ -3418,7 +3416,8 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) tau => tau_r + IF (PRESENT(tau_r)) & + tau => tau_r IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, & @@ -3482,7 +3481,8 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) tau => tau_r + IF (PRESENT(tau_r)) & + tau => tau_r my_do_sf = .FALSE. IF (PRESENT(do_sf)) my_do_sf = do_sf @@ -3590,9 +3590,8 @@ CONTAINS CPABORT("Normalization of derivative requires any of norm_drhob or drhob!") END IF CASE (deriv_rho, deriv_tau, deriv_laplace_rho) - IF (lsd) THEN + IF (lsd) & CPABORT(TRIM(id_to_desc(split_desc(idesc)))//" not handled in lsd!'") - END IF CASE (deriv_rhoa, deriv_rhob, deriv_tau_a, deriv_tau_b, deriv_laplace_rhoa, deriv_laplace_rhob) CASE default CPABORT("Unknown derivative id") diff --git a/src/xc/xc_derivative_set_types.F b/src/xc/xc_derivative_set_types.F index 3c696c4fbe..a7227a7135 100644 --- a/src/xc/xc_derivative_set_types.F +++ b/src/xc/xc_derivative_set_types.F @@ -121,9 +121,8 @@ CONTAINS derivative_set%pw_pool => pw_pool CALL pw_pool%retain() IF (PRESENT(local_bounds)) THEN - IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) THEN + IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) & CPABORT("incompatible local_bounds and pw_pool") - END IF END IF ELSE !FM ugly hack, should be replaced by a pool only for 3d arrays diff --git a/src/xc/xc_derivatives.F b/src/xc/xc_derivatives.F index 16702c65f9..431bb25b6e 100644 --- a/src/xc/xc_derivatives.F +++ b/src/xc/xc_derivatives.F @@ -11,9 +11,7 @@ MODULE xc_derivatives USE input_section_types, ONLY: section_vals_get_subs_vals2,& section_vals_type,& section_vals_val_get - USE kinds, ONLY: default_string_length,& - dp - USE string_utilities, ONLY: uppercase + USE kinds, ONLY: dp USE xc_b97, ONLY: b97_lda_eval,& b97_lda_info,& b97_lsd_eval,& @@ -283,14 +281,9 @@ CONTAINS CALL pbe_lda_info(functional, reference, shortform, needs, max_deriv) END IF CASE ("GAUXC") - IF (gauxc_model_none_selected(functional)) THEN - CALL gauxc_model_none_xc_info(functional, lsd, reference, shortform, & - needs, max_deriv, print_warn) - ELSE - CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) - ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F - ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) - END IF + CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) + ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F + ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_info(reference, shortform, needs, max_deriv) @@ -514,11 +507,7 @@ CONTAINS CALL pbe_lda_eval(rho_set, deriv_set, deriv_order, functional) END IF CASE ("GAUXC") - IF (gauxc_model_none_selected(functional)) THEN - CALL gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) - ELSE - CPABORT(abort_message_skala) - END IF + CPABORT(abort_message_skala) CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_eval(rho_set, deriv_set, deriv_order, functional) @@ -563,155 +552,6 @@ CONTAINS CALL timestop(handle) END SUBROUTINE xc_functional_eval -! ************************************************************************************************** -!> \brief true for GAUXC sections that wrap a conventional LibXC functional -!> \param functional the GAUXC section -!> \return whether MODEL NONE is active -! ************************************************************************************************** - FUNCTION gauxc_model_none_selected(functional) - TYPE(section_vals_type), POINTER :: functional - LOGICAL :: gauxc_model_none_selected - - CHARACTER(LEN=default_string_length) :: model_key, model_name, xc_fun_name, & - xc_key - - CALL section_vals_val_get(functional, "MODEL", c_val=model_name) - CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) - model_key = ADJUSTL(model_name) - xc_key = ADJUSTL(xc_fun_name) - CALL uppercase(model_key) - CALL uppercase(xc_key) - gauxc_model_none_selected = (TRIM(model_key) == "" .OR. TRIM(model_key) == "NONE" .OR. & - TRIM(model_key) == TRIM(xc_key)) - END FUNCTION gauxc_model_none_selected - -! ************************************************************************************************** -!> \brief map GAUXC MODEL NONE shorthand names to LibXC exchange/correlation components -!> \param functional the GAUXC section -!> \param xc_fun_name the GAUXC FUNCTIONAL value -!> \param libxc_names LibXC section names to evaluate and add -!> \param nfunc number of LibXC components -! ************************************************************************************************** - SUBROUTINE gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) - TYPE(section_vals_type), POINTER :: functional - CHARACTER(LEN=*), INTENT(OUT) :: xc_fun_name - CHARACTER(LEN=*), DIMENSION(:), INTENT(OUT) :: libxc_names - INTEGER, INTENT(OUT) :: nfunc - - CHARACTER(LEN=default_string_length) :: xc_key - - CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) - xc_key = ADJUSTL(xc_fun_name) - CALL uppercase(xc_key) - libxc_names(:) = "" - SELECT CASE (TRIM(xc_key)) - CASE ("LDA", "PADE") - nfunc = 2 - libxc_names(1) = "LDA_X" - libxc_names(2) = "LDA_C_PW" - CASE ("VWN") - nfunc = 2 - libxc_names(1) = "LDA_X" - libxc_names(2) = "LDA_C_VWN" - CASE ("PBE") - nfunc = 2 - libxc_names(1) = "GGA_X_PBE" - libxc_names(2) = "GGA_C_PBE" - CASE ("BLYP") - nfunc = 2 - libxc_names(1) = "GGA_X_B88" - libxc_names(2) = "GGA_C_LYP" - CASE ("BP") - nfunc = 2 - libxc_names(1) = "GGA_X_B88" - libxc_names(2) = "GGA_C_P86" - CASE ("TPSS") - nfunc = 2 - libxc_names(1) = "MGGA_X_TPSS" - libxc_names(2) = "MGGA_C_TPSS" - CASE ("R2SCAN") - nfunc = 2 - libxc_names(1) = "MGGA_X_R2SCAN" - libxc_names(2) = "MGGA_C_R2SCAN" - CASE DEFAULT - nfunc = 1 - libxc_names(1) = TRIM(xc_key) - END SELECT - END SUBROUTINE gauxc_model_none_libxc_names - -! ************************************************************************************************** -!> \brief needs information for GAUXC MODEL NONE one-center GAPW corrections -!> \param functional the GAUXC section -!> \param lsd whether spin-polarized derivatives are needed -!> \param reference reference string for the wrapped functional -!> \param shortform short name for printout -!> \param needs density ingredients needed by the wrapped functional -!> \param max_deriv maximum implemented derivative order -!> \param print_warn whether LibXC should print development warnings -! ************************************************************************************************** - SUBROUTINE gauxc_model_none_xc_info(functional, lsd, reference, shortform, & - needs, max_deriv, print_warn) - TYPE(section_vals_type), POINTER :: functional - LOGICAL, INTENT(in) :: lsd - CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform - TYPE(xc_rho_cflags_type), INTENT(inout), OPTIONAL :: needs - INTEGER, INTENT(out), OPTIONAL :: max_deriv - LOGICAL, INTENT(IN), OPTIONAL :: print_warn - - CHARACTER(LEN=default_string_length) :: libxc_names(2), xc_fun_name - INTEGER :: ifunc, max_deriv_i, max_deriv_min, nfunc - - CALL gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) - max_deriv_min = HUGE(max_deriv_min) - DO ifunc = 1, nfunc - IF (lsd) THEN - CALL libxc_lsd_info(functional, needs=needs, max_deriv=max_deriv_i, & - print_warn=print_warn, & - func_name_override=TRIM(libxc_names(ifunc))) - ELSE - CALL libxc_lda_info(functional, needs=needs, max_deriv=max_deriv_i, & - print_warn=print_warn, & - func_name_override=TRIM(libxc_names(ifunc))) - END IF - max_deriv_min = MIN(max_deriv_min, max_deriv_i) - END DO - IF (PRESENT(max_deriv)) max_deriv = max_deriv_min - IF (PRESENT(reference)) THEN - reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" - END IF - IF (PRESENT(shortform)) shortform = "GAUXC ("//TRIM(xc_fun_name)//")" - END SUBROUTINE gauxc_model_none_xc_info - -! ************************************************************************************************** -!> \brief one-center GAPW correction evaluation for GAUXC MODEL NONE -!> \param functional the GAUXC section -!> \param lsd whether spin-polarized derivatives are evaluated -!> \param rho_set density ingredients -!> \param deriv_set derivative accumulator -!> \param deriv_order derivative order to evaluate -! ************************************************************************************************** - SUBROUTINE gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) - TYPE(section_vals_type), POINTER :: functional - LOGICAL, INTENT(in) :: lsd - TYPE(xc_rho_set_type), INTENT(IN) :: rho_set - TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set - INTEGER, INTENT(IN) :: deriv_order - - CHARACTER(LEN=default_string_length) :: libxc_names(2), xc_fun_name - INTEGER :: ifunc, nfunc - - CALL gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) - DO ifunc = 1, nfunc - IF (lsd) THEN - CALL libxc_lsd_eval(rho_set, deriv_set, deriv_order, functional, & - func_name_override=TRIM(libxc_names(ifunc))) - ELSE - CALL libxc_lda_eval(rho_set, deriv_set, deriv_order, functional, & - func_name_override=TRIM(libxc_names(ifunc))) - END IF - END DO - END SUBROUTINE gauxc_model_none_xc_eval - ! ************************************************************************************************** !> \brief ... !> \param functionals a section containing the functional combination to be diff --git a/src/xc/xc_functionals_utilities.F b/src/xc/xc_functionals_utilities.F index ac52974c52..933ead184a 100644 --- a/src/xc/xc_functionals_utilities.F +++ b/src/xc/xc_functionals_utilities.F @@ -259,20 +259,16 @@ CONTAINS IF (m >= 2) fx(ip, 3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(ip, 4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) THEN + IF (m >= 0) & fx(ip, 1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - END IF - IF (m >= 1) THEN + IF (m >= 1) & fx(ip, 2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - END IF - IF (m >= 2) THEN + IF (m >= 2) & fx(ip, 3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - END IF - IF (m >= 3) THEN + IF (m >= 3) & fx(ip, 4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) - END IF END IF END IF END DO @@ -318,20 +314,16 @@ CONTAINS IF (m >= 2) fx(3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) THEN + IF (m >= 0) & fx(1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - END IF - IF (m >= 1) THEN + IF (m >= 1) & fx(2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - END IF - IF (m >= 2) THEN + IF (m >= 2) & fx(3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - END IF - IF (m >= 3) THEN + IF (m >= 3) & fx(4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) - END IF END IF END IF diff --git a/src/xc/xc_gauxc_cache.F b/src/xc/xc_gauxc_cache.F deleted file mode 100644 index 0d83d432e7..0000000000 --- a/src/xc/xc_gauxc_cache.F +++ /dev/null @@ -1,475 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -#ifdef __GAUXC -#include "gauxc/gauxc_config.f" -#endif - -MODULE xc_gauxc_cache - - USE iso_c_binding, ONLY: c_double - USE kinds, ONLY: default_path_length,& - default_string_length - USE message_passing, ONLY: mp_comm_self,& - mp_para_env_type - USE particle_types, ONLY: particle_type - USE qs_kind_types, ONLY: qs_kind_type - USE xc_gauxc_interface, ONLY: & - cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & - cp_gauxc_molecule_type, cp_gauxc_status_type, gauxc_check_status, gauxc_create_basisset, & - gauxc_create_grid, gauxc_create_integrator, gauxc_create_molecule, gauxc_destroy_basisset, & - gauxc_destroy_grid, gauxc_destroy_integrator, gauxc_destroy_molecule -#include "../base/base_uses.f90" - - IMPLICIT NONE - PRIVATE - - TYPE cp_gauxc_cache_params - INTEGER :: natom = -1 - INTEGER :: nspins = -1 - INTEGER :: batch_size = -1 - REAL(c_double) :: device_runtime_fill_fraction = 0.0_c_double - CHARACTER(LEN=default_string_length) :: xc_fun_name = "" - CHARACTER(LEN=default_string_length) :: grid_type = "" - CHARACTER(LEN=default_string_length) :: radial_quadrature = "" - CHARACTER(LEN=default_string_length) :: pruning_scheme = "" - CHARACTER(LEN=default_string_length) :: lb_exec_space = "" - CHARACTER(LEN=default_string_length) :: int_exec_space = "" - CHARACTER(LEN=default_path_length) :: model_eval_name = "" - CHARACTER(len=default_string_length) :: lwd_kernel = "" - LOGICAL :: use_mpi_runtime = .FALSE. - LOGICAL :: use_gradient_mpi_runtime = .FALSE. - LOGICAL :: use_self_runtime = .FALSE. - LOGICAL :: use_gradient_self_runtime = .FALSE. - LOGICAL :: use_fd_gradient = .FALSE. - LOGICAL :: use_gauxc_model = .FALSE. - END TYPE cp_gauxc_cache_params - - TYPE, extends(cp_gauxc_cache_params) :: cp_gauxc_cache_type - TYPE(cp_gauxc_molecule_type) :: molecule = cp_gauxc_molecule_type() - TYPE(cp_gauxc_basisset_type) :: basisset = cp_gauxc_basisset_type() - TYPE(cp_gauxc_grid_type) :: grid = cp_gauxc_grid_type() - TYPE(cp_gauxc_grid_type) :: gradient_grid = cp_gauxc_grid_type() - TYPE(cp_gauxc_integrator_type) :: integrator = cp_gauxc_integrator_type() - TYPE(cp_gauxc_integrator_type) :: gradient_integrator = cp_gauxc_integrator_type() - INTEGER :: mpi_comm = -1 - LOGICAL :: is_init = .FALSE. - REAL(c_double), DIMENSION(:, :), ALLOCATABLE :: last_positions - CONTAINS - - PROCEDURE, PUBLIC :: needs_gradient_grid => gauxc_cache_type_needs_gradient_grid - PROCEDURE, PUBLIC :: max_l => gauxc_cache_type_max_l - END TYPE cp_gauxc_cache_type - - PUBLIC :: & - cp_gauxc_cache_type, & - gauxc_cache_init, & - gauxc_cache_is_valid, & - gauxc_cache_release, cp_gauxc_cache_params - -CONTAINS - -! ************************************************************************************************** -!> \brief ... -!> \param this ... -!> \return ... -! ************************************************************************************************** - FUNCTION gauxc_cache_type_needs_gradient_grid(this) RESULT(res) - class(cp_gauxc_cache_type) :: this - LOGICAL :: res - - res = this%use_gradient_self_runtime - END FUNCTION gauxc_cache_type_needs_gradient_grid - -! ************************************************************************************************** -!> \brief ... -!> \param this ... -!> \return ... -! ************************************************************************************************** - FUNCTION gauxc_cache_type_max_l(this) RESULT(res) - class(cp_gauxc_cache_type) :: this - INTEGER :: res - - res = this%basisset%max_l - END FUNCTION gauxc_cache_type_max_l - -! ************************************************************************************************** -!> \brief ... -!> \param cache ... -!> \param params ... -!> \param para_env ... -!> \param particle_set ... -!> \param qs_kind_set ... -!> \param status ... -! ************************************************************************************************** - SUBROUTINE gauxc_cache_init( & - cache, & - params, & - para_env, & - particle_set, & - qs_kind_set, & - status) - - TYPE(cp_gauxc_cache_type), INTENT(inout) :: cache - TYPE(cp_gauxc_cache_params), INTENT(inout) :: params - TYPE(mp_para_env_type), INTENT(in), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), INTENT(in), & - POINTER :: particle_set - TYPE(qs_kind_type), DIMENSION(:), INTENT(in), & - POINTER :: qs_kind_set - TYPE(cp_gauxc_status_type), INTENT(inout) :: status - -#ifdef __GAUXC - IF (gauxc_cache_is_valid( & - cache, & - params, & - para_env, & - particle_set)) THEN - status%status%code = 0 - RETURN - END IF - - CALL gauxc_cache_release(cache) - - cache%molecule = gauxc_create_molecule( & - particle_set, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_molecule() - RETURN - END IF - - cache%basisset = gauxc_create_basisset( & - qs_kind_set, & - particle_set, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_basisset() - RETURN - END IF - - params%use_fd_gradient = & - params%use_fd_gradient .AND. (cache%max_l() > 3) - params%use_gradient_mpi_runtime = & - params%use_gradient_mpi_runtime .AND. .NOT. params%use_fd_gradient - params%use_gradient_self_runtime = & - params%use_gradient_self_runtime .AND. .NOT. params%use_gradient_mpi_runtime - - IF (params%use_fd_gradient .AND. para_env%mepos == 0) THEN - CALL cp_warn( & - __LOCATION__, & - "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & - "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & - "not yet reliable for this case.") - END IF - IF (params%use_self_runtime .OR. .NOT. params%use_gauxc_model) THEN - ! SKALA currently needs a replicated molecular runtime for reproducible - ! open-shell densities across CP2K MPI ranks. - ! Conventional GauXC also uses a replicated runtime here: CP2K has - ! already allreduced the dense AO density matrix on every rank. - cache%grid = gauxc_create_grid( & - cache%molecule, & - cache%basisset, & - params%grid_type, & - params%radial_quadrature, & - params%pruning_scheme, & - params%lb_exec_space, & - params%batch_size, & - params%device_runtime_fill_fraction, & - status, & - mpi_comm=mp_comm_self%get_handle(), & - force_new_runtime=.TRUE.) - ELSE - ! Use the QS force-evaluation communicator rather than GauXC's global - ! runtime. In mixed CDFT the diabatic states can be built on disjoint - ! MPI subgroups; using the global communicator would make GauXC wait - ! for ranks that are working on another state. - cache%grid = gauxc_create_grid( & - cache%molecule, & - cache%basisset, & - params%grid_type, & - params%radial_quadrature, & - params%pruning_scheme, & - params%lb_exec_space, & - params%batch_size, & - params%device_runtime_fill_fraction, & - status, & - mpi_comm=para_env%get_handle()) - END IF - IF (status%status%code /= 0) THEN - CALL cleanup_after_grid() - RETURN - END IF - - cache%integrator = gauxc_create_integrator( & - TRIM(params%xc_fun_name), & - cache%grid, & - params%int_exec_space, & - params%lwd_kernel, & - params%nspins, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_integrator() - RETURN - END IF - - IF (params%use_gradient_self_runtime) THEN - ! Upstream GauXC does not yet support OneDFT/SKALA nuclear gradients - ! on an MPI runtime. Keep the energy/VXC path on the normal MPI - ! runtime and use an isolated runtime only for the replicated gradient. - cache%gradient_grid = gauxc_create_grid( & - cache%molecule, & - cache%basisset, & - params%grid_type, & - params%radial_quadrature, & - params%pruning_scheme, & - params%lb_exec_space, & - params%batch_size, & - params%device_runtime_fill_fraction, & - status, & - mpi_comm=mp_comm_self%get_handle(), & - force_new_runtime=.TRUE.) - IF (status%status%code /= 0) THEN - CALL cleanup_after_gradient_grid() - RETURN - END IF - cache%gradient_integrator = gauxc_create_integrator( & - TRIM(params%xc_fun_name), & - cache%gradient_grid, & - params%int_exec_space, & - params%lwd_kernel, & - params%nspins, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_gradient_integrator() - RETURN - END IF - END IF - - cache%natom = params%natom - cache%nspins = params%nspins - cache%batch_size = params%batch_size - cache%device_runtime_fill_fraction = REAL(params%device_runtime_fill_fraction, c_double) - cache%xc_fun_name = TRIM(params%xc_fun_name) - cache%grid_type = TRIM(params%grid_type) - cache%radial_quadrature = TRIM(params%radial_quadrature) - cache%pruning_scheme = TRIM(params%pruning_scheme) - cache%lb_exec_space = TRIM(params%lb_exec_space) - cache%int_exec_space = TRIM(params%int_exec_space) - cache%model_eval_name = TRIM(params%model_eval_name) - cache%lwd_kernel = TRIM(params%lwd_kernel) - cache%use_gradient_mpi_runtime = params%use_gradient_mpi_runtime - cache%use_mpi_runtime = params%use_mpi_runtime - cache%use_gradient_self_runtime = params%use_gradient_self_runtime - cache%use_self_runtime = params%use_self_runtime - cache%use_fd_gradient = params%use_fd_gradient - IF (ALLOCATED(cache%last_positions)) THEN - DEALLOCATE (cache%last_positions) - END IF - ALLOCATE (cache%last_positions(3, params%natom)) - - BLOCK - INTEGER :: iatom - DO iatom = 1, params%natom - cache%last_positions(:, iatom) = REAL(particle_set(iatom)%r(:), c_double) - END DO - END BLOCK - - cache%mpi_comm = para_env%get_handle() - cache%is_init = .TRUE. - -#else - MARK_USED(params) - MARK_USED(para_env) - MARK_USED(particle_set) - MARK_USED(qs_kind_set) - MARK_USED(status) - cache%is_init = .FALSE. -#endif - - CONTAINS -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_gradient_integrator() - CALL gauxc_destroy_integrator(cache%gradient_integrator, status) - CALL gauxc_check_status(status) - CALL cleanup_after_gradient_grid() - END SUBROUTINE cleanup_after_gradient_integrator - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_gradient_grid() - CALL gauxc_destroy_grid(cache%gradient_grid, status) - CALL gauxc_check_status(status) - CALL cleanup_after_integrator() - END SUBROUTINE cleanup_after_gradient_grid - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_integrator() - CALL gauxc_destroy_integrator(cache%integrator, status) - CALL gauxc_check_status(status) - CALL cleanup_after_grid() - END SUBROUTINE cleanup_after_integrator - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_grid() - CALL gauxc_destroy_grid(cache%grid, status) - CALL gauxc_check_status(status) - CALL cleanup_after_basisset() - END SUBROUTINE cleanup_after_grid - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_basisset() - CALL gauxc_destroy_basisset(cache%basisset, status) - CALL gauxc_check_status(status) - CALL cleanup_after_molecule() - END SUBROUTINE cleanup_after_basisset - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_molecule() - CALL gauxc_destroy_molecule(cache%molecule, status) - CALL gauxc_check_status(status) - CALL cleanup_final() - END SUBROUTINE cleanup_after_molecule - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_final() - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. - END SUBROUTINE cleanup_final - - END SUBROUTINE gauxc_cache_init - -! ************************************************************************************************** -!> \brief Release all GauXC objects in a cache and deallocate arrays -!> \param cache ... -! ************************************************************************************************** - SUBROUTINE gauxc_cache_release(cache) - TYPE(cp_gauxc_cache_type), INTENT(INOUT) :: cache - -#ifdef __GAUXC - TYPE(cp_gauxc_status_type) :: status - - IF (cache%is_init) THEN - IF (cache%needs_gradient_grid()) THEN - CALL gauxc_destroy_integrator(cache%gradient_integrator, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_grid(cache%gradient_grid, status) - CALL gauxc_check_status(status) - END IF - CALL gauxc_destroy_integrator(cache%integrator, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_grid(cache%grid, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_basisset(cache%basisset, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_molecule(cache%molecule, status) - CALL gauxc_check_status(status) - END IF - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. -#else - MARK_USED(cache) - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. -#endif - END SUBROUTINE gauxc_cache_release - -! ************************************************************************************************** -!> \brief Check if the GauXC cache is valid for the given parameters -!> \param cache ... -!> \param params ... -!> \param para_env ... -!> \param particle_set ... -!> \return ... -!> \retval cache_valid ... -! ************************************************************************************************** - FUNCTION gauxc_cache_is_valid( & - cache, & - params, & - para_env, & - particle_set) & - RESULT(cache_valid) - - TYPE(cp_gauxc_cache_type), INTENT(IN) :: cache - TYPE(cp_gauxc_cache_params), INTENT(in) :: params - TYPE(mp_para_env_type), INTENT(in), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - LOGICAL :: use_gradient_self_runtime, use_gradient_mpi_runtime, use_fd_gradient - LOGICAL :: cache_valid - -#ifdef __GAUXC - INTEGER :: iatom - REAL(c_double), PARAMETER :: pos_tol = 1.0E-8_c_double - - cache_valid = .FALSE. - IF (.NOT. cache%is_init) RETURN - IF (cache%natom /= params%natom) RETURN - IF (cache%nspins /= params%nspins) RETURN - IF (cache%batch_size /= params%batch_size) RETURN - IF (ABS(cache%device_runtime_fill_fraction - REAL(params%device_runtime_fill_fraction, c_double)) > & - 1.0E-10_c_double) RETURN - IF (TRIM(cache%xc_fun_name) /= TRIM(params%xc_fun_name)) RETURN - IF (TRIM(cache%grid_type) /= TRIM(params%grid_type)) RETURN - IF (TRIM(cache%radial_quadrature) /= TRIM(params%radial_quadrature)) RETURN - IF (TRIM(cache%pruning_scheme) /= TRIM(params%pruning_scheme)) RETURN - IF (TRIM(cache%lb_exec_space) /= TRIM(params%lb_exec_space)) RETURN - IF (TRIM(cache%int_exec_space) /= TRIM(params%int_exec_space)) RETURN - IF (TRIM(cache%model_eval_name) /= TRIM(params%model_eval_name)) RETURN - IF (TRIM(cache%lwd_kernel) /= TRIM(params%lwd_kernel)) RETURN - IF (cache%use_self_runtime .NEQV. params%use_self_runtime) RETURN - IF (cache%use_mpi_runtime .NEQV. params%use_mpi_runtime) RETURN - - ! These three are modified during cache init, so we must emulate these changes here - use_gradient_self_runtime = params%use_gradient_self_runtime - use_gradient_mpi_runtime = params%use_gradient_mpi_runtime - use_fd_gradient = params%use_fd_gradient - - use_fd_gradient = & - use_fd_gradient .AND. (cache%max_l() > 3) - use_gradient_mpi_runtime = & - use_gradient_mpi_runtime .AND. .NOT. use_fd_gradient - use_gradient_self_runtime = & - use_gradient_self_runtime .AND. .NOT. use_gradient_mpi_runtime - - IF (cache%use_gradient_mpi_runtime .NEQV. use_gradient_mpi_runtime) RETURN - IF (cache%use_fd_gradient .NEQV. use_fd_gradient) RETURN - IF (cache%use_gradient_self_runtime .NEQV. use_gradient_self_runtime) RETURN - IF (cache%mpi_comm /= para_env%get_handle()) RETURN - - IF (.NOT. ALLOCATED(cache%last_positions)) RETURN - IF (SIZE(cache%last_positions, 2) /= params%natom) RETURN - DO iatom = 1, params%natom - IF (ANY(ABS(cache%last_positions(:, iatom) - & - REAL(particle_set(iatom)%r(:), c_double)) > pos_tol)) RETURN - END DO - cache_valid = .TRUE. -#else - MARK_USED(cache) - MARK_USED(particle_set) - MARK_USED(params) - MARK_USED(use_gradient_self_runtime) - MARK_USED(use_gradient_mpi_runtime) - MARK_USED(use_fd_gradient) - MARK_USED(para_env) - cache_valid = .FALSE. -#endif - END FUNCTION gauxc_cache_is_valid - -END MODULE xc_gauxc_cache diff --git a/src/xc/xc_gauxc_functional.F b/src/xc/xc_gauxc_functional.F index 2a850d6def..3c12631d2f 100644 --- a/src/xc/xc_gauxc_functional.F +++ b/src/xc/xc_gauxc_functional.F @@ -49,9 +49,6 @@ MODULE xc_gauxc_functional qs_rho_type USE qs_scf_types, ONLY: qs_scf_env_type USE string_utilities, ONLY: uppercase - USE xc_gauxc_cache, ONLY: cp_gauxc_cache_params,& - cp_gauxc_cache_type,& - gauxc_cache_init USE xc_gauxc_interface, ONLY: & cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & cp_gauxc_molecule_type, cp_gauxc_status_type, cp_gauxc_xc_gradient_type, cp_gauxc_xc_type, & @@ -120,26 +117,24 @@ CONTAINS !> \brief ... !> \param dbcsr_mat ... !> \param dense_mat ... -!> \param para_env ... ! ************************************************************************************************** - SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat, para_env) - USE cp_dbcsr_api, ONLY: dbcsr_distribution_get, dbcsr_distribution_type, dbcsr_get_info, & - dbcsr_get_matrix_type, dbcsr_get_readonly_block_p, & - dbcsr_get_stored_coordinates, dbcsr_type_antisymmetric, & - dbcsr_type_symmetric + SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat) + USE cp_dbcsr_api, ONLY: dbcsr_get_info, dbcsr_get_matrix_type, dbcsr_iterator_type, & + dbcsr_iterator_start, dbcsr_iterator_next_block, dbcsr_iterator_blocks_left, & + dbcsr_iterator_stop, dbcsr_type_antisymmetric, dbcsr_type_symmetric TYPE(dbcsr_p_type), INTENT(IN) :: dbcsr_mat REAL(c_double), ALLOCATABLE, DIMENSION(:, :), & INTENT(INOUT) :: dense_mat - TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env CHARACTER :: matrix_type - INTEGER :: col, col_end, col_start, icol, irow, mynode, nblkcols_total, nblkrows_total, & - ncols, nrows, numnodes, owner, row, row_end, row_start + INTEGER :: col, col_end, col_start, icol, irow, & + nblkcols_total, nblkrows_total, ncols, & + nrows, row, row_end, row_start INTEGER, ALLOCATABLE, DIMENSION(:) :: c_offset, r_offset INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size - LOGICAL :: found + LOGICAL :: transposed REAL(c_double), POINTER :: block(:, :) - TYPE(dbcsr_distribution_type) :: dist + TYPE(dbcsr_iterator_type) :: iter CALL dbcsr_get_info(dbcsr_mat%matrix, & row_blk_size=row_blk_size, & @@ -147,9 +142,7 @@ CONTAINS nblkrows_total=nblkrows_total, & nblkcols_total=nblkcols_total, & nfullrows_total=nrows, & - nfullcols_total=ncols, & - distribution=dist) - CALL dbcsr_distribution_get(dist, mynode=mynode, numnodes=numnodes) + nfullcols_total=ncols) matrix_type = dbcsr_get_matrix_type(dbcsr_mat%matrix) IF (.NOT. ALLOCATED(dense_mat)) THEN @@ -173,19 +166,23 @@ CONTAINS c_offset(col) = c_offset(col - 1) + col_blk_size(col - 1) END DO - ! Replicated DBCSR blocks must enter the following MPI sum exactly once. - DO irow = 1, nblkrows_total - DO icol = 1, nblkcols_total - IF (numnodes == 1 .AND. para_env%num_pe > 1 .AND. para_env%mepos /= 0) CYCLE - CALL dbcsr_get_stored_coordinates(dbcsr_mat%matrix, irow, icol, owner) - IF (owner /= mynode) CYCLE - CALL dbcsr_get_readonly_block_p(matrix=dbcsr_mat%matrix, row=irow, col=icol, & - block=block, found=found) - IF (.NOT. found) CYCLE - row_start = r_offset(irow) - row_end = row_start + row_blk_size(irow) - 1 - col_start = c_offset(icol) - col_end = col_start + col_blk_size(icol) - 1 + CALL dbcsr_iterator_start(iter, dbcsr_mat%matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, irow, icol, block, transposed=transposed) + row_start = r_offset(irow) + row_end = row_start + row_blk_size(irow) - 1 + col_start = c_offset(icol) + col_end = col_start + col_blk_size(icol) - 1 + IF (transposed) THEN + dense_mat(row_start:row_end, col_start:col_end) = TRANSPOSE(block) + IF (irow /= icol) THEN + IF (matrix_type == dbcsr_type_symmetric) THEN + dense_mat(col_start:col_end, row_start:row_end) = block + ELSE IF (matrix_type == dbcsr_type_antisymmetric) THEN + dense_mat(col_start:col_end, row_start:row_end) = -block + END IF + END IF + ELSE dense_mat(row_start:row_end, col_start:col_end) = block IF (irow /= icol) THEN IF (matrix_type == dbcsr_type_symmetric) THEN @@ -194,8 +191,9 @@ CONTAINS dense_mat(col_start:col_end, row_start:row_end) = -TRANSPOSE(block) END IF END IF - END DO + END IF END DO + CALL dbcsr_iterator_stop(iter) DEALLOCATE (r_offset, c_offset) @@ -574,8 +572,7 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & gauxc_status, & - mpi_comm=mp_comm_self%get_handle(), & - force_new_runtime=.TRUE.) + mpi_comm=mp_comm_self%get_handle()) CALL gauxc_check_status(gauxc_status) gauxc_integrator_fd = gauxc_create_integrator( & TRIM(xc_fun_name), & @@ -898,36 +895,31 @@ CONTAINS INTEGER, INTENT(out), OPTIONAL :: max_deriv CHARACTER(len=default_path_length) :: model_key, model_name - CHARACTER(len=default_string_length) :: xc_fun_key, xc_fun_name + CHARACTER(len=default_string_length) :: xc_fun_name LOGICAL :: native_grid CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) CALL section_vals_val_get(functional, "MODEL", c_val=model_name) CALL section_vals_val_get(functional, "NATIVE_GRID", l_val=native_grid) model_key = ADJUSTL(model_name) - xc_fun_key = ADJUSTL(xc_fun_name) CALL uppercase(model_key) - CALL uppercase(xc_fun_key) IF (PRESENT(reference)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & - TRIM(model_key) == TRIM(xc_fun_key)) THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" ELSE reference = "Functional computed by GauXC Skala model "//TRIM(model_name) END IF END IF IF (PRESENT(shortform)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & - TRIM(model_key) == TRIM(xc_fun_key)) THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN shortform = "GAUXC ("//TRIM(xc_fun_name)//")" ELSE shortform = "GAUXC Skala" END IF END IF IF (PRESENT(needs)) THEN - IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "" .AND. & - TRIM(model_key) /= TRIM(xc_fun_key)) THEN + IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "") THEN IF (lsd) THEN needs%rho_spin = .TRUE. needs%drho_spin = .TRUE. @@ -969,21 +961,26 @@ CONTAINS REAL(KIND=dp), PARAMETER :: gapw_fd_gradient_dx = 1.0E-4_dp CHARACTER(len=default_path_length) :: model_key, model_name, output_path - CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, & - grid_key, pruning_key, skala_runtime, & - skala_runtime_key, xc_fun_key - INTEGER :: atom_chunk_size, env_status, img, ispin, & - nimages + CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, grid_key, & + grid_type, int_exec_space, lb_exec_space, lwd_kernel, pruning_key, pruning_scheme, & + radial_quadrature, skala_runtime, skala_runtime_key, xc_fun_name + INTEGER :: atom_chunk_size, batch_size, env_status, & + img, ispin, natom, nimages, nspins LOGICAL :: atom_chunk_size_explicit, do_kpoints, gapw_method, gapw_paw_pseudopotentials, & gapw_pseudopotentials, grid_explicit, hdf5_output, is_periodic, molecular_virial, & molecular_virial_debug, need_xc_gradient, periodic_reference, pruning_explicit, & - use_skala_model, write_hdf5_output - REAL(KIND=dp) :: molecular_virial_debug_dx + use_fd_gradient, use_gauxc_model, use_gradient_mpi_runtime, use_gradient_self_runtime, & + use_self_runtime, use_skala_model, write_hdf5_output + REAL(KIND=dp) :: device_runtime_fill_fraction, & + molecular_virial_debug_dx REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: density_scalar, density_zeta TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell - TYPE(cp_gauxc_cache_params) :: params - TYPE(cp_gauxc_cache_type), POINTER :: cache + TYPE(cp_gauxc_basisset_type) :: gauxc_basis + TYPE(cp_gauxc_grid_type) :: gauxc_gradient_grid_result, & + gauxc_grid_result + TYPE(cp_gauxc_integrator_type) :: gauxc_gradient_integrator_result, gauxc_integrator_result + TYPE(cp_gauxc_molecule_type) :: gauxc_mol TYPE(cp_gauxc_status_type) :: gauxc_status TYPE(cp_gauxc_xc_gradient_type) :: exc_grad TYPE(cp_gauxc_xc_type) :: gauxc_xc_result @@ -1026,7 +1023,7 @@ CONTAINS energy=energy, & ks_env=ks_env, & matrix_vxc=matrix_vxc, & - natom=params%natom, & + natom=natom, & atomic_kind_set=atomic_kind_set, & force=force, & para_env=para_env, & @@ -1053,7 +1050,7 @@ CONTAINS rho_ao_kp=rho_ao) nimages = dft_control%nimages - params%nspins = dft_control%nspins + nspins = dft_control%nspins is_periodic = .FALSE. IF (ASSOCIATED(cell)) is_periodic = ANY(cell%perd /= 0) @@ -1068,7 +1065,7 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "FUNCTIONAL", & - c_val=params%xc_fun_name) + c_val=xc_fun_name) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL", & @@ -1076,25 +1073,25 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "GRID", & - c_val=params%grid_type, & + c_val=grid_type, & explicit=grid_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "RADIAL_QUADRATURE", & - c_val=params%radial_quadrature) + c_val=radial_quadrature) CALL section_vals_val_get( & gauxc_functional_section, & "PRUNING_SCHEME", & - c_val=params%pruning_scheme, & + c_val=pruning_scheme, & explicit=pruning_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "BATCH_SIZE", & - i_val=params%batch_size) + i_val=batch_size) CALL section_vals_val_get( & gauxc_functional_section, & "DEVICE_RUNTIME_FILL_FRACTION", & - r_val=params%device_runtime_fill_fraction) + r_val=device_runtime_fill_fraction) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL_ATOM_CHUNK_SIZE", & @@ -1119,15 +1116,15 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "LB_EXECUTION_SPACE", & - c_val=params%lb_exec_space) + c_val=lb_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "INT_EXECUTION_SPACE", & - c_val=params%int_exec_space) + c_val=int_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "LWD_KERNEL", & - c_val=params%lwd_kernel) + c_val=lwd_kernel) CALL section_vals_val_get( & gauxc_functional_section, & "SKALA_RUNTIME", & @@ -1143,21 +1140,20 @@ CONTAINS model_key = ADJUSTL(model_name) CALL uppercase(model_key) - xc_fun_key = ADJUSTL(params%xc_fun_name) - CALL uppercase(xc_fun_key) skala_runtime_key = ADJUSTL(skala_runtime) CALL uppercase(skala_runtime_key) gradient_runtime_key = ADJUSTL(gradient_runtime) CALL uppercase(gradient_runtime_key) - params%use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & - TRIM(model_key) /= TRIM(xc_fun_key)) + use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") use_skala_model = (INDEX(TRIM(model_key), "SKALA") > 0) - params%model_eval_name = model_name - IF (.NOT. params%use_gauxc_model) THEN - ! MODEL NONE and MODEL equal to FUNCTIONAL select conventional GauXC. - params%model_eval_name = "NONE" + IF (gapw_pseudopotentials .AND. .NOT. use_gauxc_model) THEN + CALL cp_abort(__LOCATION__, & + "GauXC with METHOD GAPW/GAPW_XC and pseudopotentials is supported only for "// & + "Skala-style models that replace the molecular XC term. "// & + "Use POTENTIAL ALL for local/semi-local GauXC GAPW validation or METHOD GPW "// & + "with pseudopotentials.") END IF - IF (gapw_pseudopotentials .AND. params%use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & + IF (gapw_pseudopotentials .AND. use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & .NOT. gapw_paw_pseudopotentials .AND. para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1167,7 +1163,7 @@ CONTAINS "XC correction is used for those regular-grid kinds.") END IF END IF - IF (params%device_runtime_fill_fraction <= 0.0_dp .OR. params%device_runtime_fill_fraction > 1.0_dp) THEN + IF (device_runtime_fill_fraction <= 0.0_dp .OR. device_runtime_fill_fraction > 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "GAUXC%DEVICE_RUNTIME_FILL_FRACTION must be > 0 and <= 1.") END IF @@ -1195,21 +1191,21 @@ CONTAINS END IF END IF END IF - IF (params%use_gauxc_model) THEN + IF (use_gauxc_model) THEN IF (has_nlcc(qs_kind_set)) THEN CALL cp_abort(__LOCATION__, & "GauXC Skala with NLCC pseudopotentials is not implemented. "// & "The frozen core density would need a SKALA-consistent feature definition.") END IF END IF - IF (params%use_gauxc_model) THEN + IF (use_gauxc_model) THEN CALL set_gauxc_model_atom_chunk_env( & atom_chunk_size, atom_chunk_size_explicit) - IF (.NOT. grid_explicit) params%grid_type = "SUPERFINE" - IF (.NOT. pruning_explicit) params%pruning_scheme = "UNPRUNED" + IF (.NOT. grid_explicit) grid_type = "SUPERFINE" + IF (.NOT. pruning_explicit) pruning_scheme = "UNPRUNED" - grid_key = ADJUSTL(params%grid_type) - pruning_key = ADJUSTL(params%pruning_scheme) + grid_key = ADJUSTL(grid_type) + pruning_key = ADJUSTL(pruning_scheme) CALL uppercase(grid_key) CALL uppercase(pruning_key) IF (use_skala_model .AND. need_xc_gradient .AND. & @@ -1224,36 +1220,35 @@ CONTAINS IF (env_status /= 0 .OR. LEN_TRIM(model_name) == 0) THEN CPABORT("MODEL SKALA requires the GAUXC_SKALA_MODEL environment variable") END IF - params%model_eval_name = model_name END IF END IF SELECT CASE (TRIM(skala_runtime_key)) CASE ("AUTO") - params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. params%nspins > 1 + use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. nspins > 1 CASE ("MPI") - params%use_self_runtime = .FALSE. + use_self_runtime = .FALSE. CASE ("SELF") - params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 + use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%SKALA_RUNTIME value.") END SELECT - IF (.NOT. use_skala_model) params%use_self_runtime = .FALSE. + IF (.NOT. use_skala_model) use_self_runtime = .FALSE. SELECT CASE (TRIM(gradient_runtime_key)) CASE ("AUTO", "SELF") - params%use_gradient_mpi_runtime = .FALSE. - params%use_gradient_self_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. & - para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime + use_gradient_mpi_runtime = .FALSE. + use_gradient_self_runtime = need_xc_gradient .AND. use_gauxc_model .AND. & + para_env%num_pe > 1 .AND. .NOT. use_self_runtime CASE ("MPI") - params%use_gradient_mpi_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. para_env%num_pe > 1 - params%use_gradient_self_runtime = .FALSE. + use_gradient_mpi_runtime = need_xc_gradient .AND. use_gauxc_model .AND. para_env%num_pe > 1 + use_gradient_self_runtime = .FALSE. CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%MODEL_GRADIENT_RUNTIME value.") END SELECT - IF (.NOT. params%use_gauxc_model) THEN - params%use_gradient_mpi_runtime = .FALSE. - params%use_gradient_self_runtime = .FALSE. + IF (.NOT. use_gauxc_model) THEN + use_gradient_mpi_runtime = .FALSE. + use_gradient_self_runtime = .FALSE. END IF - IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime .AND. & + IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. use_self_runtime .AND. & para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1264,19 +1259,15 @@ CONTAINS END IF END IF - ! After creating the basisset, we will have to check max_l>3 as a further condition - params%use_fd_gradient = gapw_method .AND. need_xc_gradient - - IF (.NOT. ASSOCIATED(qs_env%gauxc_cache)) ALLOCATE (qs_env%gauxc_cache) - cache => qs_env%gauxc_cache - CALL gauxc_cache_init( & - cache, & - params, & - para_env, & - particle_set, & - qs_kind_set, & - gauxc_status) - + gauxc_mol = gauxc_create_molecule( & + particle_set, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) + gauxc_basis = gauxc_create_basisset( & + qs_kind_set, & + particle_set, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) hdf5_output = (TRIM(output_path) /= "") write_hdf5_output = hdf5_output .AND. para_env%mepos == 0 IF (write_hdf5_output .AND. ASSOCIATED(scf_env)) THEN @@ -1284,20 +1275,98 @@ CONTAINS END IF IF (write_hdf5_output) THEN CALL gauxc_write_molecule_hdf5( & - cache%molecule, & + gauxc_mol, & output_path, & "molecule.h5", & "molecule", & gauxc_status) CALL gauxc_check_status(gauxc_status) CALL gauxc_write_basisset_hdf5( & - cache%basisset, & + gauxc_basis, & output_path, & "basisset.h5", & "basisset", & gauxc_status) CALL gauxc_check_status(gauxc_status) END IF + use_fd_gradient = gapw_method .AND. need_xc_gradient .AND. (gauxc_basis%max_l > 3) + IF (use_fd_gradient) use_gradient_mpi_runtime = .FALSE. + IF (use_gradient_mpi_runtime) THEN + use_gradient_self_runtime = .FALSE. + END IF + IF (use_fd_gradient .AND. para_env%mepos == 0) THEN + CALL cp_warn( & + __LOCATION__, & + "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & + "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & + "not yet reliable for this case.") + END IF + IF (use_self_runtime) THEN + ! SKALA currently needs a replicated molecular runtime for reproducible + ! open-shell densities across CP2K MPI ranks. + gauxc_grid_result = gauxc_create_grid( & + gauxc_mol, & + gauxc_basis, & + grid_type, & + radial_quadrature, & + pruning_scheme, & + lb_exec_space, & + batch_size, & + device_runtime_fill_fraction, & + gauxc_status, & + mpi_comm=mp_comm_self%get_handle()) + ELSE + ! Use the QS force-evaluation communicator rather than GauXC's global + ! runtime. In mixed CDFT the diabatic states can be built on disjoint + ! MPI subgroups; using the global communicator would make GauXC wait + ! for ranks that are working on another state. + gauxc_grid_result = gauxc_create_grid( & + gauxc_mol, & + gauxc_basis, & + grid_type, & + radial_quadrature, & + pruning_scheme, & + lb_exec_space, & + batch_size, & + device_runtime_fill_fraction, & + gauxc_status, & + mpi_comm=para_env%get_handle()) + END IF + CALL gauxc_check_status(gauxc_status) + gauxc_integrator_result = gauxc_create_integrator( & + TRIM(xc_fun_name), & + gauxc_grid_result, & + int_exec_space, & + lwd_kernel, & + nspins, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) + + IF (use_gradient_self_runtime) THEN + ! Upstream GauXC does not yet support Skala nuclear gradients + ! on an MPI runtime. Keep the energy/VXC path on the normal MPI + ! runtime and use an isolated runtime only for the replicated gradient. + gauxc_gradient_grid_result = gauxc_create_grid( & + gauxc_mol, & + gauxc_basis, & + grid_type, & + radial_quadrature, & + pruning_scheme, & + lb_exec_space, & + batch_size, & + device_runtime_fill_fraction, & + gauxc_status, & + mpi_comm=mp_comm_self%get_handle()) + CALL gauxc_check_status(gauxc_status) + gauxc_gradient_integrator_result = gauxc_create_integrator( & + TRIM(xc_fun_name), & + gauxc_gradient_grid_result, & + int_exec_space, & + lwd_kernel, & + nspins, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) + END IF IF (qs_env%run_rtp) THEN CPABORT("GAUXC XC energy currently does not support real-time propagation") @@ -1306,46 +1375,46 @@ CONTAINS energy%exc = 0 IF (ASSOCIATED(matrix_vxc)) CALL dbcsr_deallocate_matrix_set(matrix_vxc) - CALL dbcsr_allocate_matrix_set(matrix_vxc, params%nspins) + CALL dbcsr_allocate_matrix_set(matrix_vxc, nspins) DO img = 1, nimages IF (img > 1) THEN CPABORT("UNIMPLEMENTED: Handling nimg>1 in k-point integration") END IF - CALL dbcsr_to_dense(rho_ao(1, img), density_scalar, para_env) + CALL dbcsr_to_dense(rho_ao(1, img), density_scalar) CALL para_env%sum(density_scalar) - IF (params%nspins == 1) THEN + IF (nspins == 1) THEN gauxc_xc_result = gauxc_compute_xc( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & - nspins=params%nspins, & + nspins=nspins, & status=gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (params%use_fd_gradient) THEN + IF (use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & - params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, nspins, model_name, & + xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad) - ELSE IF (params%use_gradient_self_runtime) THEN + ELSE IF (use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - cache%gradient_integrator, & + gauxc_gradient_integrator_result, & density_scalar, & - nspins=params%nspins, & - natom=params%natom, & + nspins=nspins, & + natom=natom, & status=gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & - nspins=params%nspins, & - natom=params%natom, & + nspins=nspins, & + natom=natom, & status=gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1360,19 +1429,19 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & - params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & + model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) END IF DEALLOCATE (exc_grad%exc_grad) END IF ELSE - CPASSERT(params%nspins == 2) + CPASSERT(nspins == 2) ! In here: ! scalar <- rho_ao(1, :) + rho_ao(2, :) ! zeta <- rho_ao(1, :) - rho_ao(2, :) - CALL dbcsr_to_dense(rho_ao(2, img), density_zeta, para_env) + CALL dbcsr_to_dense(rho_ao(2, img), density_zeta) CALL para_env%sum(density_zeta) ! Do NOT reorder the following lines! density_scalar(:, :) = density_scalar(:, :) + density_zeta(:, :) @@ -1382,39 +1451,39 @@ CONTAINS ! This style lowers memory footprint. density_zeta(:, :) = density_scalar(:, :) - 2.0_dp*density_zeta(:, :) gauxc_xc_result = gauxc_compute_xc( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & density_zeta, & - params%nspins, & + nspins, & gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (params%use_fd_gradient) THEN + IF (use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & - params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, nspins, model_name, & + xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad, density_zeta=density_zeta) - ELSE IF (params%use_gradient_self_runtime) THEN + ELSE IF (use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - cache%gradient_integrator, & + gauxc_gradient_integrator_result, & density_scalar, & density_zeta, & - params%nspins, & - params%natom, & + nspins, & + natom, & gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & density_zeta, & - params%nspins, & - params%natom, & + nspins, & + natom, & gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1429,10 +1498,10 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & - params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & + model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & density_zeta=density_zeta) END IF DEALLOCATE (exc_grad%exc_grad) @@ -1441,14 +1510,14 @@ CONTAINS energy%exc = energy%exc + gauxc_xc_result%exc - IF (params%nspins == 1) THEN + IF (nspins == 1) THEN IF (img == 1) THEN matrix_vxc(1) = dense_to_dbcsr(gauxc_xc_result%vxc_scalar, rho_ao(1, img)) ELSE CPABORT("UNIMPLEMENTED: Handling multiple result matrices in k-point integration") END IF ELSE - CPASSERT(params%nspins == 2) + CPASSERT(nspins == 2) ! Transform derivatives from total/spin density back to alpha/beta channels. vxc_zeta_tmp = dense_to_dbcsr(gauxc_xc_result%vxc_zeta, rho_ao(1, img)) IF (img == 1) THEN @@ -1475,10 +1544,25 @@ CONTAINS IF (ALLOCATED(gauxc_xc_result%vxc_zeta)) DEALLOCATE (gauxc_xc_result%vxc_zeta) CALL set_ks_env(ks_env, matrix_vxc=matrix_vxc) - DO ispin = 1, params%nspins + DO ispin = 1, nspins CALL dbcsr_finalize(matrix_vxc(ispin)%matrix) END DO + IF (use_gradient_self_runtime) THEN + CALL gauxc_destroy_integrator(gauxc_gradient_integrator_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_grid(gauxc_gradient_grid_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + END IF + CALL gauxc_destroy_integrator(gauxc_integrator_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_grid(gauxc_grid_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_basisset(gauxc_basis, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_molecule(gauxc_mol, gauxc_status) + CALL gauxc_check_status(gauxc_status) + END SUBROUTINE apply_gauxc END MODULE xc_gauxc_functional diff --git a/src/xc/xc_gauxc_interface.F b/src/xc/xc_gauxc_interface.F index e79a8fdd87..ed1356ebde 100644 --- a/src/xc/xc_gauxc_interface.F +++ b/src/xc/xc_gauxc_interface.F @@ -506,7 +506,6 @@ CONTAINS !> \param device_runtime_fill_fraction ... !> \param status ... !> \param mpi_comm optional communicator for a grid-local GauXC runtime -!> \param force_new_runtime force creation of a grid-local GauXC runtime !> \return ... ! ************************************************************************************************** FUNCTION gauxc_create_grid( & @@ -519,8 +518,7 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & status, & - mpi_comm, & - force_new_runtime) RESULT(res) + mpi_comm) RESULT(res) TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule TYPE(cp_gauxc_basisset_type), INTENT(in) :: basis @@ -530,14 +528,13 @@ CONTAINS REAL(c_double), INTENT(IN) :: device_runtime_fill_fraction TYPE(cp_gauxc_status_type), INTENT(OUT) :: status INTEGER, INTENT(IN), OPTIONAL :: mpi_comm - LOGICAL, INTENT(IN), OPTIONAL :: force_new_runtime TYPE(cp_gauxc_grid_type) :: res #ifdef __GAUXC INTEGER(c_int) :: grid_type_local, int_exec_space_local, & lb_exec_space_local, & pruning_scheme_local, radial_quad_local - LOGICAL :: force_new_runtime_local, use_device_runtime + LOGICAL :: use_device_runtime grid_type_local = read_atomic_grid_size(grid_type) radial_quad_local = read_radial_quad(radial_quadrature) @@ -545,8 +542,6 @@ CONTAINS lb_exec_space_local = read_execution_space(lb_exec_space) int_exec_space_local = read_execution_space("host") use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device) - force_new_runtime_local = .FALSE. - IF (PRESENT(force_new_runtime)) force_new_runtime_local = force_new_runtime res%owns_rt = .FALSE. IF (use_device_runtime) THEN @@ -575,8 +570,7 @@ CONTAINS IF (PRESENT(mpi_comm)) THEN ! Reuse the global runtime when the requested communicator matches ! the communicator used during gauxc_init. - IF (force_new_runtime_local .OR. .NOT. rt_has_mpi_comm .OR. & - mpi_comm /= rt_mpi_comm) THEN + IF (.NOT. rt_has_mpi_comm .OR. mpi_comm /= rt_mpi_comm) THEN res%rt = gauxc_runtime_environment_new(status%status, mpi_comm) GAUXC_RETURN_IF_ERROR(status) res%owns_rt = .TRUE. @@ -584,7 +578,6 @@ CONTAINS END IF #else MARK_USED(mpi_comm) - MARK_USED(force_new_runtime) #endif END IF @@ -644,7 +637,6 @@ CONTAINS MARK_USED(grid_type) MARK_USED(lb_exec_space) MARK_USED(mpi_comm) - MARK_USED(force_new_runtime) MARK_USED(molecule) MARK_USED(pruning_scheme) MARK_USED(radial_quadrature) diff --git a/src/xc/xc_libxc.F b/src/xc/xc_libxc.F index 6b0340a0bf..3faed929f3 100644 --- a/src/xc/xc_libxc.F +++ b/src/xc/xc_libxc.F @@ -307,11 +307,9 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & - func_name_override) + SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -319,7 +317,6 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -329,13 +326,8 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -406,7 +398,6 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & @@ -424,11 +415,9 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & - func_name_override) + SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -436,7 +425,6 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -446,13 +434,8 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -525,7 +508,6 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are "// & "asking for a functional of the LibXC library, "// & @@ -560,16 +542,14 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) + SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_eval' @@ -594,23 +574,15 @@ CONTAINS NULLIFY (dummy) NULLIFY (rho, norm_drho, laplace_rho, tau) - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_UNPOLARIZED) xc_info = xc_f03_func_get_info(xc_func) - no_exc = .FALSE. - IF (.NOT. PRESENT(func_name_override)) THEN - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) - END IF + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rho=rho, norm_drho=norm_drho, laplace_rho=laplace_rho, & @@ -790,7 +762,6 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & "you have to download and install the library!") @@ -806,16 +777,14 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) + SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_eval' @@ -854,23 +823,15 @@ CONTAINS NULLIFY (rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, laplace_rhoa, & laplace_rhob, tau_a, tau_b) - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_POLARIZED) xc_info = xc_f03_func_get_info(xc_func) - no_exc = .FALSE. - IF (.NOT. PRESENT(func_name_override)) THEN - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) - END IF + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, & @@ -1329,7 +1290,6 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & diff --git a/src/xc/xc_libxc_wrap.F b/src/xc/xc_libxc_wrap.F index e070d9f6f3..b8c0ed8962 100644 --- a/src/xc/xc_libxc_wrap.F +++ b/src/xc/xc_libxc_wrap.F @@ -105,10 +105,9 @@ MODULE xc_libxc_wrap section_release, & section_type, section_vals_type, section_vals_val_get #include "../base/base_uses.f90" -#endif + IMPLICIT NONE PRIVATE -#if defined (__LIBXC) CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xc_libxc_wrap' diff --git a/src/xc/xc_pade.F b/src/xc/xc_pade.F index 2a2b413b26..2be8e39fa3 100644 --- a/src/xc/xc_pade.F +++ b/src/xc/xc_pade.F @@ -118,9 +118,8 @@ CONTAINS END IF IF (PRESENT(needs)) THEN - IF (.NOT. PRESENT(lsd)) THEN + IF (.NOT. PRESENT(lsd)) & CPABORT("Arguments mismatch.") - END IF IF (lsd) THEN needs%rho_spin = .TRUE. ELSE diff --git a/src/xc/xc_perdew86.F b/src/xc/xc_perdew86.F index 559927a21e..386c1bd48e 100644 --- a/src/xc/xc_perdew86.F +++ b/src/xc/xc_perdew86.F @@ -36,6 +36,8 @@ MODULE xc_perdew86 PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_perdew_zunger.F b/src/xc/xc_perdew_zunger.F index c5870410fd..eede7b4efa 100644 --- a/src/xc/xc_perdew_zunger.F +++ b/src/xc/xc_perdew_zunger.F @@ -296,7 +296,7 @@ CONTAINS dummy => a e_0 => dummy - ea => dummy + ea => dummy; eaa => dummy; eab => dummy; ebb => dummy eaaa => dummy; eaab => dummy; eabb => dummy; ebbb => dummy diff --git a/src/xc/xc_rho_set_types.F b/src/xc/xc_rho_set_types.F index da711debed..f44aaf8ce4 100644 --- a/src/xc/xc_rho_set_types.F +++ b/src/xc/xc_rho_set_types.F @@ -620,9 +620,8 @@ CONTAINS do_sf = .FALSE. IF (PRESENT(spinflip)) do_sf = spinflip - IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) THEN + IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) & CPABORT("pw_pool cr3d have different size than expected") - END IF nspins = SIZE(rho_r) rho_set%local_bounds = rho_r(1)%pw_grid%bounds_local rho_cutoff = 0.5*rho_set%rho_cutoff diff --git a/src/xc/xc_tfw.F b/src/xc/xc_tfw.F index 57f1d74478..c46167a7d2 100644 --- a/src/xc/xc_tfw.F +++ b/src/xc/xc_tfw.F @@ -16,7 +16,6 @@ MODULE xc_tfw USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_norm_drho,& deriv_norm_drhoa,& deriv_norm_drhob,& @@ -38,6 +37,8 @@ MODULE xc_tfw PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_thomas_fermi.F b/src/xc/xc_thomas_fermi.F index 32584bd0ae..61765ad154 100644 --- a/src/xc/xc_thomas_fermi.F +++ b/src/xc/xc_thomas_fermi.F @@ -18,7 +18,6 @@ MODULE xc_thomas_fermi USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& deriv_rhob @@ -37,6 +36,8 @@ MODULE xc_thomas_fermi PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_vwn.F b/src/xc/xc_vwn.F index 29739a1179..528117d098 100644 --- a/src/xc/xc_vwn.F +++ b/src/xc/xc_vwn.F @@ -200,13 +200,13 @@ CONTAINS CALL xc_derivative_get(deriv, deriv_data=e_rho) CALL vwn_lda_01(rho, x, e_0, e_rho, npoints, sc) - ELSE IF (order >= 0) THEN + ELSEIF (order >= 0) THEN deriv => xc_dset_get_derivative(deriv_set, [INTEGER::], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_0) CALL vwn_lda_0(rho, x, e_0, npoints, sc) - ELSE IF (order == -1) THEN + ELSEIF (order == -1) THEN deriv => xc_dset_get_derivative(deriv_set, [deriv_rho], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_rho) diff --git a/src/xc/xc_xalpha.F b/src/xc/xc_xalpha.F index e9a0912979..8c260959e5 100644 --- a/src/xc/xc_xalpha.F +++ b/src/xc/xc_xalpha.F @@ -21,7 +21,6 @@ MODULE xc_xalpha USE input_section_types, ONLY: section_vals_type,& section_vals_val_get USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE pw_types, ONLY: pw_r3d_rs_type USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& @@ -41,6 +40,8 @@ MODULE xc_xalpha PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13 diff --git a/src/xc_adiabatic_utils.F b/src/xc_adiabatic_utils.F index f50f1f790a..7a304c6770 100644 --- a/src/xc_adiabatic_utils.F +++ b/src/xc_adiabatic_utils.F @@ -134,11 +134,10 @@ CONTAINS CASE (do_adiabatic_hybrid_mcy3) SELECT CASE (adiabatic_model) CASE (do_adiabatic_model_pade) - IF (n_rep_hf /= 2) THEN + IF (n_rep_hf /= 2) & CALL cp_abort(__LOCATION__, & "For this kind of adiababatic hybrid functional 2 HF sections have to be provided. "// & "Please check your input file.") - END IF CALL rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & adiabatic_omega, scale_dEx1, scale_ddW0, scale_dDFA, & scale_dEx2, total_energy_xc) diff --git a/src/xc_pot_saop.F b/src/xc_pot_saop.F index 2034fd550c..186d29c5d6 100644 --- a/src/xc_pot_saop.F +++ b/src/xc_pot_saop.F @@ -855,35 +855,29 @@ CONTAINS IF (lsd) THEN DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) THEN + IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) & vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rhoa(ia, ir, 1) - END IF - IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) THEN + IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) & vxc_GLLB_h(ia, ir, 2) = vxc_GLLB_h(ia, ir, 2) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 2)/rho_set_h%rhob(ia, ir, 1) - END IF - IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) THEN + IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) & vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rhoa(ia, ir, 1) - END IF - IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) THEN + IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) & vxc_GLLB_s(ia, ir, 2) = vxc_GLLB_s(ia, ir, 2) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 2)/rho_set_s%rhob(ia, ir, 1) - END IF END DO END DO ELSE DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) THEN + IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) & vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rho(ia, ir, 1) - END IF - IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) THEN + IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) & vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rho(ia, ir, 1) - END IF END DO END DO END IF diff --git a/src/xtb_coulomb.F b/src/xtb_coulomb.F index 16de64133a..f079817d9b 100644 --- a/src/xtb_coulomb.F +++ b/src/xtb_coulomb.F @@ -73,7 +73,6 @@ MODULE xtb_coulomb sap_int_type USE virial_methods, ONLY: virial_pair_force USE virial_types, ONLY: virial_type - USE xtb_spinpol, ONLY: build_xtb_spinpol USE xtb_types, ONLY: get_xtb_atom_param,& xtb_atom_type #include "./base/base_uses.f90" @@ -645,12 +644,6 @@ CONTAINS DEALLOCATE (zeffk, xgamma) END IF - IF (xtb_control%do_spinpol) THEN - CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - CALL build_xtb_spinpol(qs_env, ks_matrix, matrix_p, energy, & - sap_int, calculate_forces, just_energy) - END IF - ! QMMM IF (qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CALL build_tb_coulomb_qmqm(qs_env, ks_matrix, rho, mcharge, energy, & @@ -716,7 +709,7 @@ CONTAINS IF (rab < 1.e-6_dp) THEN ! on site terms gmat(:, :) = eta(:, :) - ELSE IF (rab > rcut) THEN + ELSEIF (rab > rcut) THEN ! do nothing ELSE rk = rab**kg @@ -784,7 +777,7 @@ CONTAINS IF (rab < 1.e-6) THEN ! on site terms dgmat(:, :) = 0.0_dp - ELSE IF (rab > rcut) THEN + ELSEIF (rab > rcut) THEN dgmat(:, :) = 0.0_dp ELSE eta = eta**(-kg) diff --git a/src/xtb_ehess.F b/src/xtb_ehess.F index 8eb7a0a5af..a7c1f17cdf 100644 --- a/src/xtb_ehess.F +++ b/src/xtb_ehess.F @@ -51,7 +51,6 @@ MODULE xtb_ehess neighbor_list_set_p_type USE virial_types, ONLY: virial_type USE xtb_coulomb, ONLY: gamma_rab_sr - USE xtb_spinpol, ONLY: xtb_spinpol_hessian USE xtb_types, ONLY: get_xtb_atom_param,& xtb_atom_type #include "./base/base_uses.f90" @@ -73,15 +72,13 @@ CONTAINS !> \param charges1 ... !> \param mcharge1 ... !> \param mcharge ... -!> \param matrix_p1 ... ! ************************************************************************************************** - SUBROUTINE xtb_coulomb_hessian(qs_env, ks_matrix, charges1, mcharge1, mcharge, matrix_p1) + SUBROUTINE xtb_coulomb_hessian(qs_env, ks_matrix, charges1, mcharge1, mcharge) TYPE(qs_environment_type), POINTER :: qs_env TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: ks_matrix REAL(dp), DIMENSION(:, :) :: charges1 REAL(dp), DIMENSION(:) :: mcharge1, mcharge - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_p1 CHARACTER(len=*), PARAMETER :: routineN = 'xtb_coulomb_hessian' @@ -287,10 +284,6 @@ CONTAINS DEALLOCATE (xgamma) END IF - IF (xtb_control%do_spinpol) THEN - CALL xtb_spinpol_hessian(qs_env, ks_matrix, matrix_p1) - END IF - IF (qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CPABORT("QMMM not available in xTB response calculations") END IF diff --git a/src/xtb_ehess_force.F b/src/xtb_ehess_force.F index c9926ca9f0..84e17a8887 100644 --- a/src/xtb_ehess_force.F +++ b/src/xtb_ehess_force.F @@ -54,7 +54,6 @@ MODULE xtb_ehess_force USE virial_types, ONLY: virial_type USE xtb_coulomb, ONLY: dgamma_rab_sr,& gamma_rab_sr - USE xtb_spinpol, ONLY: xtb_spinpol_hforce USE xtb_types, ONLY: get_xtb_atom_param,& xtb_atom_type #include "./base/base_uses.f90" @@ -437,18 +436,6 @@ CONTAINS alpha_scalar=1.0_dp, beta_scalar=-1.0_dp) END IF - IF (xtb_control%do_spinpol) THEN - IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1) - ! - CALL xtb_spinpol_hforce(qs_env, matrix_p0, matrix_p1) - ! - IF (debug_forces) THEN - fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3) - CALL para_env%sum(fodeb) - IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pz*Hspin[P] ", fodeb - END IF - END IF - ! QMMM IF (qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CPABORT("Not Available") diff --git a/src/xtb_hcore.F b/src/xtb_hcore.F index 8b7565eb05..0e182950b3 100644 --- a/src/xtb_hcore.F +++ b/src/xtb_hcore.F @@ -156,7 +156,7 @@ CONTAINS CALL get_atomic_kind(atomic_kind_set(ikind), z=za) IF (metal(za)) THEN kcnlk(0:3, ikind) = 0.0_dp - ELSE IF (early3d(za)) THEN + ELSEIF (early3d(za)) THEN kcnlk(0, ikind) = kcns kcnlk(1, ikind) = kcnp kcnlk(2, ikind) = 0.005_dp @@ -278,7 +278,7 @@ CONTAINS ELSE km = km*kdiff END IF - ELSE IF (zb == 1 .AND. nb == 2) THEN + ELSEIF (zb == 1 .AND. nb == 2) THEN km = km*kdiff END IF kijab(i, j, ikind, jkind) = km diff --git a/src/xtb_ks_matrix.F b/src/xtb_ks_matrix.F index cf71f9b96c..527f5f20b0 100644 --- a/src/xtb_ks_matrix.F +++ b/src/xtb_ks_matrix.F @@ -190,10 +190,9 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge equilibration energy: ", energy%eeq, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF + "Correction for nonbonded interactions: ", energy%xtb_nonbonded IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield @@ -431,9 +430,8 @@ CONTAINS energy%qmmm_el = energy%qmmm_el + pc_ener END IF - energy%total = energy%core + energy%repulsive + & - energy%hartree + energy%xtb_spinpol + energy%efield + & - energy%qmmm_el + energy%dispersion + energy%dftb3 + energy%kTS + energy%total = energy%core + energy%hartree + energy%efield + energy%qmmm_el + & + energy%repulsive + energy%dispersion + energy%dftb3 + energy%kTS iounit = cp_print_key_unit_nr(logger, scf_section, "PRINT%DETAILED_ENERGY", & extension=".scfLog") @@ -443,18 +441,12 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge fluctuation energy: ", energy%hartree, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_spinpol) THEN + IF (dft_control%qs_control%xtb_control%xb_interaction) & WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Spin polarisation correction: ", energy%xtb_spinpol - END IF - IF (dft_control%qs_control%xtb_control%xb_interaction) THEN + "Correction for halogen bonding: ", energy%xtb_xb_inter + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - END IF - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN - WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF + "Correction for nonbonded interactions: ", energy%xtb_nonbonded IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield diff --git a/src/xtb_parameters.F b/src/xtb_parameters.F index 5d0f343518..0c79a46c19 100644 --- a/src/xtb_parameters.F +++ b/src/xtb_parameters.F @@ -69,11 +69,9 @@ MODULE xtb_parameters 0.98_dp, 1.57_dp, 2.04_dp, 2.55_dp, 3.04_dp, 3.44_dp, 3.98_dp, 4.50_dp, & ! 10 0.93_dp, 1.31_dp, 1.61_dp, 1.90_dp, 2.19_dp, 2.58_dp, 3.16_dp, 3.50_dp, & ! 18 0.82_dp, 1.00_dp, 1.36_dp, 1.54_dp, 1.63_dp, 1.66_dp, 1.55_dp, 1.83_dp, & - 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, & - 2.96_dp, 3.00_dp, & ! 36 + 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, 2.96_dp, 3.00_dp, & ! 36 0.82_dp, 0.95_dp, 1.22_dp, 1.33_dp, 1.60_dp, 2.16_dp, 1.90_dp, 2.20_dp, & - 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, & - 2.66_dp, 2.60_dp, & ! 54 + 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, 2.66_dp, 2.60_dp, & ! 54 0.79_dp, 0.89_dp, 1.10_dp, & 1.12_dp, 1.13_dp, 1.14_dp, 1.15_dp, 1.17_dp, 1.18_dp, 1.20_dp, 1.21_dp, & 1.22_dp, 1.23_dp, 1.24_dp, 1.25_dp, 1.26_dp, 1.27_dp, & ! Lanthanides @@ -118,11 +116,9 @@ MODULE xtb_parameters 1.30_dp, 0.99_dp, 0.84_dp, 0.75_dp, 0.71_dp, 0.64_dp, 0.60_dp, 0.62_dp, & ! 10 1.60_dp, 1.40_dp, 1.24_dp, 1.14_dp, 1.09_dp, 1.04_dp, 1.00_dp, 1.01_dp, & ! 18 2.00_dp, 1.74_dp, 1.59_dp, 1.48_dp, 1.44_dp, 1.30_dp, 1.29_dp, 1.24_dp, & - 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, & - 1.17_dp, 1.16_dp, & ! 36 + 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, 1.17_dp, 1.16_dp, & ! 36 2.15_dp, 1.90_dp, 1.76_dp, 1.64_dp, 1.56_dp, 1.46_dp, 1.38_dp, 1.36_dp, & - 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, & - 1.36_dp, 1.36_dp, & ! 54 + 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, 1.36_dp, 1.36_dp, & ! 54 2.38_dp, 2.06_dp, 1.94_dp, & 1.84_dp, 1.90_dp, 1.88_dp, 1.86_dp, 1.85_dp, 1.83_dp, 1.82_dp, 1.81_dp, & 1.80_dp, 1.79_dp, 1.77_dp, 1.77_dp, 1.78_dp, 1.74_dp, & ! Lanthanides @@ -142,11 +138,9 @@ MODULE xtb_parameters 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 10 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 18 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 1.25_dp, 1.00_dp, & ! 36 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 36 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 1.25_dp, 1.00_dp, & ! 54 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 54 1.05_dp, 2.05_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & ! Lanthanides @@ -165,7 +159,6 @@ MODULE xtb_parameters ! *** Public data types *** PUBLIC :: xtb_parameters_init, xtb_parameters_set, init_xtb_basis, xtb_set_kab - PUBLIC :: xtb_spinpol_init, xtb_spinpol_ext PUBLIC :: metal, early3d, pp_gfn0 CONTAINS @@ -469,112 +462,6 @@ CONTAINS END SUBROUTINE xtb1_parameters_init -! ************************************************************************************************** -!> \brief ... -!> \param param ... -!> \param gfn_type ... -!> \param element_symbol ... -!> \param parameter_file_path ... -!> \param spinpol_param_file_name ... -!> \param para_env ... -! ************************************************************************************************** - SUBROUTINE xtb_spinpol_init(param, gfn_type, element_symbol, parameter_file_path, spinpol_param_file_name, & - para_env) - - TYPE(xtb_atom_type), POINTER :: param - INTEGER, INTENT(IN) :: gfn_type - CHARACTER(LEN=2), INTENT(IN) :: element_symbol - CHARACTER(LEN=*), INTENT(IN) :: parameter_file_path, & - spinpol_param_file_name - TYPE(mp_para_env_type), POINTER :: para_env - - CHARACTER(len=default_string_length) :: filename - INTEGER :: zin, znum - LOGICAL :: at_end - TYPE(cp_parser_type) :: parser - - SELECT CASE (gfn_type) - CASE (0) - CPABORT("gfn_type = 0: No spin polarisation possible!") - CASE (1) - ! OK - CASE (2) - CPABORT("gfn_type = 2 not yet supported") - CASE DEFAULT - CPABORT("Wrong gfn_type") - END SELECT - - filename = ADJUSTL(TRIM(parameter_file_path))//ADJUSTL(TRIM(spinpol_param_file_name)) - CALL parser_create(parser, filename, apply_preprocessing=.FALSE., para_env=para_env) - znum = 0 - param%wall = 0.0_dp - CALL get_ptable_info(element_symbol, znum) - DO - at_end = .FALSE. - CALL parser_get_next_line(parser, 1, at_end) - IF (at_end) EXIT - CALL parser_get_object(parser, zin) - IF (zin == znum) THEN - CALL parser_get_object(parser, param%wall(1, 1)) - CALL parser_get_object(parser, param%wall(1, 2)) - CALL parser_get_object(parser, param%wall(2, 2)) - CALL parser_get_object(parser, param%wall(1, 3)) - CALL parser_get_object(parser, param%wall(2, 3)) - CALL parser_get_object(parser, param%wall(3, 3)) - param%wall(2, 1) = param%wall(1, 2) - param%wall(3, 1) = param%wall(1, 3) - param%wall(3, 2) = param%wall(2, 3) - END IF - END DO - CALL parser_release(parser) - - END SUBROUTINE xtb_spinpol_init - -! ************************************************************************************************** -!> \brief ... -!> \param param ... -!> \param gfn_type ... -!> \param xtb_control ... -! ************************************************************************************************** - SUBROUTINE xtb_spinpol_ext(param, gfn_type, xtb_control) - TYPE(xtb_atom_type), POINTER :: param - INTEGER, INTENT(IN) :: gfn_type - TYPE(xtb_control_type), INTENT(IN), POINTER :: xtb_control - - INTEGER :: i - - SELECT CASE (gfn_type) - CASE (0) - CPABORT("gfn_type = 0: No spin polarisation possible!") - CASE (1) - ! OK - CASE (2) - CPABORT("gfn_type = 2 not yet supported") - CASE DEFAULT - CPABORT("Wrong gfn_type") - END SELECT - - IF (param%defined) THEN - IF (ASSOCIATED(xtb_control%spinpol_type)) THEN - DO i = 1, SIZE(xtb_control%spinpol_type) - IF (xtb_control%spinpol_type(i) == param%z) THEN - param%wall(1, 1) = xtb_control%spinpol_vals(1, i) - param%wall(1, 2) = xtb_control%spinpol_vals(2, i) - param%wall(2, 2) = xtb_control%spinpol_vals(3, i) - param%wall(1, 3) = xtb_control%spinpol_vals(4, i) - param%wall(2, 3) = xtb_control%spinpol_vals(5, i) - param%wall(3, 3) = xtb_control%spinpol_vals(6, i) - param%wall(2, 1) = param%wall(1, 2) - param%wall(3, 1) = param%wall(1, 3) - param%wall(3, 2) = param%wall(2, 3) - EXIT - END IF - END DO - END IF - END IF - - END SUBROUTINE xtb_spinpol_ext - ! ************************************************************************************************** !> \brief Read atom parameters for xTB Hamiltonian from input file !> \param param ... @@ -759,14 +646,14 @@ CONTAINS CASE (78) kab = 0.80_dp END SELECT - ELSE IF (za == 5 .OR. zb == 5) THEN + ELSEIF (za == 5 .OR. zb == 5) THEN ! Boron z = za + zb - 5 SELECT CASE (z) CASE (15) kab = 0.97_dp END SELECT - ELSE IF (za == 7 .OR. zb == 7) THEN + ELSEIF (za == 7 .OR. zb == 7) THEN ! Nitrogen z = za + zb - 7 SELECT CASE (z) @@ -775,21 +662,21 @@ CONTAINS ! in the paper this is Kab for B-Si kab = 1.01_dp END SELECT - ELSE IF (za > 20 .AND. za < 30) THEN + ELSEIF (za > 20 .AND. za < 30) THEN ! 3d IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 1.10_dp - ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 0.50_dp*(1.20_dp + 1.10_dp) END IF - ELSE IF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN + ELSEIF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN ! 4d/5d/4f IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 0.50_dp*(1.20_dp + 1.10_dp) - ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 1.20_dp END IF diff --git a/src/xtb_potentials.F b/src/xtb_potentials.F index 07dab22561..36028812aa 100644 --- a/src/xtb_potentials.F +++ b/src/xtb_potentials.F @@ -807,11 +807,10 @@ CONTAINS ((name_atm_a) == (nonbonded%pot(ingp)%pot%at2)))) THEN CALL pair_potential_single_copy(nonbonded%pot(ingp)%pot, pot) ! multiple potential not implemented, simply overwriting - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") - END IF !IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. END IF diff --git a/src/xtb_spinpol.F b/src/xtb_spinpol.F deleted file mode 100644 index 3d0afdec70..0000000000 --- a/src/xtb_spinpol.F +++ /dev/null @@ -1,871 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief Calculation of Spin Polarisation contributions in xTB -!> \author JGH -! ************************************************************************************************** -MODULE xtb_spinpol - USE atomic_kind_types, ONLY: atomic_kind_type,& - get_atomic_kind,& - get_atomic_kind_set - USE atprop_types, ONLY: atprop_type - USE bibliography, ONLY: Neugebauer2023,& - cite_reference - USE cell_types, ONLY: cell_type - USE cp_control_types, ONLY: dft_control_type - USE cp_dbcsr_api, ONLY: dbcsr_get_block_p,& - dbcsr_iterator_blocks_left,& - dbcsr_iterator_next_block,& - dbcsr_iterator_start,& - dbcsr_iterator_stop,& - dbcsr_iterator_type,& - dbcsr_p_type,& - dbcsr_type - USE kinds, ONLY: dp - USE kpoint_types, ONLY: get_kpoint_info,& - kpoint_type - USE message_passing, ONLY: mp_para_env_type - USE mulliken, ONLY: ao_charges - USE particle_types, ONLY: particle_type - USE qs_energy_types, ONLY: qs_energy_type - USE qs_environment_types, ONLY: get_qs_env,& - qs_environment_type - USE qs_force_types, ONLY: qs_force_type - USE qs_kind_types, ONLY: get_qs_kind,& - get_qs_kind_set,& - qs_kind_type - USE qs_neighbor_list_types, ONLY: get_iterator_info,& - neighbor_list_iterate,& - neighbor_list_iterator_create,& - neighbor_list_iterator_p_type,& - neighbor_list_iterator_release,& - neighbor_list_set_p_type - USE sap_kind_types, ONLY: sap_int_type - USE virial_methods, ONLY: virial_pair_force - USE virial_types, ONLY: virial_type - USE xtb_types, ONLY: get_xtb_atom_param,& - xtb_atom_type -#include "./base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xtb_spinpol' - - PUBLIC :: build_xtb_spinpol, xtb_spinpol_hessian, xtb_spinpol_hforce - -CONTAINS - -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param ks_matrix ... -!> \param matrix_p ... -!> \param energy ... -!> \param sap_int ... -!> \param calculate_forces ... -!> \param just_energy ... -! ************************************************************************************************** - SUBROUTINE build_xtb_spinpol(qs_env, ks_matrix, matrix_p, energy, & - sap_int, calculate_forces, just_energy) - - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix, matrix_p - TYPE(qs_energy_type), POINTER :: energy - TYPE(sap_int_type), DIMENSION(:), POINTER :: sap_int - LOGICAL, INTENT(in) :: calculate_forces, just_energy - - CHARACTER(len=*), PARAMETER :: routineN = 'build_xtb_spinpol' - - INTEGER :: atom_a, atom_i, atom_j, handle, i, ia, iac, iatom, ib, ic, icol, ikind, iknd, & - irow, jatom, jkind, jknd, la, lb, na, natom, natorb, nb, nimg, nkind, nsgf, nspins - INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of - INTEGER, DIMENSION(25) :: lao - INTEGER, DIMENSION(3) :: cellind - INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - LOGICAL :: defined, found, use_virial - REAL(KIND=dp) :: dr, espin, fi, fval - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: docg - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: aocg, bocg, pam, pbm, wab - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: wabk - REAL(KIND=dp), DIMENSION(3) :: fij, rij - REAL(KIND=dp), DIMENSION(3, 3) :: wall - REAL(KIND=dp), DIMENSION(:, :), POINTER :: aksb, bksb, dsblock, pamat, pbmat, sblock - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsint - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(atprop_type), POINTER :: atprop - TYPE(cell_type), POINTER :: cell - TYPE(dbcsr_iterator_type) :: iter - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: p_matrix - TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_p_kp, matrix_s, matrix_s_kp - TYPE(dbcsr_type), POINTER :: s_matrix - TYPE(dft_control_type), POINTER :: dft_control - TYPE(kpoint_type), POINTER :: kpoints - TYPE(mp_para_env_type), POINTER :: para_env - TYPE(neighbor_list_iterator_p_type), & - DIMENSION(:), POINTER :: nl_iterator - TYPE(neighbor_list_set_p_type), DIMENSION(:), & - POINTER :: n_list - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - TYPE(qs_force_type), DIMENSION(:), POINTER :: force - TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set - TYPE(virial_type), POINTER :: virial - TYPE(xtb_atom_type), POINTER :: xtb_kind - - CALL timeset(routineN, handle) - - energy%xtb_spinpol = 0.0_dp - - CALL get_qs_env(qs_env, dft_control=dft_control) - nspins = dft_control%nspins - nimg = dft_control%nimages - - IF (nspins == 2) THEN - - CALL cite_reference(Neugebauer2023) - - CALL get_qs_env(qs_env, & - qs_kind_set=qs_kind_set, & - particle_set=particle_set, & - atomic_kind_set=atomic_kind_set, & - cell=cell, & - virial=virial, & - atprop=atprop) - - CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & - kind_of=kind_of, & - atom_of_kind=atom_of_kind) - - use_virial = .FALSE. - IF (calculate_forces) THEN - use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) - END IF - - CALL get_qs_env(qs_env, nkind=nkind, natom=natom) - CALL get_qs_kind_set(qs_kind_set, maxsgf=nsgf) - CALL get_qs_env(qs_env, matrix_s_kp=matrix_s, para_env=para_env) - - ! expand parameters - ALLOCATE (wabk(nsgf, nsgf, nkind)) - wabk = 0.0_dp - DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) - CALL get_xtb_atom_param(xtb_kind, natorb=natorb, lao=lao, wall=wall) - DO ia = 1, natorb - la = lao(ia) + 1 - DO ib = 1, natorb - lb = lao(ib) + 1 - wabk(ia, ib, ikind) = wall(la, lb) - END DO - END DO - END DO - - ! Calculate charges - ALLOCATE (aocg(nsgf, natom), bocg(nsgf, natom)) - aocg = 0.0_dp - bocg = 0.0_dp - IF (nimg > 1) THEN - matrix_s_kp => matrix_s(:, :) - matrix_p_kp => matrix_p(1:1, :) - CALL ao_charges(matrix_p_kp, matrix_s_kp, aocg, para_env) - matrix_p_kp => matrix_p(2:2, :) - CALL ao_charges(matrix_p_kp, matrix_s_kp, bocg, para_env) - ELSE - s_matrix => matrix_s(1, 1)%matrix - p_matrix => matrix_p(1:1, 1) - CALL ao_charges(p_matrix, s_matrix, aocg, para_env) - p_matrix => matrix_p(2:2, 1) - CALL ao_charges(p_matrix, s_matrix, bocg, para_env) - END IF - - ! calculate energy - DO ikind = 1, nkind - CALL get_atomic_kind(atomic_kind_set(ikind), natom=na) - CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) - CALL get_xtb_atom_param(xtb_kind, defined=defined, natorb=natorb) - IF (.NOT. defined .OR. natorb < 1) CYCLE - ALLOCATE (docg(natorb), wab(natorb, natorb)) - wab(1:natorb, 1:natorb) = wabk(1:natorb, 1:natorb, ikind) - DO iatom = 1, na - atom_a = atomic_kind_set(ikind)%atom_list(iatom) - docg = 0.0_dp - docg(1:natorb) = aocg(1:natorb, atom_a) - bocg(1:natorb, atom_a) - espin = 0.5_dp*DOT_PRODUCT(docg, MATMUL(wab, docg)) - energy%xtb_spinpol = energy%xtb_spinpol + espin - IF (atprop%energy) THEN - atprop%atecoul(iatom) = atprop%atecoul(iatom) + espin - END IF - END DO - DEALLOCATE (docg, wab) - END DO - - ! Forces and Virial - IF (calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env, force=force) - NULLIFY (cell_to_index) - IF (nimg > 1) THEN - NULLIFY (kpoints) - CALL get_qs_env(qs_env=qs_env, kpoints=kpoints) - CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) - END IF - IF (nimg == 1) THEN - ! no k-points; all matrices have been transformed to periodic bsf - CALL dbcsr_iterator_start(iter, matrix_s(1, 1)%matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) - ikind = kind_of(irow) - atom_i = atom_of_kind(irow) - jkind = kind_of(icol) - atom_j = atom_of_kind(icol) - - CALL dbcsr_get_block_p(matrix=matrix_p(1, 1)%matrix, & - row=irow, col=icol, block=pamat, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=matrix_p(2, 1)%matrix, & - row=irow, col=icol, block=pbmat, found=found) - CPASSERT(found) - - na = SIZE(pamat, 1) - nb = SIZE(pamat, 2) - - DO i = 1, 3 - CALL dbcsr_get_block_p(matrix=matrix_s(1 + i, 1)%matrix, & - row=irow, col=icol, block=dsblock, found=found) - CPASSERT(found) - - CALL fupdate(fi, pamat, pbmat, dsblock, na, nb, & - wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & - aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) - - force(ikind)%rho_elec(i, atom_i) = force(ikind)%rho_elec(i, atom_i) + fi - force(jkind)%rho_elec(i, atom_j) = force(jkind)%rho_elec(i, atom_j) - fi - END DO - - END DO - CALL dbcsr_iterator_stop(iter) - ! use dsint list - IF (use_virial .AND. 0 == 0) THEN - CPASSERT(ASSOCIATED(sap_int)) - DO ikind = 1, nkind - DO jkind = 1, nkind - iac = ikind + nkind*(jkind - 1) - IF (.NOT. ASSOCIATED(sap_int(iac)%alist)) CYCLE - DO ia = 1, sap_int(iac)%nalist - IF (.NOT. ASSOCIATED(sap_int(iac)%alist(ia)%clist)) CYCLE - iatom = sap_int(iac)%alist(ia)%aatom - DO ic = 1, sap_int(iac)%alist(ia)%nclist - jatom = sap_int(iac)%alist(ia)%clist(ic)%catom - rij = sap_int(iac)%alist(ia)%clist(ic)%rac - dr = SQRT(SUM(rij(:)**2)) - IF (dr > 1.e-6_dp) THEN - dsint => sap_int(iac)%alist(ia)%clist(ic)%acint - icol = MAX(iatom, jatom) - irow = MIN(iatom, jatom) - CALL dbcsr_get_block_p(matrix=matrix_p(1, 1)%matrix, & - row=irow, col=icol, block=pamat, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=matrix_p(2, 1)%matrix, & - row=irow, col=icol, block=pbmat, found=found) - CPASSERT(found) - IF (irow == iatom) THEN - na = SIZE(pamat, 1) - nb = SIZE(pamat, 2) - ALLOCATE (pam(na, nb), pbm(na, nb)) - pam(1:na, 1:nb) = pamat(1:na, 1:nb) - pbm(1:na, 1:nb) = pbmat(1:na, 1:nb) - ELSE - na = SIZE(pamat, 2) - nb = SIZE(pamat, 1) - ALLOCATE (pam(na, nb), pbm(na, nb)) - pam(1:na, 1:nb) = TRANSPOSE(pamat(1:nb, 1:na)) - pbm(1:na, 1:nb) = TRANSPOSE(pbmat(1:nb, 1:na)) - END IF - - DO i = 1, 3 - CALL fupdate(fi, pam, pbm, dsint(:, :, i), na, nb, & - wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & - aocg(1:na, iatom), aocg(1:nb, jatom), & - bocg(1:na, iatom), bocg(1:nb, jatom)) - fij(i) = fi - END DO - fi = 1.0_dp - IF (iatom == jatom) fi = 0.5_dp - CALL virial_pair_force(virial%pv_virial, fi, fij, rij) - DEALLOCATE (pam, pbm) - - END IF - END DO - END DO - END DO - END DO - END IF - ELSE - NULLIFY (n_list) - CALL get_qs_env(qs_env=qs_env, sab_orb=n_list) - CALL neighbor_list_iterator_create(nl_iterator, n_list) - DO WHILE (neighbor_list_iterate(nl_iterator) == 0) - CALL get_iterator_info(nl_iterator, ikind=ikind, jkind=jkind, & - iatom=iatom, jatom=jatom, r=rij, cell=cellind) - - dr = SQRT(SUM(rij**2)) - IF (iatom == jatom .AND. dr < 1.0e-6_dp) CYCLE - - icol = MAX(iatom, jatom) - irow = MIN(iatom, jatom) - - ic = cell_to_index(cellind(1), cellind(2), cellind(3)) - CPASSERT(ic > 0) - - IF (irow == iatom) THEN - iknd = ikind - jknd = jkind - atom_i = atom_of_kind(iatom) - atom_j = atom_of_kind(jatom) - rij = rij - ELSE - iknd = jkind - jknd = ikind - atom_i = atom_of_kind(jatom) - atom_j = atom_of_kind(iatom) - rij = -rij - END IF - ! - CALL dbcsr_get_block_p(matrix=matrix_p(1, ic)%matrix, & - row=irow, col=icol, block=pamat, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=matrix_p(2, ic)%matrix, & - row=irow, col=icol, block=pbmat, found=found) - CPASSERT(found) - - na = SIZE(pamat, 1) - nb = SIZE(pamat, 2) - - fij = 0.0_dp - DO i = 1, 3 - CALL dbcsr_get_block_p(matrix=matrix_s(1 + i, ic)%matrix, & - row=irow, col=icol, block=dsblock, found=found) - CPASSERT(found) - - CALL fupdate(fi, pamat, pbmat, dsblock, na, nb, & - wabk(1:na, 1:na, iknd), wabk(1:nb, 1:nb, jknd), & - aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) - - force(iknd)%rho_elec(i, atom_i) = force(iknd)%rho_elec(i, atom_i) + fi - force(jknd)%rho_elec(i, atom_j) = force(jknd)%rho_elec(i, atom_j) - fi - fij(i) = fi - END DO - IF (use_virial) THEN - fi = 1.0_dp - IF (iatom == jatom) fi = 0.5_dp - CALL virial_pair_force(virial%pv_virial, fi, fij, rij) - END IF - - END DO - CALL neighbor_list_iterator_release(nl_iterator) - - END IF - END IF - - ! KS matrix - IF (.NOT. just_energy) THEN - IF (nimg > 1) THEN - CALL get_qs_env(qs_env=qs_env, kpoints=kpoints) - CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) - END IF - IF (nimg == 1) THEN - ! no k-points; all matrices have been transformed to periodic bsf - CALL dbcsr_iterator_start(iter, matrix_s(1, 1)%matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) - CALL dbcsr_get_block_p(matrix=ks_matrix(1, 1)%matrix, & - row=irow, col=icol, block=aksb, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=ks_matrix(2, 1)%matrix, & - row=irow, col=icol, block=bksb, found=found) - CPASSERT(found) - na = SIZE(aksb, 1) - nb = SIZE(aksb, 2) - ikind = kind_of(irow) - jkind = kind_of(icol) - fval = 0.5_dp - CALL ksupdate(aksb, bksb, sblock, na, nb, fval, & - wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & - aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) - END DO - CALL dbcsr_iterator_stop(iter) - ELSE - CALL get_qs_env(qs_env=qs_env, sab_orb=n_list) - CALL neighbor_list_iterator_create(nl_iterator, n_list) - DO WHILE (neighbor_list_iterate(nl_iterator) == 0) - CALL get_iterator_info(nl_iterator, ikind=ikind, jkind=jkind, & - iatom=iatom, jatom=jatom, r=rij, cell=cellind) - - icol = MAX(iatom, jatom) - irow = MIN(iatom, jatom) - - ic = cell_to_index(cellind(1), cellind(2), cellind(3)) - CPASSERT(ic > 0) - - ikind = kind_of(irow) - jkind = kind_of(icol) - - CALL dbcsr_get_block_p(matrix=matrix_s(1, ic)%matrix, & - row=irow, col=icol, block=sblock, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=ks_matrix(1, ic)%matrix, & - row=irow, col=icol, block=aksb, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=ks_matrix(2, ic)%matrix, & - row=irow, col=icol, block=bksb, found=found) - CPASSERT(found) - - na = SIZE(aksb, 1) - nb = SIZE(aksb, 2) - fval = 0.5_dp - CALL ksupdate(aksb, bksb, sblock, na, nb, fval, & - wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & - aocg(1:na, irow), aocg(1:nb, icol), bocg(1:na, irow), bocg(1:nb, icol)) - END DO - CALL neighbor_list_iterator_release(nl_iterator) - END IF - - END IF - - DEALLOCATE (wabk) - DEALLOCATE (aocg, bocg) - END IF - - CALL timestop(handle) - - END SUBROUTINE build_xtb_spinpol - -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param ks_matrix ... -!> \param matrix_p1 ... -! ************************************************************************************************** - SUBROUTINE xtb_spinpol_hessian(qs_env, ks_matrix, matrix_p1) - - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: ks_matrix, matrix_p1 - - CHARACTER(len=*), PARAMETER :: routineN = 'xtb_spinpol_hessian' - - INTEGER :: handle, ia, ib, icol, ikind, irow, & - jkind, la, lb, na, natom, natorb, nb, & - nimg, nkind, nsgf, nspins - INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of - INTEGER, DIMENSION(25) :: lao - LOGICAL :: found - REAL(KIND=dp) :: fval - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: aocg1, bocg1 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: wabk - REAL(KIND=dp), DIMENSION(3, 3) :: wall - REAL(KIND=dp), DIMENSION(:, :), POINTER :: aksb, bksb, sblock - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(dbcsr_iterator_type) :: iter - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: p_matrix - TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_s - TYPE(dbcsr_type), POINTER :: s_matrix - TYPE(dft_control_type), POINTER :: dft_control - TYPE(mp_para_env_type), POINTER :: para_env - TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set - TYPE(xtb_atom_type), POINTER :: xtb_kind - - CALL timeset(routineN, handle) - - CALL get_qs_env(qs_env, dft_control=dft_control) - nspins = dft_control%nspins - nimg = dft_control%nimages - - IF (nimg /= 1) THEN - CPABORT("No kpoints allowed in xTB response calculation") - END IF - - IF (nspins == 2) THEN - - CALL get_qs_env(qs_env, & - qs_kind_set=qs_kind_set, & - atomic_kind_set=atomic_kind_set) - - CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of) - - CALL get_qs_env(qs_env, nkind=nkind, natom=natom) - CALL get_qs_kind_set(qs_kind_set, maxsgf=nsgf) - CALL get_qs_env(qs_env, matrix_s_kp=matrix_s, para_env=para_env) - - ! expand parameters - ALLOCATE (wabk(nsgf, nsgf, nkind)) - wabk = 0.0_dp - DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) - CALL get_xtb_atom_param(xtb_kind, natorb=natorb, lao=lao, wall=wall) - DO ia = 1, natorb - la = lao(ia) + 1 - DO ib = 1, natorb - lb = lao(ib) + 1 - wabk(ia, ib, ikind) = wall(la, lb) - END DO - END DO - END DO - - ! Calculate response charges - ALLOCATE (aocg1(nsgf, natom), bocg1(nsgf, natom)) - aocg1 = 0.0_dp - bocg1 = 0.0_dp - s_matrix => matrix_s(1, 1)%matrix - p_matrix => matrix_p1(1:1) - CALL ao_charges(p_matrix, s_matrix, aocg1, para_env) - p_matrix => matrix_p1(2:2) - CALL ao_charges(p_matrix, s_matrix, bocg1, para_env) - aocg1 = 0.5_dp*aocg1 - bocg1 = 0.5_dp*bocg1 - - CALL dbcsr_iterator_start(iter, s_matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) - CALL dbcsr_get_block_p(matrix=ks_matrix(1)%matrix, & - row=irow, col=icol, block=aksb, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=ks_matrix(2)%matrix, & - row=irow, col=icol, block=bksb, found=found) - CPASSERT(found) - na = SIZE(aksb, 1) - nb = SIZE(aksb, 2) - ikind = kind_of(irow) - jkind = kind_of(icol) - fval = 1.00_dp - CALL ksupdate(aksb, bksb, sblock, na, nb, fval, & - wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & - aocg1(1:na, irow), aocg1(1:nb, icol), & - bocg1(1:na, irow), bocg1(1:nb, icol)) - END DO - CALL dbcsr_iterator_stop(iter) - - DEALLOCATE (wabk) - DEALLOCATE (aocg1, bocg1) - END IF - - CALL timestop(handle) - - END SUBROUTINE xtb_spinpol_hessian - -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param matrix_p0 ... -!> \param matrix_p1 ... -! ************************************************************************************************** - SUBROUTINE xtb_spinpol_hforce(qs_env, matrix_p0, matrix_p1) - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_p0, matrix_p1 - - CHARACTER(len=*), PARAMETER :: routineN = 'xtb_spinpol_hforce' - - INTEGER :: atom_i, atom_j, handle, i, ia, ib, icol, & - ikind, irow, jkind, la, lb, na, natom, & - natorb, nb, nimg, nkind, nsgf, nspins - INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of - INTEGER, DIMENSION(25) :: lao - LOGICAL :: found - REAL(KIND=dp) :: fi - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: aocg, aocg1, bocg, bocg1 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: wabk - REAL(KIND=dp), DIMENSION(3, 3) :: wall - REAL(KIND=dp), DIMENSION(:, :), POINTER :: dsblock, p0amat, p0bmat, p1amat, p1bmat, & - sblock - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(dbcsr_iterator_type) :: iter - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, p_matrix - TYPE(dbcsr_type), POINTER :: s_matrix - TYPE(dft_control_type), POINTER :: dft_control - TYPE(mp_para_env_type), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - TYPE(qs_force_type), DIMENSION(:), POINTER :: force - TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set - TYPE(xtb_atom_type), POINTER :: xtb_kind - - CALL timeset(routineN, handle) - - CALL get_qs_env(qs_env, dft_control=dft_control) - nspins = dft_control%nspins - nimg = dft_control%nimages - IF (nimg /= 1) THEN - CPABORT("xTB response forces for spin polarisation Hamiltonian not available") - END IF - - IF (nspins == 2) THEN - - CALL get_qs_env(qs_env, & - qs_kind_set=qs_kind_set, & - particle_set=particle_set, & - atomic_kind_set=atomic_kind_set) - - CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & - kind_of=kind_of, & - atom_of_kind=atom_of_kind) - - CALL get_qs_env(qs_env, nkind=nkind, natom=natom) - CALL get_qs_kind_set(qs_kind_set, maxsgf=nsgf) - - CALL get_qs_env(qs_env, matrix_s=matrix_s, para_env=para_env) - - ! expand parameters - ALLOCATE (wabk(nsgf, nsgf, nkind)) - wabk = 0.0_dp - DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) - CALL get_xtb_atom_param(xtb_kind, natorb=natorb, lao=lao, wall=wall) - DO ia = 1, natorb - la = lao(ia) + 1 - DO ib = 1, natorb - lb = lao(ib) + 1 - wabk(ia, ib, ikind) = wall(la, lb) - END DO - END DO - END DO - - ! Calculate charges - s_matrix => matrix_s(1)%matrix - ALLOCATE (aocg(nsgf, natom), bocg(nsgf, natom)) - aocg = 0.0_dp - bocg = 0.0_dp - p_matrix => matrix_p0(1:1) - CALL ao_charges(p_matrix, s_matrix, aocg, para_env) - p_matrix => matrix_p0(2:2) - CALL ao_charges(p_matrix, s_matrix, bocg, para_env) - ! Calculate response charges - ALLOCATE (aocg1(nsgf, natom), bocg1(nsgf, natom)) - aocg1 = 0.0_dp - bocg1 = 0.0_dp - p_matrix => matrix_p1(1:1) - CALL ao_charges(p_matrix, s_matrix, aocg1, para_env) - p_matrix => matrix_p1(2:2) - CALL ao_charges(p_matrix, s_matrix, bocg1, para_env) - aocg1 = 0.5_dp*aocg1 - bocg1 = 0.5_dp*bocg1 - - ! calculate forces - CALL get_qs_env(qs_env=qs_env, force=force) - ! no k-points; all matrices have been transformed to periodic bsf - CALL dbcsr_iterator_start(iter, s_matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, irow, icol, sblock) - ikind = kind_of(irow) - atom_i = atom_of_kind(irow) - jkind = kind_of(icol) - atom_j = atom_of_kind(icol) - - CALL dbcsr_get_block_p(matrix=matrix_p0(1)%matrix, & - row=irow, col=icol, block=p0amat, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=matrix_p0(2)%matrix, & - row=irow, col=icol, block=p0bmat, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=matrix_p1(1)%matrix, & - row=irow, col=icol, block=p1amat, found=found) - CPASSERT(found) - CALL dbcsr_get_block_p(matrix=matrix_p1(2)%matrix, & - row=irow, col=icol, block=p1bmat, found=found) - CPASSERT(found) - - na = SIZE(p0amat, 1) - nb = SIZE(p0amat, 2) - - DO i = 1, 3 - CALL dbcsr_get_block_p(matrix=matrix_s(1 + i)%matrix, & - row=irow, col=icol, block=dsblock, found=found) - CPASSERT(found) - - fi = 0.0_dp - CALL f2update(fi, p0amat, p0bmat, p1amat, p1bmat, dsblock, na, nb, & - wabk(1:na, 1:na, ikind), wabk(1:nb, 1:nb, jkind), & - aocg(1:na, irow), aocg(1:nb, icol), & - bocg(1:na, irow), bocg(1:nb, icol), & - aocg1(1:na, irow), aocg1(1:nb, icol), & - bocg1(1:na, irow), bocg1(1:nb, icol)) - - force(ikind)%rho_elec(i, atom_i) = force(ikind)%rho_elec(i, atom_i) + fi - force(jkind)%rho_elec(i, atom_j) = force(jkind)%rho_elec(i, atom_j) - fi - END DO - - END DO - CALL dbcsr_iterator_stop(iter) - - END IF - - CALL timestop(handle) - - END SUBROUTINE xtb_spinpol_hforce - -! ************************************************************************************************** -!> \brief ... -!> \param aksb ... -!> \param bksb ... -!> \param sb ... -!> \param na ... -!> \param nb ... -!> \param fval ... -!> \param wabi ... -!> \param wabj ... -!> \param qai ... -!> \param qaj ... -!> \param qbi ... -!> \param qbj ... -! ************************************************************************************************** - SUBROUTINE ksupdate(aksb, bksb, sb, na, nb, fval, & - wabi, wabj, qai, qaj, qbi, qbj) - - REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: aksb, bksb - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sb - INTEGER, INTENT(IN) :: na, nb - REAL(KIND=dp), INTENT(IN) :: fval - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: wabi, wabj - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: qai, qaj, qbi, qbj - - INTEGER :: ia, ib - REAL(KIND=dp), DIMENSION(na) :: dqa, wa - REAL(KIND=dp), DIMENSION(na, nb) :: wqab - REAL(KIND=dp), DIMENSION(nb) :: dqb, wb - - dqa = qai - qbi - dqb = qaj - qbj - wa = MATMUL(wabi, dqa) - wb = MATMUL(wabj, dqb) - DO ib = 1, nb - DO ia = 1, na - wqab(ia, ib) = fval*sb(ia, ib)*(wa(ia) + wb(ib)) - END DO - END DO - - aksb = aksb + wqab - bksb = bksb - wqab - - END SUBROUTINE ksupdate - -! ************************************************************************************************** -!> \brief ... -!> \param fij ... -!> \param pa ... -!> \param pb ... -!> \param ds ... -!> \param na ... -!> \param nb ... -!> \param wabi ... -!> \param wabj ... -!> \param qai ... -!> \param qaj ... -!> \param qbi ... -!> \param qbj ... -! ************************************************************************************************** - SUBROUTINE fupdate(fij, pa, pb, ds, na, nb, & - wabi, wabj, qai, qaj, qbi, qbj) - - REAL(KIND=dp), INTENT(OUT) :: fij - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: pa, pb, ds - INTEGER, INTENT(IN) :: na, nb - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: wabi, wabj - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: qai, qaj, qbi, qbj - - INTEGER :: ia, ib - REAL(KIND=dp), DIMENSION(na) :: dpsa, dqa, wa - REAL(KIND=dp), DIMENSION(na, nb) :: dpab - REAL(KIND=dp), DIMENSION(nb) :: dpsb, dqb, wb - - dqa = qai - qbi - dqb = qaj - qbj - wa = MATMUL(wabi, dqa) - wb = MATMUL(wabj, dqb) - dpab = pa - pb - dpsa = 0.0_dp - dpsb = 0.0_dp - DO ib = 1, nb - DO ia = 1, na - dpsa(ia) = dpsa(ia) + dpab(ia, ib)*ds(ia, ib) - dpsb(ib) = dpsb(ib) + dpab(ia, ib)*ds(ia, ib) - END DO - END DO - - fij = SUM(wa*dpsa) + SUM(wb*dpsb) - - END SUBROUTINE fupdate - -! ************************************************************************************************** -!> \brief ... -!> \param fij ... -!> \param p0a ... -!> \param p0b ... -!> \param p1a ... -!> \param p1b ... -!> \param ds ... -!> \param na ... -!> \param nb ... -!> \param wabi ... -!> \param wabj ... -!> \param qai ... -!> \param qaj ... -!> \param qbi ... -!> \param qbj ... -!> \param rai ... -!> \param raj ... -!> \param rbi ... -!> \param rbj ... -! ************************************************************************************************** - SUBROUTINE f2update(fij, p0a, p0b, p1a, p1b, ds, na, nb, wabi, wabj, & - qai, qaj, qbi, qbj, rai, raj, rbi, rbj) - - REAL(KIND=dp), INTENT(OUT) :: fij - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: p0a, p0b, p1a, p1b, ds - INTEGER, INTENT(IN) :: na, nb - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: wabi, wabj - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: qai, qaj, qbi, qbj, rai, raj, rbi, rbj - - INTEGER :: ia, ib - REAL(KIND=dp), DIMENSION(na) :: dpsa, dqa, wa - REAL(KIND=dp), DIMENSION(na, nb) :: dpab - REAL(KIND=dp), DIMENSION(nb) :: dpsb, dqb, wb - - fij = 0.0_dp - - dqa = qai - qbi - dqb = qaj - qbj - wa = MATMUL(wabi, dqa) - wb = MATMUL(wabj, dqb) - dpab = p1a - p1b - dpsa = 0.0_dp - dpsb = 0.0_dp - DO ib = 1, nb - DO ia = 1, na - dpsa(ia) = dpsa(ia) + dpab(ia, ib)*ds(ia, ib) - dpsb(ib) = dpsb(ib) + dpab(ia, ib)*ds(ia, ib) - END DO - END DO - - fij = fij + SUM(wa*dpsa) + SUM(wb*dpsb) - - dqa = rai - rbi - dqb = raj - rbj - wa = MATMUL(wabi, dqa) - wb = MATMUL(wabj, dqb) - dpab = p0a - p0b - dpsa = 0.0_dp - dpsb = 0.0_dp - DO ib = 1, nb - DO ia = 1, na - dpsa(ia) = dpsa(ia) + dpab(ia, ib)*ds(ia, ib) - dpsb(ib) = dpsb(ib) + dpab(ia, ib)*ds(ia, ib) - END DO - END DO - - fij = fij + SUM(wa*dpsa) + SUM(wb*dpsb) - - END SUBROUTINE f2update - -END MODULE xtb_spinpol diff --git a/src/xtb_types.F b/src/xtb_types.F index 5075595868..51240aabdf 100644 --- a/src/xtb_types.F +++ b/src/xtb_types.F @@ -69,7 +69,6 @@ MODULE xtb_types REAL(KIND=dp), DIMENSION(5) :: kappa = -1.0_dp REAL(KIND=dp), DIMENSION(5) :: hen = -1.0_dp REAL(KIND=dp), DIMENSION(5) :: zeta = -1.0_dp - REAL(KIND=dp), DIMENSION(3, 3) :: wall = -1.0_dp ! spin polarisation ! gfn0 params REAL(KIND=dp) :: en = -1.0_dp REAL(KIND=dp) :: kqat2 = -1.0_dp @@ -100,9 +99,8 @@ CONTAINS TYPE(xtb_atom_type), POINTER :: xtb_parameter - IF (ASSOCIATED(xtb_parameter)) THEN + IF (ASSOCIATED(xtb_parameter)) & CALL deallocate_xtb_atom_param(xtb_parameter) - END IF ALLOCATE (xtb_parameter) @@ -128,7 +126,6 @@ CONTAINS xtb_parameter%occupation = 0 xtb_parameter%kpoly = 0.0_dp xtb_parameter%kappa = 0.0_dp - xtb_parameter%wall = 0.0_dp xtb_parameter%hen = 0.0_dp xtb_parameter%zeta = 0.0_dp xtb_parameter%en = 0.0_dp @@ -182,7 +179,6 @@ CONTAINS !> \param lval ... !> \param kpoly ... !> \param kappa ... -!> \param wall ... !> \param hen ... !> \param zeta ... !> \param xi ... @@ -198,7 +194,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE get_xtb_atom_param(xtb_parameter, symbol, aname, typ, defined, z, zeff, natorb, lmax, nao, lao, & rcut, rcov, kx, eta, xgamma, alpha, zneff, nshell, nval, lval, kpoly, kappa, & - wall, hen, zeta, xi, kappa0, alpg, occupation, electronegativity, chmax, & + hen, zeta, xi, kappa0, alpg, occupation, electronegativity, chmax, & en, kqat2, kcn, kq) TYPE(xtb_atom_type), POINTER :: xtb_parameter @@ -213,10 +209,7 @@ CONTAINS REAL(KIND=dp), INTENT(OUT), OPTIONAL :: rcut, rcov, kx, eta, xgamma, alpha, zneff INTEGER, INTENT(OUT), OPTIONAL :: nshell INTEGER, DIMENSION(5), INTENT(OUT), OPTIONAL :: nval, lval - REAL(KIND=dp), DIMENSION(5), INTENT(OUT), OPTIONAL :: kpoly, kappa - REAL(KIND=dp), DIMENSION(3, 3), INTENT(OUT), & - OPTIONAL :: wall - REAL(KIND=dp), DIMENSION(5), INTENT(OUT), OPTIONAL :: hen, zeta + REAL(KIND=dp), DIMENSION(5), INTENT(OUT), OPTIONAL :: kpoly, kappa, hen, zeta REAL(KIND=dp), INTENT(OUT), OPTIONAL :: xi, kappa0, alpg INTEGER, DIMENSION(5), INTENT(OUT), OPTIONAL :: occupation REAL(KIND=dp), INTENT(OUT), OPTIONAL :: electronegativity, chmax, en, kqat2 @@ -249,7 +242,6 @@ CONTAINS IF (PRESENT(occupation)) occupation = xtb_parameter%occupation IF (PRESENT(kpoly)) kpoly = xtb_parameter%kpoly IF (PRESENT(kappa)) kappa = xtb_parameter%kappa - IF (PRESENT(wall)) wall(1:3, 1:3) = xtb_parameter%wall(1:3, 1:3) IF (PRESENT(hen)) hen = xtb_parameter%hen IF (PRESENT(zeta)) zeta = xtb_parameter%zeta IF (PRESENT(chmax)) chmax = xtb_parameter%chmax @@ -287,7 +279,6 @@ CONTAINS !> \param lval ... !> \param kpoly ... !> \param kappa ... -!> \param wall ... !> \param hen ... !> \param zeta ... !> \param xi ... @@ -303,7 +294,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE set_xtb_atom_param(xtb_parameter, aname, typ, defined, z, zeff, natorb, lmax, nao, lao, & rcut, rcov, kx, eta, xgamma, alpha, zneff, nshell, nval, lval, kpoly, kappa, & - wall, hen, zeta, xi, kappa0, alpg, electronegativity, occupation, chmax, & + hen, zeta, xi, kappa0, alpg, electronegativity, occupation, chmax, & en, kqat2, kcn, kq) TYPE(xtb_atom_type), POINTER :: xtb_parameter @@ -317,10 +308,7 @@ CONTAINS REAL(KIND=dp), INTENT(IN), OPTIONAL :: rcut, rcov, kx, eta, xgamma, alpha, zneff INTEGER, INTENT(IN), OPTIONAL :: nshell INTEGER, DIMENSION(5), INTENT(IN), OPTIONAL :: nval, lval - REAL(KIND=dp), DIMENSION(5), INTENT(IN), OPTIONAL :: kpoly, kappa - REAL(KIND=dp), DIMENSION(3, 3), INTENT(IN), & - OPTIONAL :: wall - REAL(KIND=dp), DIMENSION(5), INTENT(IN), OPTIONAL :: hen, zeta + REAL(KIND=dp), DIMENSION(5), INTENT(IN), OPTIONAL :: kpoly, kappa, hen, zeta REAL(KIND=dp), INTENT(IN), OPTIONAL :: xi, kappa0, alpg, electronegativity INTEGER, DIMENSION(5), INTENT(IN), OPTIONAL :: occupation REAL(KIND=dp), INTENT(IN), OPTIONAL :: chmax, en, kqat2 @@ -352,7 +340,6 @@ CONTAINS IF (PRESENT(occupation)) xtb_parameter%occupation = occupation IF (PRESENT(kpoly)) xtb_parameter%kpoly = kpoly IF (PRESENT(kappa)) xtb_parameter%kappa = kappa - IF (PRESENT(wall)) xtb_parameter%wall(1:3, 1:3) = wall(1:3, 1:3) IF (PRESENT(hen)) xtb_parameter%hen = hen IF (PRESENT(zeta)) xtb_parameter%zeta = zeta IF (PRESENT(chmax)) xtb_parameter%chmax = chmax @@ -382,10 +369,9 @@ CONTAINS CHARACTER(LEN=default_string_length) :: aname, bb INTEGER :: i, io_unit, m, natorb, nshell INTEGER, DIMENSION(5) :: lval, nval, occupation - LOGICAL :: defined, have_sp + LOGICAL :: defined REAL(dp) :: zeff REAL(KIND=dp) :: alpha, en, eta, xgamma, zneff - REAL(KIND=dp), DIMENSION(3, 3) :: wall REAL(KIND=dp), DIMENSION(5) :: hen, kappa, kpoly, zeta TYPE(cp_logger_type), POINTER :: logger @@ -407,10 +393,6 @@ CONTAINS CALL get_xtb_atom_param(xtb_parameter, nshell=nshell, lval=lval, nval=nval, occupation=occupation) CALL get_xtb_atom_param(xtb_parameter, kpoly=kpoly, kappa=kappa, hen=hen, zeta=zeta) CALL get_xtb_atom_param(xtb_parameter, electronegativity=en, xgamma=xgamma, eta=eta, alpha=alpha, zneff=zneff) - wall = 0.0_dp - CALL get_xtb_atom_param(xtb_parameter, wall=wall) - have_sp = .FALSE. - IF (SUM(ABS(wall)) /= 0.0_dp) have_sp = .TRUE. bb = " " WRITE (UNIT=io_unit, FMT="(/,A,T67,A14)") " xTB parameters: ", TRIM(aname) @@ -430,10 +412,6 @@ CONTAINS (kappa(i), i=1, nshell) WRITE (UNIT=io_unit, FMT="(T16,A,T71,F10.3)") "3rd Order constant", xgamma WRITE (UNIT=io_unit, FMT="(T16,A,T61,2F10.3)") "Repulsion potential [Z,alpha]", zneff, alpha - IF (have_sp) THEN - WRITE (UNIT=io_unit, FMT="(T16,A,T51,3F10.4)") "Spin Polarisation Wss sp pp", wall(1, 1), wall(1, 2), wall(2, 2) - WRITE (UNIT=io_unit, FMT="(T16,A,T51,3F10.4)") " Wsd pd dd", wall(1, 3), wall(2, 3), wall(3, 3) - END IF ELSE WRITE (UNIT=io_unit, FMT="(T55,A)") "Parameters are not defined" END IF diff --git a/tests/Fist/regtest-mace/TEST_FILES.toml b/tests/Fist/regtest-mace/TEST_FILES.toml deleted file mode 100644 index 4e86987486..0000000000 --- a/tests/Fist/regtest-mace/TEST_FILES.toml +++ /dev/null @@ -1,3 +0,0 @@ -# Test of MACE using libtorch https://pytorch.org/cppdocs/installing.html -"mace_test.inp" = [{matcher="M011", tol=1.0E-9, ref=-1532.363300232407482}] -#EOF \ No newline at end of file diff --git a/tests/Fist/regtest-mace/mace-test.xyz b/tests/Fist/regtest-mace/mace-test.xyz deleted file mode 100644 index de5d503ae3..0000000000 --- a/tests/Fist/regtest-mace/mace-test.xyz +++ /dev/null @@ -1,34 +0,0 @@ -32 -Lattice="7.23 0.0 0.0 0.0 7.23 0.0 0.0 0.0 7.23" Properties=species:S:1:pos:R:3 pbc="T T T" -Cu 7.19929385 0.07184150 7.15208419 -Cu 7.14664045 2.10236709 2.01651087 -Cu 1.82143618 0.04226192 1.92285339 -Cu 1.99446521 1.95857840 7.03556683 -Cu 0.04124875 0.03433693 3.81793753 -Cu 0.13296440 1.50725440 5.36672362 -Cu 2.05785380 7.16421454 5.34153878 -Cu 1.87904775 2.29484159 3.46181587 -Cu 7.14343690 3.63361819 0.04539203 -Cu 0.07856581 5.42264104 2.00907147 -Cu 1.70046840 3.49032697 1.45196525 -Cu 1.52838588 5.29338639 0.08402179 -Cu 7.04010983 3.63297407 3.45547313 -Cu 0.04993241 5.06858718 5.39256856 -Cu 1.57620067 3.46938961 5.22644546 -Cu 1.85045246 5.47919762 3.50191702 -Cu 3.66469285 0.20246133 0.01048150 -Cu 3.65200112 1.80572076 1.95822174 -Cu 5.62157919 7.09211077 1.57513403 -Cu 5.42582769 1.92125447 7.13092135 -Cu 3.74438701 7.22849521 3.62250140 -Cu 3.71553234 1.93544475 5.27911967 -Cu 5.41897600 6.88436492 5.32462967 -Cu 5.23975470 1.60760854 3.77619340 -Cu 3.72354623 3.71850028 0.15023152 -Cu 3.53953689 5.32915887 1.66932471 -Cu 5.31356798 3.64843433 1.81519742 -Cu 5.24884208 5.54500604 0.06504144 -Cu 3.76661054 3.88873128 3.46537226 -Cu 3.74258866 5.40276336 5.55936212 -Cu 5.45073160 3.94041922 5.40526077 -Cu 5.72305460 5.42694152 3.73428797 diff --git a/tests/Fist/regtest-mace/mace_test.inp b/tests/Fist/regtest-mace/mace_test.inp deleted file mode 100644 index feabc680c5..0000000000 --- a/tests/Fist/regtest-mace/mace_test.inp +++ /dev/null @@ -1,41 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT mace_test - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD FIST - #STRESS_TENSOR ANALYTICAL - &MM - &FORCEFIELD - &NONBONDED - &MACE - ATOMS Cu - POT_FILE_NAME MACE/MACE_scratch_run-3.model-cp2k.pth - &END MACE - &END NONBONDED - &END FORCEFIELD - &POISSON - &EWALD - EWALD_TYPE none - &END EWALD - &END POISSON - &END MM - &PRINT - &FORCES ON - &END FORCES - #&STRESS_TENSOR ON - #&END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - CELL_FILE_FORMAT XYZ - CELL_FILE_NAME ./mace-test.xyz - &END CELL - &TOPOLOGY - COORD_FILE_FORMAT XYZ - COORD_FILE_NAME ./mace-test.xyz - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md index b369135c48..c7e9b8747a 100644 --- a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md +++ b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md @@ -20,8 +20,6 @@ used to move towards making accurate XC integration the GAPW default in a future | DC-DFT/Energy Correction | `regtest-acc-2/HF-ec1.inp`, `HF-ec2.inp`, `HF-ec3.inp` | `HF-ec4.inp`, `HF-ec5.inp`, `HF-ec6.inp`, and `HF-ec7.inp` now also use explicit accurate integration | | TDDFPT forces | `regtest-acc-5/h2o_f01.inp` | `regtest-acc-5/h2o_f01_fine.inp` | | ADMM-GAPW TDDFPT response | `regtest-acc-5/ft3.inp` | `regtest-acc-5/ft3_fine.inp` | -| UZH basis/potential data | all-electron UZH HF force-debug tests in `regtest-acc-1` | GAPW all-electron and GAPW/GAPW_XC GTH finite-difference force and stress checks with `BASIS_MOLOPT_UZH` and `POTENTIAL_UZH` | -| def2-ECP data | def2-SVP ECP GAPW energy checks in `regtest-ecp` and `regtest-ecp-2` | GAPW mixed all-electron/ECP and GAPW_XC ECP-only finite-difference force and stress checks | | XAS/RT response | XAS_TDP and RTBSE coverage in `regtest-xastdp` and `regtest-rtbse` | open-shell GAPW XAS_TDP and GAPW RTBSE smoke tests in `regtest-acc-3` | | KG embedding | existing `regtest-kg` GPW cases | GAPW/GAPW_XC energy and stress checks for libxc KG, meta-GGA/tau KG, and RI embedding | | KG atomic potential | `regtest-kg/H2_KG-1.inp` | GAPW/GAPW_XC energy and stress checks for `TNADD_METHOD ATOMIC` | @@ -57,16 +55,6 @@ Finite-difference checks with `STOP_ON_MISMATCH` are included for: is kept diagonal in the targeted debug tests above. - GAPW_XC forces and diagonal stress: `regtest-acc-1/h2o-gapw_xc-force-1.inp`, `regtest-acc-1/h2o-gapw_xc-stress-debug-1.inp`. -- UZH all-electron GAPW forces and analytical stress smoke: - `regtest-acc-1/h2o-uzh-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp`. -- UZH GTH GAPW/GAPW_XC forces and analytical stress smoke: - `regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp`, - `regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp`, and - `regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp`. -- ECP GAPW/GAPW_XC targeted force and analytical stress smoke checks: - `regtest-ecp/ICl_lanl2dz_gapw_force.inp`, `ICl_lanl2dz_gapw_stress.inp`, - `ICl_lanl2dz_gapw_xc_force.inp`, and `ICl_lanl2dz_gapw_xc_stress.inp`; the def2-ECP energy path - remains covered by `regtest-ecp/SbH3_def2_gapw.inp`. - ADMM-GAPW forces: `regtest-acc-1/HF-d5.inp`, `regtest-acc-5/ft3_fine.inp`. - ADMM-GAPW diagonal stress: `regtest-acc-2/h2o-admm-gapw-stress-debug-1.inp`, `regtest-acc-2/h2o-admm-gapw-pbe-stress-debug-1.inp`. diff --git a/tests/QS/regtest-acc-1/TEST_FILES.toml b/tests/QS/regtest-acc-1/TEST_FILES.toml index d26801d538..41e4817c71 100644 --- a/tests/QS/regtest-acc-1/TEST_FILES.toml +++ b/tests/QS/regtest-acc-1/TEST_FILES.toml @@ -36,10 +36,4 @@ "h2o-gapw_xc-stress-debug-1.inp" = [] "h2o-gapw_xc-full-stress-1.inp" = [{matcher="M011", tol=1e-08, ref=-17.256333793570239}, {matcher="M031", tol=1e-08, ref=3.91898639036E+03}] -"h2o-uzh-gapw-force-1.inp" = [] -"h2o-uzh-gapw-stress-debug-1.inp" = [] -"h2o-uzh-gth-gapw-force-1.inp" = [] -"h2o-uzh-gth-gapw-stress-debug-1.inp" = [] -"h2o-uzh-gth-gapw_xc-force-1.inp" = [] -"h2o-uzh-gth-gapw_xc-stress-debug-1.inp" = [] #EOF diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp deleted file mode 100644 index 9e6684b46a..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp +++ /dev/null @@ -1,63 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gapw-force-1 - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &KIND O - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp deleted file mode 100644 index 920bbbf7a1..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp +++ /dev/null @@ -1,60 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gapw-stress-debug-1 - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &KIND O - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp deleted file mode 100644 index 924f9670d2..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp +++ /dev/null @@ -1,67 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw-force-1 - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp deleted file mode 100644 index 3c80d1546e..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp +++ /dev/null @@ -1,64 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw-stress-debug-1 - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp deleted file mode 100644 index 412457eafe..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp +++ /dev/null @@ -1,69 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw_xc-force-1 - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp deleted file mode 100644 index 5bceffa537..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp +++ /dev/null @@ -1,66 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw_xc-stress-debug-1 - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-admm-libxc/TEST_FILES.toml b/tests/QS/regtest-admm-libxc/TEST_FILES.toml index 548bfe1fbe..640bfb052e 100644 --- a/tests/QS/regtest-admm-libxc/TEST_FILES.toml +++ b/tests/QS/regtest-admm-libxc/TEST_FILES.toml @@ -2,8 +2,8 @@ "H2O-BP-OPTX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.173082884557527}] "H2O-BP-BECKEX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172192115148068}] "H2O-BP-Coul.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172925552133442}] -"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689027640}] +"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689018060}] "H2O-BP-lr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.689871565334784}] -"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754561230}] -"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992363387}] +"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754585429}] +"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992387993}] #EOF diff --git a/tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp b/tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp deleted file mode 100644 index d39718e9dd..0000000000 --- a/tests/QS/regtest-bse/ABBA_H2_PBE_UKS_G0W0.inp +++ /dev/null @@ -1,78 +0,0 @@ -&GLOBAL - PRINT_LEVEL MEDIUM - PROJECT ABBA_H2_PBE_UKS_G0W0 - RUN_TYPE ENERGY - &TIMINGS - THRESHOLD 0.01 - &END TIMINGS -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_DIFFUSE - LSD - MULTIPLICITY 1 - POTENTIAL_FILE_NAME POTENTIAL - &MGRID - CUTOFF 300 - REL_CUTOFF 30 - &END MGRID - &POISSON - PERIODIC NONE - PSOLVER MULTIPOLE - &END POISSON - &PRINT - &MO - ENERGIES T - &END MO - &END PRINT - &QS - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &END SCF - &XC - &WF_CORRELATION - &RI_RPA - &GW - SELF_CONSISTENCY G0W0 - &BSE - ENERGY_CUTOFF_EMPTY 60 - NUM_PRINT_EXC -1 - TDA OFF - &END BSE - &END GW - &END RI_RPA - &END WF_CORRELATION - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - ABC 6 6 6 - PERIODIC NONE - &END CELL - &COORD - H 0 0.0 0.0 - H 0 0.0 0.74144 - &END COORD - &KIND H - BASIS_SET def2-SVP-custom-diffuse - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &PRINT - &ATOMIC_COORDINATES ON - &END ATOMIC_COORDINATES - &END PRINT - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp b/tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp deleted file mode 100644 index a8f647a6cd..0000000000 --- a/tests/QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp +++ /dev/null @@ -1,83 +0,0 @@ -&GLOBAL - PRINT_LEVEL MEDIUM - PROJECT ABBA_O2_PBE_UKS_G0W0 - RUN_TYPE ENERGY - &TIMINGS - THRESHOLD 0.01 - &END TIMINGS -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_def2_TZVP_orb - BASIS_SET_FILE_NAME BASIS_def2_TZVP_rifit - ! Asymmetric open-shell BSE regtest candidate: O2 triplet (9a/7b), def2-TZVP all-electron GAPW, - ! no cutoff so beta's extra virtuals exercise the per-spin (ab|K) Q9 path (ABBA). Not converged physics - ! (def2-TZVP-RIFIT auxiliary) - this is a code-reproducibility regtest, not a benchmark. - LSD - MULTIPLICITY 3 - POTENTIAL_FILE_NAME POTENTIAL - &MGRID - CUTOFF 600 - REL_CUTOFF 50 - &END MGRID - &POISSON - PERIODIC NONE - PSOLVER MULTIPOLE - &END POISSON - &PRINT - &MO - ENERGIES T - &END MO - &END PRINT - &QS - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &END SCF - &XC - &WF_CORRELATION - &RI_RPA - &GW - CORR_MOS_OCC -1 - CORR_MOS_VIRT -1 - SELF_CONSISTENCY G0W0 - &BSE - NUM_PRINT_EXC 8 - TDA OFF - &END BSE - &END GW - &END RI_RPA - &END WF_CORRELATION - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - ABC 8 8 8 - PERIODIC NONE - &END CELL - &COORD - O 0.0 0.0 0.0 - O 0.0 0.0 1.2075 - &END COORD - &KIND O - BASIS_SET def2-TZVP - BASIS_SET RI_AUX def2-TZVP-RIFIT - POTENTIAL ALL - &END KIND - &PRINT - &ATOMIC_COORDINATES ON - &END ATOMIC_COORDINATES - &END PRINT - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/BASIS_def2_TZVP_orb b/tests/QS/regtest-bse/BASIS_def2_TZVP_orb deleted file mode 100644 index b3f400467f..0000000000 --- a/tests/QS/regtest-bse/BASIS_def2_TZVP_orb +++ /dev/null @@ -1,47 +0,0 @@ -#---------------------------------------------------------------------- -# Basis Set Exchange -# Version 0.12 -# https://www.basissetexchange.org -#---------------------------------------------------------------------- -# Basis set: def2-TZVP -# Description: def2-TZVP -# Role: orbital -# Version: 1 (Data from Turbomole 7.3) -#---------------------------------------------------------------------- - - -# Oxygen def2-TZVP (11s,6p,2d,1f) -> [5s,3p,2d,1f] -O def2-TZVP - 11 -1 0 0 6 1 - 27032.3826310 0.21726302465E-03 - 4052.3871392 0.16838662199E-02 - 922.32722710 0.87395616265E-02 - 261.24070989 0.35239968808E-01 - 85.354641351 0.11153519115 - 31.035035245 0.25588953961 -1 0 0 2 1 - 12.260860728 0.39768730901 - 4.9987076005 0.24627849430 -1 0 0 1 1 - 1.1703108158 1.0000000 -1 0 0 1 1 - 0.46474740994 1.0000000 -1 0 0 1 1 - 0.18504536357 1.0000000 -1 1 1 4 1 - 63.274954801 0.60685103418E-02 - 14.627049379 0.41912575824E-01 - 4.4501223456 0.16153841088 - 1.5275799647 0.35706951311 -1 1 1 1 1 - 0.52935117943 .44794207502 -1 1 1 1 1 - 0.17478421270 .24446069663 -1 2 2 1 1 - 2.31400000 1.0000000 -1 2 2 1 1 - 0.64500000 1.0000000 -1 3 3 1 1 - 1.42800000 1.0000000 - diff --git a/tests/QS/regtest-bse/BASIS_def2_TZVP_rifit b/tests/QS/regtest-bse/BASIS_def2_TZVP_rifit deleted file mode 100644 index 9d71bf729b..0000000000 --- a/tests/QS/regtest-bse/BASIS_def2_TZVP_rifit +++ /dev/null @@ -1,61 +0,0 @@ -#---------------------------------------------------------------------- -# Basis Set Exchange -# Version 0.12 -# https://www.basissetexchange.org -#---------------------------------------------------------------------- -# Basis set: def2-TZVP-RIFIT -# Description: RIMP2 auxiliary basis for def2-TZVP -# Role: rifit -# Version: 1 (Data from Turbomole 7.3) -#---------------------------------------------------------------------- - - -# Oxygen def2-TZVP-RIFIT (8s,6p,5d,3f,1g) -> [8s,6p,4d,3f,1g] -O def2-TZVP-RIFIT - 22 -1 0 0 1 1 - 364.91291000 .58060340 -1 0 0 1 1 - 77.38709400 1.40179846 -1 0 0 1 1 - 24.30170600 .34994600 -1 0 0 1 1 - 8.43695450 1.0000000 -1 0 0 1 1 - 3.15279410 1.0000000 -1 0 0 1 1 - 1.57754300 1.0000000 -1 0 0 1 1 - .78178244 1.0000000 -1 0 0 1 1 - .31652679 1.0000000 -1 1 1 1 1 - 56.73594800 1.04911649 -1 1 1 1 1 - 14.99721700 1.13960439 -1 1 1 1 1 - 5.64281160 1.0000000 -1 1 1 1 1 - 2.40692198 1.0000000 -1 1 1 1 1 - 1.02640596 1.0000000 -1 1 1 1 1 - .43769977 1.0000000 -1 2 2 2 1 - 12.44682100 1.14971821 - 6.12169170 .95355196 -1 2 2 1 1 - 2.71029490 1.0000000 -1 2 2 1 1 - 1.15240610 1.0000000 -1 2 2 1 1 - .41386174 1.0000000 -1 3 3 1 1 - 4.77935390 .36170900 -1 3 3 1 1 - 2.32046420 1.78111990 -1 3 3 1 1 - 1.09128040 .45330353 -1 4 4 1 1 - 2.33831070 1.0000000 - diff --git a/tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp b/tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp deleted file mode 100644 index 64d1662fa0..0000000000 --- a/tests/QS/regtest-bse/TDA_H2_PBE_UKS_KS.inp +++ /dev/null @@ -1,79 +0,0 @@ -&GLOBAL - PRINT_LEVEL MEDIUM - PROJECT TDA_H2_PBE_UKS_KS - RUN_TYPE ENERGY - &TIMINGS - THRESHOLD 0.01 - &END TIMINGS -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_DIFFUSE - LSD - MULTIPLICITY 1 - POTENTIAL_FILE_NAME POTENTIAL - &MGRID - CUTOFF 300 - REL_CUTOFF 30 - &END MGRID - &POISSON - PERIODIC NONE - PSOLVER MULTIPOLE - &END POISSON - &PRINT - &MO - ENERGIES T - &END MO - &END PRINT - &QS - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &END SCF - &XC - &WF_CORRELATION - &RI_RPA - &GW - SELF_CONSISTENCY G0W0 - &BSE - ENERGY_CUTOFF_EMPTY 60 - NUM_PRINT_EXC -1 - TDA ON - USE_KS_ENERGIES - &END BSE - &END GW - &END RI_RPA - &END WF_CORRELATION - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - ABC 6 6 6 - PERIODIC NONE - &END CELL - &COORD - H 0 0.0 0.0 - H 0 0.0 0.74144 - &END COORD - &KIND H - BASIS_SET def2-SVP-custom-diffuse - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &PRINT - &ATOMIC_COORDINATES ON - &END ATOMIC_COORDINATES - &END PRINT - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp b/tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp deleted file mode 100644 index 63022849d4..0000000000 --- a/tests/QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp +++ /dev/null @@ -1,83 +0,0 @@ -&GLOBAL - PRINT_LEVEL MEDIUM - PROJECT TDA_O2_PBE_UKS_G0W0 - RUN_TYPE ENERGY - &TIMINGS - THRESHOLD 0.01 - &END TIMINGS -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_def2_TZVP_orb - BASIS_SET_FILE_NAME BASIS_def2_TZVP_rifit - ! Asymmetric open-shell BSE regtest candidate: O2 triplet (9a/7b), def2-TZVP all-electron GAPW, - ! no cutoff so beta's extra virtuals exercise the per-spin (ab|K) Q9 path. Not converged physics - ! (def2-TZVP-RIFIT auxiliary) - this is a code-reproducibility regtest, not a benchmark. - LSD - MULTIPLICITY 3 - POTENTIAL_FILE_NAME POTENTIAL - &MGRID - CUTOFF 600 - REL_CUTOFF 50 - &END MGRID - &POISSON - PERIODIC NONE - PSOLVER MULTIPOLE - &END POISSON - &PRINT - &MO - ENERGIES T - &END MO - &END PRINT - &QS - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &END SCF - &XC - &WF_CORRELATION - &RI_RPA - &GW - CORR_MOS_OCC -1 - CORR_MOS_VIRT -1 - SELF_CONSISTENCY G0W0 - &BSE - NUM_PRINT_EXC 8 - TDA ON - &END BSE - &END GW - &END RI_RPA - &END WF_CORRELATION - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - ABC 8 8 8 - PERIODIC NONE - &END CELL - &COORD - O 0.0 0.0 0.0 - O 0.0 0.0 1.2075 - &END COORD - &KIND O - BASIS_SET def2-TZVP - BASIS_SET RI_AUX def2-TZVP-RIFIT - POTENTIAL ALL - &END KIND - &PRINT - &ATOMIC_COORDINATES ON - &END ATOMIC_COORDINATES - &END PRINT - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-bse/TEST_FILES.toml b/tests/QS/regtest-bse/TEST_FILES.toml index 88785e6eed..b9cb20d92c 100644 --- a/tests/QS/regtest-bse/TEST_FILES.toml +++ b/tests/QS/regtest-bse/TEST_FILES.toml @@ -20,17 +20,6 @@ "BSE_H2O_PBE_evGW0_spectra.inp" = [{matcher="M124", tol=2e-02, ref=25.3518}, {matcher="M125", tol=2e-02, ref=0.7006}] "TDA_H2_PBE_G0W0_CHOLESKY_OFF.inp" = [{matcher="BSE_1st_excit_ener_TDA", tol=2e-05 , ref=16.9750}] -"TDA_H2_PBE_UKS_KS.inp" = [{matcher="BSE_1st_excit_ener_UKS", tol=2e-05, ref=0.5127}, - {matcher="BSE_2nd_excit_ener_UKS", tol=2e-05, ref=6.2622}, - {matcher="BSE_osc_str_n2_UKS", tol=7e-02, ref=0.295}] -"ABBA_H2_PBE_UKS_G0W0.inp" = [{matcher="BSE_1st_excit_ener_UKS_ABBA", tol=2e-05, ref=10.5924}, - {matcher="BSE_2nd_excit_ener_UKS_ABBA", tol=2e-05, ref=15.8565}, - {matcher="BSE_osc_str_n2_UKS_ABBA", tol=7e-02, ref=0.589}, - {matcher="BSE_ampl_n2_UKS_ABBA", tol=7e-02, ref=0.7132}] -"TDA_O2_PBE_UKS_G0W0.inp" = [{matcher="BSE_1st_excit_ener_UKS", tol=1e-03, ref=5.7853}, - {matcher="BSE_2nd_excit_ener_UKS", tol=1e-03, ref=5.8093}] -"ABBA_O2_PBE_UKS_G0W0.inp" = [{matcher="BSE_1st_excit_ener_UKS_ABBA", tol=1e-03, ref=5.7210}, - {matcher="BSE_2nd_excit_ener_UKS_ABBA", tol=1e-03, ref=5.7210}] #EOF #Low convergence criteria for evGW make a higher threshold necessary for these tests #Logic: Absolute errors (for G0W0/evGW0) should be within 1e-4, i.e. relative errors are diff --git a/tests/QS/regtest-debug-2/TEST_FILES.toml b/tests/QS/regtest-debug-2/TEST_FILES.toml index 043d6f8142..132ecbab4e 100644 --- a/tests/QS/regtest-debug-2/TEST_FILES.toml +++ b/tests/QS/regtest-debug-2/TEST_FILES.toml @@ -3,13 +3,10 @@ # e.g. 0 means do not compare anything, running is enough # 1 compares the last total energy in the file # for details see cp2k/tools/do_regtest -"h2o_lri.inp" = [] -"h2o_pade_fd.inp" = [] -"h2o_hfx.inp" = [] -"h2o_hfx_admm.inp" = [] -"h2o_admm_gapw.inp" = [] -"h2o_admm_x.inp" = [] -"h2o_pbe_fd.inp" = [] -# -#"h2o_tpss_fd.inp" = [] +"h2o_lri.inp" = [{matcher="M087", tol=1e-05, ref=0.222165614960E+02}] +"h2o_pade_fd.inp" = [{matcher="M087", tol=1e-05, ref=0.168333363169E+02}] +"h2o_hfx.inp" = [{matcher="M087", tol=1e-05, ref=0.106990197203E+02}] +"h2o_hfx_admm.inp" = [{matcher="M087", tol=1e-05, ref=0.153251090463E+02}] +"h2o_admm_gapw.inp" = [{matcher="M087", tol=1e-05, ref=0.108571964857E+02}] +"h2o_admm_x.inp" = [{matcher="M087", tol=1e-05, ref=0.108790445340E+02}] #EOF diff --git a/tests/QS/regtest-debug-2/h2o_admm_gapw.inp b/tests/QS/regtest-debug-2/h2o_admm_gapw.inp index 4b739123e2..70acbfd20e 100644 --- a/tests/QS/regtest-debug-2/h2o_admm_gapw.inp +++ b/tests/QS/regtest-debug-2/h2o_admm_gapw.inp @@ -59,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-2/h2o_admm_x.inp b/tests/QS/regtest-debug-2/h2o_admm_x.inp index 264392849d..84f4e0912d 100644 --- a/tests/QS/regtest-debug-2/h2o_admm_x.inp +++ b/tests/QS/regtest-debug-2/h2o_admm_x.inp @@ -59,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-2/h2o_hfx.inp b/tests/QS/regtest-debug-2/h2o_hfx.inp index a3a681f63d..7859756baa 100644 --- a/tests/QS/regtest-debug-2/h2o_hfx.inp +++ b/tests/QS/regtest-debug-2/h2o_hfx.inp @@ -56,7 +56,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-2/h2o_hfx_admm.inp b/tests/QS/regtest-debug-2/h2o_hfx_admm.inp index 1c9397200c..b31484886f 100644 --- a/tests/QS/regtest-debug-2/h2o_hfx_admm.inp +++ b/tests/QS/regtest-debug-2/h2o_hfx_admm.inp @@ -26,9 +26,6 @@ &END AUXILIARY_DENSITY_MATRIX_METHOD &EFIELD &END EFIELD - &MGRID - CUTOFF 100 - &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -41,9 +38,9 @@ &END QS &SCF EPS_SCF 1.0E-6 - MAX_SCF 10 + MAX_SCF 100 SCF_GUESS ATOMIC - &OT ON + &OT OFF MINIMIZER DIIS PRECONDITIONER FULL_SINGLE_INVERSE &END OT diff --git a/tests/QS/regtest-debug-2/h2o_lri.inp b/tests/QS/regtest-debug-2/h2o_lri.inp index d4605011e3..e0ec64d6da 100644 --- a/tests/QS/regtest-debug-2/h2o_lri.inp +++ b/tests/QS/regtest-debug-2/h2o_lri.inp @@ -21,7 +21,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 240 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -34,7 +35,7 @@ METHOD LRIGPW &END QS &SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-6 MAX_SCF 10 SCF_GUESS ATOMIC &OT @@ -42,7 +43,7 @@ PRECONDITIONER FULL_SINGLE_INVERSE &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -63,7 +64,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.0 5.0 5.0 + ABC [angstrom] 4.5 4.5 4.5 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-2/h2o_pade_fd.inp b/tests/QS/regtest-debug-2/h2o_pade_fd.inp index 39605d26ea..13819d3810 100644 --- a/tests/QS/regtest-debug-2/h2o_pade_fd.inp +++ b/tests/QS/regtest-debug-2/h2o_pade_fd.inp @@ -19,9 +19,6 @@ LSD &EFIELD &END EFIELD - &MGRID - CUTOFF 100 - &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -53,7 +50,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-09 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -63,7 +60,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4. 4. 4. + ABC [angstrom] 4.5 4.5 4.5 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-2/h2o_pbe_fd.inp b/tests/QS/regtest-debug-2/h2o_pbe_fd.inp index 05165ceed1..1849583aa4 100644 --- a/tests/QS/regtest-debug-2/h2o_pbe_fd.inp +++ b/tests/QS/regtest-debug-2/h2o_pbe_fd.inp @@ -18,9 +18,6 @@ &DFT &EFIELD &END EFIELD - &MGRID - CUTOFF 100 - &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -52,7 +49,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-10 + EPS 1.e-09 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -62,7 +59,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.0 5.0 5.0 + ABC [angstrom] 6.0 6.0 6.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-2/h2o_tpss_fd.inp b/tests/QS/regtest-debug-2/h2o_tpss_fd.inp index 91631001ea..fcea6cff85 100644 --- a/tests/QS/regtest-debug-2/h2o_tpss_fd.inp +++ b/tests/QS/regtest-debug-2/h2o_tpss_fd.inp @@ -19,9 +19,6 @@ LSD &EFIELD &END EFIELD - &MGRID - CUTOFF 100 - &END MGRID &PRINT &MOMENTS ON PERIODIC .FALSE. @@ -57,9 +54,8 @@ &END DFT &PROPERTIES &LINRES - ENERGY_GAP 0.05 - EPS 1.e-07 - PRECONDITIONER FULL_SINGLE_INVERSE + EPS 1.e-09 + PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T PERIODIC_DIPOLE_OPERATOR F @@ -68,7 +64,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 6.0 6.0 6.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-3/TEST_FILES.toml b/tests/QS/regtest-debug-3/TEST_FILES.toml index 150a32d80b..f5340fcf68 100644 --- a/tests/QS/regtest-debug-3/TEST_FILES.toml +++ b/tests/QS/regtest-debug-3/TEST_FILES.toml @@ -6,8 +6,8 @@ "h2o_pbe0.inp" = [{matcher="M060", tol=1e-05, ref=0.411901963703}] "h2o_pbe0_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.426369189904}] # -"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.445432754543}] -"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.442023635799}] +"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.436263865396}] +"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.381688458912}] #h2o_B88_mixcl.inp functional B88_LR 60 1e-05 0.000000000000E+00 #h2o_B88_mixcl_admm.inp functional B88_LR 60 1e-05 0.000000000000E+00 "h2o_pbe0TC.inp" = [{matcher="M060", tol=1e-05, ref=0.430192264863}] diff --git a/tests/QS/regtest-debug-3/h2o_HSE06.inp b/tests/QS/regtest-debug-3/h2o_HSE06.inp index c57938acb0..8330db4771 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06.inp @@ -21,7 +21,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 150 + CUTOFF 200 &END MGRID &PRINT &MOMENTS ON @@ -80,7 +80,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 5.0 5.0 5.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp index c46674b366..a96d0a06ff 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp @@ -28,7 +28,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 150 + CUTOFF 200 &END MGRID &PRINT &MOMENTS ON @@ -87,7 +87,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 5.0 5.0 5.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/TEST_FILES.toml b/tests/QS/regtest-debug-7/TEST_FILES.toml index 360eb5a2ba..4b7be864c6 100644 --- a/tests/QS/regtest-debug-7/TEST_FILES.toml +++ b/tests/QS/regtest-debug-7/TEST_FILES.toml @@ -3,17 +3,17 @@ # e.g. 0 means do not compare anything, running is enough # 1 compares the last total energy in the file # for details see cp2k/tools/do_regtest -"ch2o_gapw_t1.inp" = [] -"ch2o_gapw_t2.inp" = [] -"ch2o_gapw_t3.inp" = [] -"ch2o_gapw_t4.inp" = [] -"h2o_gapw_t5.inp" = [] -"h2o_gapw_t6.inp" = [] -"h2o_gapw_t7.inp" = [] -"ch2o_gapw_xc_t1.inp" = [] -"ch2o_gapw_xc_t2.inp" = [] -"ch2o_gapw_xc_t3.inp" = [] -"ch2o_gapw_xc_t4.inp" = [] -"h2o_gapw_xc_t5.inp" = [] -"h2o_gapw_xc_t6.inp" = [] +"ch2o_gapw_t1.inp" = [{matcher="M087", tol=1e-05, ref=0.483221735787E+02}] +"ch2o_gapw_t2.inp" = [{matcher="M087", tol=1e-05, ref=0.523034637680E+02}] +"ch2o_gapw_t3.inp" = [{matcher="M087", tol=1e-05, ref=0.514019909196E+02}] +"ch2o_gapw_t4.inp" = [{matcher="M087", tol=1e-05, ref=0.509623579715E+02}] +"h2o_gapw_t5.inp" = [{matcher="M087", tol=1e-05, ref=0.107325591393E+02}] +"h2o_gapw_t6.inp" = [{matcher="M087", tol=1e-05, ref=0.154795414458E+02}] +"h2o_gapw_t7.inp" = [{matcher="M087", tol=1e-05, ref=0.999033988860E+01}] +"ch2o_gapw_xc_t1.inp" = [{matcher="M087", tol=1e-05, ref=0.531344520427E+02}] +"ch2o_gapw_xc_t2.inp" = [{matcher="M087", tol=1e-05, ref=0.522983512347E+02}] +"ch2o_gapw_xc_t3.inp" = [{matcher="M087", tol=1e-05, ref=0.513981803741E+02}] +"ch2o_gapw_xc_t4.inp" = [{matcher="M087", tol=1e-05, ref=0.509588648640E+02}] +"h2o_gapw_xc_t5.inp" = [{matcher="M087", tol=1e-05, ref=0.108004306906E+02}] +"h2o_gapw_xc_t6.inp" = [{matcher="M087", tol=1e-05, ref=0.993781535670E+01}] #EOF diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp index 747c356b9e..80d678ae59 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t1.inp @@ -19,7 +19,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 300 + REL_CUTOFF 50 &END MGRID &POISSON PERIODIC NONE @@ -55,7 +56,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -65,7 +66,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 6.0 6.0 6.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp index 14b4becb29..6bedbc8d08 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t2.inp @@ -19,7 +19,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -28,11 +29,11 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-6 MAX_SCF 20 SCF_GUESS ATOMIC &OT @@ -40,7 +41,7 @@ PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -51,7 +52,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp index 68a2219c17..aabe828566 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t3.inp @@ -5,7 +5,7 @@ &END GLOBAL &DEBUG - DE 0.001 + DE 0.005 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .FALSE. DEBUG_POLARIZABILITY .TRUE. @@ -19,7 +19,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -28,19 +29,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-6 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -51,7 +52,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp b/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp index 60b8f62253..f48b57cebd 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_t4.inp @@ -27,7 +27,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -36,19 +37,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-6 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -59,7 +60,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp index e86fcf1113..9462398ec9 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t1.inp @@ -19,7 +19,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -28,19 +29,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-7 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -51,7 +52,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp index a70faff79e..5c27e56781 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t2.inp @@ -19,7 +19,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -51,7 +52,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -61,7 +62,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 6.0 6.0 6.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp index c88e40c1f5..b021b9c75d 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t3.inp @@ -19,7 +19,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -28,19 +29,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-7 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-7 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -51,7 +52,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp index c00d805a5c..f8f7f65cd4 100644 --- a/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp +++ b/tests/QS/regtest-debug-7/ch2o_gapw_xc_t4.inp @@ -27,7 +27,8 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 100 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -36,19 +37,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-6 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -59,7 +60,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp b/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp index 84af39ac67..4f4338c4b1 100644 --- a/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp +++ b/tests/QS/regtest-debug-7/ch2o_vdw_t1.inp @@ -21,7 +21,8 @@ METHOD GPW &END QS &MGRID - CUTOFF 100 + CUTOFF 400 + REL_CUTOFF 60 &END MGRID &EFIELD &END EFIELD @@ -48,7 +49,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-10 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/h2o_gapw_t5.inp b/tests/QS/regtest-debug-7/h2o_gapw_t5.inp index 1793187c29..2b2a70b83c 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_t5.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_t5.inp @@ -28,6 +28,7 @@ &END EFIELD &MGRID CUTOFF 100 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -36,11 +37,11 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-5 MAX_SCF 20 SCF_GUESS ATOMIC &OT @@ -48,7 +49,7 @@ PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-5 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -59,7 +60,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -69,7 +70,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 6.0 6.0 6.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/h2o_gapw_t6.inp b/tests/QS/regtest-debug-7/h2o_gapw_t6.inp index 9809dd14ab..d61633ce9d 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_t6.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_t6.inp @@ -27,6 +27,7 @@ &END EFIELD &MGRID CUTOFF 100 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -35,19 +36,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-5 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-5 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -58,7 +59,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/h2o_gapw_t7.inp b/tests/QS/regtest-debug-7/h2o_gapw_t7.inp index be7da6dc9b..3273f865f2 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_t7.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_t7.inp @@ -11,7 +11,7 @@ DEBUG_POLARIZABILITY .TRUE. DEBUG_STRESS_TENSOR .FALSE. EPS_NO_ERROR_CHECK 5.e-5 - STOP_ON_MISMATCH .TRUE. + STOP_ON_MISMATCH .FALSE. &END DEBUG &FORCE_EVAL @@ -31,6 +31,7 @@ &END EFIELD &MGRID CUTOFF 100 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -39,19 +40,19 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW &END QS &SCF - EPS_SCF 1.0E-8 - MAX_SCF 10 + EPS_SCF 1.0E-6 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-8 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -62,7 +63,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp b/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp index 4cbe9cc7ad..d16c59a6f5 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_xc_t5.inp @@ -28,6 +28,7 @@ &END EFIELD &MGRID CUTOFF 100 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -36,11 +37,11 @@ &END MOMENTS &END PRINT &QS - EPS_DEFAULT 1.e-14 + EPS_DEFAULT 1.e-10 METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-5 MAX_SCF 20 SCF_GUESS ATOMIC &OT @@ -48,7 +49,7 @@ PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-5 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -59,7 +60,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T @@ -69,7 +70,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 6.0 6.0 6.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp b/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp index 4d8e18c8fa..22a5159d07 100644 --- a/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp +++ b/tests/QS/regtest-debug-7/h2o_gapw_xc_t6.inp @@ -30,6 +30,7 @@ &END EFIELD &MGRID CUTOFF 100 + REL_CUTOFF 40 &END MGRID &PRINT &MOMENTS ON @@ -42,15 +43,15 @@ METHOD GAPW_XC &END QS &SCF - EPS_SCF 1.0E-7 - MAX_SCF 10 + EPS_SCF 1.0E-6 + MAX_SCF 20 SCF_GUESS ATOMIC &OT MINIMIZER DIIS PRECONDITIONER FULL_ALL &END OT &OUTER_SCF - EPS_SCF 1.0E-7 + EPS_SCF 1.0E-6 MAX_SCF 10 &END OUTER_SCF &END SCF @@ -61,7 +62,7 @@ &END DFT &PROPERTIES &LINRES - EPS 1.e-12 + EPS 1.e-5 PRECONDITIONER FULL_ALL &POLAR DO_RAMAN T diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp deleted file mode 100644 index 35a8618cc7..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp +++ /dev/null @@ -1,62 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_force - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp deleted file mode 100644 index aa73463cd3..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp +++ /dev/null @@ -1,59 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_stress - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp deleted file mode 100644 index a1fd01ce1e..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp +++ /dev/null @@ -1,64 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_xc_force - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 6.0 0.0 0.0 - B 0.25 6.1 0.0 - C 0.15 0.35 6.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp deleted file mode 100644 index b94b1a47a1..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp +++ /dev/null @@ -1,61 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_xc_stress - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 6.0 0.0 0.0 - B 0.25 6.1 0.0 - C 0.15 0.35 6.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/TEST_FILES.toml b/tests/QS/regtest-ecp/TEST_FILES.toml index 914bf20fb4..77e7b87d8e 100644 --- a/tests/QS/regtest-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-ecp/TEST_FILES.toml @@ -3,7 +3,3 @@ "SbH3_def2_gapw.inp" = [{matcher="M011", tol=1.0E-11, ref=-241.414769303399083}] "HCl_ccECP.inp" = [{matcher="M011", tol=1.0E-12, ref=-15.457709431781252}] "HCl_force.inp" = [] -"ICl_lanl2dz_gapw_force.inp" = [] -"ICl_lanl2dz_gapw_stress.inp" = [] -"ICl_lanl2dz_gapw_xc_force.inp" = [] -"ICl_lanl2dz_gapw_xc_stress.inp" = [] diff --git a/tests/QS/regtest-gauxc-api/TEST_FILES.toml b/tests/QS/regtest-gauxc-api/TEST_FILES.toml index e9ee7d1cee..c03ead6223 100644 --- a/tests/QS/regtest-gauxc-api/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-api/TEST_FILES.toml @@ -1,7 +1,7 @@ "1H2_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163125608332391}] "1H2_GAUXC_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] -"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] +"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121899608445}] "NH3_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722432805445091}] -"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722557896081605}] +"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722558568119791}] "OH_GAUXC_MODEL_PBE_UKS.inp" = [{matcher="E_total", tol=5e-6, ref=-16.541584062034670}] "CH4_DIMER_GAUXC_PBE_D3.inp" = [{matcher="M033", tol=1e-14, ref=-0.00355123783846}] diff --git a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml index db816e3a27..3bd87ffe71 100644 --- a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml @@ -1,11 +1,11 @@ "H2_PBE_CDFT_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157232743213941}, {matcher="M071", tol=1e-8, ref=0.197625731046}] -"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229340943540}, +"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229554329094}, {matcher="M071", tol=1e-8, ref=0.197624070585}] "H2_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.216557647288}] "H2_GAPW_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.217417757774}] "H2_PBE_CDFT_CI_REFERENCE.inp" = [{matcher="M073", tol=1e-8, ref=345.364329058819}, {matcher="M077", tol=1e-8, ref=-1.16295181842678}] -"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325380057211}, - {matcher="M077", tol=1e-8, ref=-1.16294801624740}] +"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325437357859}, + {matcher="M077", tol=1e-8, ref=-1.16294823026735}] "H2_SKALA_CDFT_CI.inp" = [{matcher="M077", tol=5e-8, ref=-1.39020335005227}] diff --git a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml index babec12d78..274511571a 100644 --- a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml @@ -1,8 +1,8 @@ "HCl_GAPW_SKALA_ECP_ENERGY.inp" = [{matcher="E_total", tol=5e-6, ref=-15.464581508021762}] -"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44142596263930}] +"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.45263701}] "HCl_NATIVE_SKALA_GAPW_GPWTYPE_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36078871}] -"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.35170807520943}] +"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36291913}] "H2_NATIVE_SKALA_GAPW_ECP_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=6e-1, ref=0.0}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] diff --git a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml index dea40ed44e..80fac5377e 100644 --- a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml @@ -1,3 +1,3 @@ -"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] diff --git a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml index fbeaab6fca..300b8bb9d2 100644 --- a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml @@ -1,8 +1,8 @@ -"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] -"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833172}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833169}] "H2_NATIVE_SKALA_GAPW_GPWTYPE_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="M072", tol=1e-4, ref=5.37252718E-05}, {matcher="M031", tol=1e-5, ref=-8.58976831594E+04}] -"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.94877811114650}] +"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9698629747}] "H2_NATIVE_SKALA_GAPW_GTH_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=2e-1, ref=0.0}] "H2_NATIVE_SKALA_GAPW_GTH_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=2e-1, ref=0.0}] diff --git a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp index d2a3f65b34..683adc123c 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp +++ b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp @@ -27,7 +27,7 @@ &SCF EPS_SCF 1.0E-5 IGNORE_CONVERGENCE_FAILURE T - MAX_SCF 2 + MAX_SCF 1 SCF_GUESS ATOMIC &DIAGONALIZATION &END DIAGONALIZATION diff --git a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml index 5899459292..d1858ded5d 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml @@ -2,7 +2,7 @@ "H2_NATIVE_SKALA_GPW_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=5e-3, ref=0.0}] "H2P_NATIVE_SKALA_GPW_UKS_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=1e-3, ref=0.0}] "H2_NATIVE_SKALA_GPW_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] -"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-1.04111543882624}] +"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] "H2_NATIVE_SKALA_GPW_SMOOTH.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="SKALA_GPW_feature_electrons", tol=1e-8, ref=2.00000875882}, {matcher="SKALA_GPW_feature_spin_moment", tol=1e-12, ref=0.0}, diff --git a/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp b/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp deleted file mode 100644 index 995959e522..0000000000 --- a/tests/QS/regtest-gw-realspace/06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp +++ /dev/null @@ -1,82 +0,0 @@ -&GLOBAL - PRINT_LEVEL SILENT - PROJECT RIRS-G0W0-PBE-H2O - RUN_TYPE ENERGY -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME REGTEST_BASIS - POTENTIAL_FILE_NAME POTENTIAL - &MGRID - CUTOFF 300 - REL_CUTOFF 30 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER MULTIPOLE - &END POISSON - &QS - METHOD GAPW - &END QS - &SCF - EPS_SCF 1E-6 - MAX_SCF 500 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING T - ALPHA 0.2 - BETA 1.5 - METHOD BROYDEN_MIXING - NBUFFER 8 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - CUTOFF_RADIUS_RL_AO 1.5 - CUTOFF_RADIUS_RL_RI 1.5 - CUTOFF_RADIUS_RL_W 1.5 - GRID_SELECT 1 - NUM_TIME_FREQ_POINTS 10 - N_PANELS 2 - RI_RS - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 5 5 5 - MULTIPLE_UNIT_CELL 1 1 1 - PERIODIC NONE - &END CELL - &COORD - O 0.0000 0.0000 0.0000 - H 0.7571 0.0000 0.5861 - H -0.7571 0.0000 0.5861 - &END COORD - &KIND H - BASIS_SET H_MINI - BASIS_SET RI_AUX RI_H_MINI - POTENTIAL ALL - &END KIND - &KIND O - BASIS_SET O_MINI - BASIS_SET RI_AUX RI_O_MINI - POTENTIAL ALL - &END KIND - &TOPOLOGY - MULTIPLE_UNIT_CELL 1 1 1 - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-gw-realspace/RIRS-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix b/tests/QS/regtest-gw-realspace/RIRS-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix index d13f131f6f..6e19f1a2af 100644 Binary files a/tests/QS/regtest-gw-realspace/RIRS-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix and b/tests/QS/regtest-gw-realspace/RIRS-RESTART-G0W0-PBE-H2O-RESTART_Z_lP.matrix differ diff --git a/tests/QS/regtest-gw-realspace/TEST_FILES.toml b/tests/QS/regtest-gw-realspace/TEST_FILES.toml index 0be69d8db7..f83f347cc5 100644 --- a/tests/QS/regtest-gw-realspace/TEST_FILES.toml +++ b/tests/QS/regtest-gw-realspace/TEST_FILES.toml @@ -18,8 +18,4 @@ {matcher="E_RIRS_LUMO", tol=1e-03, ref=17.425}, {matcher="E_G0W0_direct_gap", tol=1e-03, ref=23.517}] -"06_RIRS_G0W0_PBE_H2O_CUTOFFS.inp" = [{matcher="E_RIRS_HOMO", tol=1e-03, ref=-6.234}, - {matcher="E_RIRS_LUMO", tol=1e-03, ref=18.334}, - {matcher="E_G0W0_direct_gap", tol=1e-03, ref=24.567}] - #EOF diff --git a/tests/QS/regtest-polar/TEST_FILES.toml b/tests/QS/regtest-polar/TEST_FILES.toml index 02631ef944..083c616850 100644 --- a/tests/QS/regtest-polar/TEST_FILES.toml +++ b/tests/QS/regtest-polar/TEST_FILES.toml @@ -9,6 +9,5 @@ "H2O_md_polar.inp" = [{matcher="M060", tol=6e-04, ref=0.619379304308}] "xTB_LRraman.inp" = [{matcher="M060", tol=2e-05, ref=0.807352993847}] "xTB_LRraman_loc.inp" = [{matcher="M060", tol=2e-05, ref=0.807352993847}] -"xTB_LRraman_spin.inp" = [] "h2o_LRraman_LRI.inp" = [{matcher="M060", tol=4e-04, ref=0.004283834553}] #EOF diff --git a/tests/QS/regtest-polar/xTB_LRraman_spin.inp b/tests/QS/regtest-polar/xTB_LRraman_spin.inp deleted file mode 100644 index 89a9914030..0000000000 --- a/tests/QS/regtest-polar/xTB_LRraman_spin.inp +++ /dev/null @@ -1,63 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - DE 0.0002 - DEBUG_DIPOLE F - DEBUG_FORCES F - DEBUG_POLARIZABILITY T - DEBUG_STRESS_TENSOR F - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 3 - &EFIELD - &END EFIELD - &PRINT - &MOMENTS ON - PERIODIC F - REFERENCE COM - &END MOMENTS - &END PRINT - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION F - &END XTB - &END QS - &SCF - EPS_SCF 1.e-7 - MAX_SCF 100 - SCF_GUESS MOPAC - &END SCF - &END DFT - &PROPERTIES - &LINRES - EPS 1.e-10 - PRECONDITIONER FULL_ALL - &POLAR - DO_RAMAN T - PERIODIC_DIPOLE_OPERATOR F - &END POLAR - &END LINRES - &END PROPERTIES - &SUBSYS - &CELL - ABC 20.0 20.0 20.0 - PERIODIC NONE - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL deleted file mode 100644 index a6fcdbb64b..0000000000 --- a/tests/QS/regtest-rtbse-linearized-open-shell/BASIS_MINIMAL +++ /dev/null @@ -1,31 +0,0 @@ -# Hydrogen def2-SVP (4s,1p) -> [2s,1p] -H def2-SVP-custom - 4 -1 0 0 1 1 - 1.9622572 0.13796524 -1 0 0 1 1 - 0.44453796 0.47831935 -1 0 0 1 1 - 0.3 1.0000000 -1 1 1 1 1 - 0.8000000 1.0000000 -H def2-SVP-RIFIT-custom - 9 -1 0 0 1 1 - 9.33521609 .64609379 -1 0 0 1 1 - 1.86110704 1.37005241 -1 0 0 1 1 - .59512466 1.0000000 -1 0 0 1 1 - .26448099 1.0000000 -1 1 1 1 1 - 2.45249821 .13284956 -1 1 1 1 1 - 1.35403830 1.45276215 -1 1 1 1 1 - .59522394 1.0000000 -1 2 2 1 1 - 1.58163766 1.49367397 -1 2 2 1 1 - .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml deleted file mode 100644 index c6a97429a4..0000000000 --- a/tests/QS/regtest-rtbse-linearized-open-shell/TEST_FILES.toml +++ /dev/null @@ -1,18 +0,0 @@ -"h2_linrtbse_tda_open_shell_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=12.1081}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=25.0470}] -"h2_linrtbse_tda_open_shell_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=12.1081}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=25.0470}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=4.3728481438E-001}, - {matcher="LinRTBSE_static_pol_xx_total", tol=1e-03, ref=8.7456962872E-001}] -"h2_linrtbse_abba_rirs_open_shell.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=11.9499}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=17.4347}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=24.9629}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=3.2821735047E-001}, - {matcher="LinRTBSE_static_pol_xx_total", tol=1e-03, ref=6.5643470094E-001}] -"h2_linrtbse_tda_full_rirs_open_shell.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=12.1081}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=25.0470}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=4.3729997326E-001}, - {matcher="LinRTBSE_static_pol_xx_total", tol=1e-03, ref=8.7459994651E-001}] diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp deleted file mode 100644 index fd94980402..0000000000 --- a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_abba_rirs_open_shell.inp +++ /dev/null @@ -1,106 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_RIRS_OPEN_SHELL - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Open-shell (LSD) ABBA with RI-RS Hartree+SEX: joint Liouvillian peaks + propagated alpha(0). -! STATIC_POL| TOT must equal the closed-shell RIRS ABBA alpha(0) at matched grid (forced-LSD -! identity), and equals 2 x the per-spin STATIC_POL| xx by spin symmetry. GRID_SELECT 2 per P-C12. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - LSD .TRUE. - MULTIPLICITY 1 - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - GRID_SELECT 2 - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp deleted file mode 100644 index d27dc72249..0000000000 --- a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_full_rirs_open_shell.inp +++ /dev/null @@ -1,108 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_FULL_RIRS_OPEN_SHELL - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Open-shell (LSD) TDA, full RI-RS: GW step (RI_RS T) AND Hartree+SEX kernels (KERNEL_RI RS) -! both in real-space. STATIC_POL| TOT must equal the closed-shell full-RIRS TDA alpha(0) at -! matched grid (forced-LSD identity), and equals 2 x the per-spin STATIC_POL| xx by spin -! symmetry. GRID_SELECT 2 per P-C12. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - LSD .TRUE. - MULTIPLICITY 1 - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - GRID_SELECT 2 - NUM_TIME_FREQ_POINTS 20 - RI_RS T - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp deleted file mode 100644 index 54841d1d7a..0000000000 --- a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart.inp +++ /dev/null @@ -1,107 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_OPEN_SHELL_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Open-shell (LSD) TDA: Liouvillian peaks + propagated alpha(0) + spin-total identity. -&MOTION - &MD - ENSEMBLE NVE - STEPS 10 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - ! Forced open shell: spin-polarized singlet H2 (n_alpha = n_beta = 1). - ! Must reproduce the closed-shell result -> spin-factor identity test. - LSD .TRUE. - MULTIPLICITY 1 - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp deleted file mode 100644 index bd8312c849..0000000000 --- a/tests/QS/regtest-rtbse-linearized-open-shell/h2_linrtbse_tda_open_shell_restart_cont.inp +++ /dev/null @@ -1,107 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_OPEN_SHELL_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Open-shell (LSD) TDA: Liouvillian peaks + propagated alpha(0) + spin-total identity. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - ! Forced open shell: spin-polarized singlet H2 (n_alpha = n_beta = 1). - ! Must reproduce the closed-shell result -> spin-factor identity test. - LSD .TRUE. - MULTIPLICITY 1 - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL deleted file mode 100644 index a6fcdbb64b..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/BASIS_MINIMAL +++ /dev/null @@ -1,31 +0,0 @@ -# Hydrogen def2-SVP (4s,1p) -> [2s,1p] -H def2-SVP-custom - 4 -1 0 0 1 1 - 1.9622572 0.13796524 -1 0 0 1 1 - 0.44453796 0.47831935 -1 0 0 1 1 - 0.3 1.0000000 -1 1 1 1 1 - 0.8000000 1.0000000 -H def2-SVP-RIFIT-custom - 9 -1 0 0 1 1 - 9.33521609 .64609379 -1 0 0 1 1 - 1.86110704 1.37005241 -1 0 0 1 1 - .59512466 1.0000000 -1 0 0 1 1 - .26448099 1.0000000 -1 1 1 1 1 - 2.45249821 .13284956 -1 1 1 1 1 - 1.35403830 1.45276215 -1 1 1 1 1 - .59522394 1.0000000 -1 2 2 1 1 - 1.58163766 1.49367397 -1 2 2 1 1 - .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml deleted file mode 100644 index 18222ca413..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/TEST_FILES.toml +++ /dev/null @@ -1,44 +0,0 @@ -"h2_linrtbse_tda_static_pol_shift_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=2.3524245107E-001}] -"h2_linrtbse_tda_static_pol_shift_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7460749367E-001}] -"h2_linrtbse_abba_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4346}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2290}] -"h2_linrtbse_abba_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4346}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2290}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5643997853E-001}] -"h2_linrtbse_tda_rirs_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5563}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=2.3524254536E-001}] -"h2_linrtbse_tda_rirs_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5563}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7460778986E-001}] -"h2_linrtbse_tda_restart_chain.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=2.3524244706E-001}] -"h2_linrtbse_tda_restart_chain_cont1.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7460748716E-001}] -"h2_linrtbse_tda_restart_chain_cont2.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.8576219499E+000}] -"h2_linrtbse_tda_enforce_restart.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.0586781424E+001}] -"h2_linrtbse_tda_enforce_restart_cont.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.0430371851E+000}] -#EOF diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp deleted file mode 100644 index 7e7bbbcd82..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ABBA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 10 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp deleted file mode 100644 index b62d9e39f0..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_abba_restart_cont.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ABBA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp deleted file mode 100644 index 3fa883dc97..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart.inp +++ /dev/null @@ -1,104 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_ENF_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ENFORCE_MAX_DT + restart (dump): rewrites TIMESTEP/STEPS to the max-stable dt, dumps the trace. -&MOTION - &MD - ENSEMBLE NVE - STEPS 100 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - ENFORCE_MAX_DT T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp deleted file mode 100644 index 652a49e243..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_enforce_restart_cont.inp +++ /dev/null @@ -1,104 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_ENF_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ENFORCE_MAX_DT + restart (cont): 3x window; ENFORCE inherits the trace dt and only rescales STEPS. -&MOTION - &MD - ENSEMBLE NVE - STEPS 300 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - ENFORCE_MAX_DT T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp deleted file mode 100644 index 0c68845a9d..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_CHAIN - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 10 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp deleted file mode 100644 index f97e89590a..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont1.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_CHAIN - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp deleted file mode 100644 index a3569c8eee..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_restart_chain_cont2.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_CHAIN - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 30 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp deleted file mode 100644 index 17dc778011..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart.inp +++ /dev/null @@ -1,104 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_RIRS_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA with RI-RS: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 10 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp deleted file mode 100644 index ed0351aa03..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_rirs_restart_cont.inp +++ /dev/null @@ -1,104 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_RIRS_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA with RI-RS: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp deleted file mode 100644 index 8fef5913b5..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart.inp +++ /dev/null @@ -1,109 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_SHIFT_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA + TDA_SHIFT_TO_FIRST_PEAK at fixed dt = h2_linrtbse_tda_static_pol.inp -! dt. Validates the rotating-frame round-trip identity at the alpha(0) -! layer: ref equals the unshifted baseline ref to ~1e-8. ENFORCE_MAX_DT -! deliberately not set here so the propagation accuracy matches the -! baseline; the auto-rescale code path is covered by the companion -! h2_linrtbse_tda_static_pol_shift_enforce_dt.inp. -&MOTION - &MD - ENSEMBLE NVE - STEPS 10 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - TDA_SHIFT_TO_FIRST_PEAK T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp b/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp deleted file mode 100644 index 83d8f9ff3e..0000000000 --- a/tests/QS/regtest-rtbse-linearized-restart/h2_linrtbse_tda_static_pol_shift_restart_cont.inp +++ /dev/null @@ -1,109 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_SHIFT_RST - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA + TDA_SHIFT_TO_FIRST_PEAK at fixed dt = h2_linrtbse_tda_static_pol.inp -! dt. Validates the rotating-frame round-trip identity at the alpha(0) -! layer: ref equals the unshifted baseline ref to ~1e-8. ENFORCE_MAX_DT -! deliberately not set here so the propagation accuracy matches the -! baseline; the auto-rescale code path is covered by the companion -! h2_linrtbse_tda_static_pol_shift_enforce_dt.inp. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN RT_RESTART - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART - &EACH - MD 1 - &END EACH - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - TDA_SHIFT_TO_FIRST_PEAK T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS RESTART - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL deleted file mode 100644 index a6fcdbb64b..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/BASIS_MINIMAL +++ /dev/null @@ -1,31 +0,0 @@ -# Hydrogen def2-SVP (4s,1p) -> [2s,1p] -H def2-SVP-custom - 4 -1 0 0 1 1 - 1.9622572 0.13796524 -1 0 0 1 1 - 0.44453796 0.47831935 -1 0 0 1 1 - 0.3 1.0000000 -1 1 1 1 1 - 0.8000000 1.0000000 -H def2-SVP-RIFIT-custom - 9 -1 0 0 1 1 - 9.33521609 .64609379 -1 0 0 1 1 - 1.86110704 1.37005241 -1 0 0 1 1 - .59512466 1.0000000 -1 0 0 1 1 - .26448099 1.0000000 -1 1 1 1 1 - 2.45249821 .13284956 -1 1 1 1 1 - 1.35403830 1.45276215 -1 1 1 1 1 - .59522394 1.0000000 -1 2 2 1 1 - 1.58163766 1.49367397 -1 2 2 1 1 - .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml deleted file mode 100644 index a76f855074..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/TEST_FILES.toml +++ /dev/null @@ -1,17 +0,0 @@ -"h2_linrtbse_abba_rirs.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4347}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2291}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5643377772E-001}] -"h2_linrtbse_tda_full_rirs.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0144}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2591}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5588}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7462404927E-001}] -"h2_linrtbse_tda_full_rirs_gridsel3.inp" = [{matcher="RIRS_Grid", tol=1e-03, ref=272}, - {matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0144}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2591}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5588}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7462404928E-001}] -"h2_linrtbse_abba_full_rirs.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.435}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0499}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2316}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5646779778E-001}] diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp deleted file mode 100644 index 89005502e7..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_full_rirs.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_FULL_RIRS - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Full RI-RS: GW step (RI_RS T) AND linRTBSE kernels (KERNEL_RI RS) both in real-space. -! ABBA: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - RI_RS T - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp deleted file mode 100644 index 2607e91c5e..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_abba_rirs.inp +++ /dev/null @@ -1,101 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_RIRS - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ABBA with RI-RS: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp deleted file mode 100644 index 03999b1ade..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_FULL_RIRS - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Full RI-RS: GW step (RI_RS T) AND linRTBSE kernels (KERNEL_RI RS) both in real-space. -! TDA: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - RI_RS T - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp b/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp deleted file mode 100644 index 8a70f86104..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/h2_linrtbse_tda_full_rirs_gridsel3.inp +++ /dev/null @@ -1,107 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_FULL_RIRS_GRIDSEL3 - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! Full RI-RS: GW step (RI_RS T) AND linRTBSE kernels (KERNEL_RI RS) both in real-space. -! TDA: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -! GRID_SELECT 3: reads user-provided grid ri_rs_grid/H_rirs.ion (a copy of the built-in -! H def2-TZVPP grid), so results match h2_linrtbse_tda_full_rirs.inp exactly. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - KERNEL_RI RS - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - GRID_FILE_SUFFIX _rirs.ion - GRID_SELECT 3 - NUM_TIME_FREQ_POINTS 20 - RI_RS T - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion b/tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion deleted file mode 100644 index 5594c318cf..0000000000 --- a/tests/QS/regtest-rtbse-linearized-rirs/ri_rs_grid/H_rirs.ion +++ /dev/null @@ -1,178 +0,0 @@ -R"( - -beDeft - a general framework for molecular all electron calculation. - -Copyright (C) 2018 Ivan Duchemin. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program. If not, see - - -Please consider citing the following works upon use of these data: - -1) "Separable resolution-of-the-identity with all-electron Gaussian bases: Application to cubic-scaling RPA", - J. Chem. Phys. 150, 174120 (2019); https://doi.org/10.1063/1.5090605; - -2) "Cubic-scaling all-electron GW calculations with a separable density-fitting space-time approach", - J. Chem. Theory Comput. 2021, 17, 2383−2393; https://doi.org/10.1021/acs.jctc.1c00101 - - - - Def2-TZVP realspace grid (Bohr) for species H - sqr error : 6.239134422007024e-07 - penalty : 9.830708520256151e-23 - n points : 136 - - - -0.2954148854501534 -0.1335642491691153 0.05068066035374287 - 0.1816380973401107 0.1859817433782612 -0.1386401349055483 - -0.01597099546061177 0.1287618520530735 -0.07001358047206471 - -0.02613587467036126 0.08932538392091835 -0.002838074440176907 - -0.06842058257872188 -0.08566817521093061 0.08522166521479257 - -0.08225046126705603 -0.169501604718487 0.2549724944661679 - 0.2566196514993097 0.02211931854806932 0.142291062832903 - -0.07432372098974464 0.3223691064275651 0.06297929572928379 - 0.5074128993367629 -0.1791359313809102 -0.0781260060975192 - 0.06377427096181078 -0.07385931271461051 -0.08061937700991234 - -0.2969263564043537 0.1835711887428562 0.2067556007423259 - -0.06453055224680186 -0.1031342172240359 -0.317980395159791 - 0.2576605683435805 -0.3838479590546792 0.2673057038155396 - 0.09375518435061178 -0.2976176406243511 -0.01906421437674757 - 0.4771926409809089 0.2922163830521363 0.02153261927022125 - -0.4636605785871395 0.08499757183189958 -0.299276732604827 - -0.2595208082744394 0.3547958371317465 -0.2665160678781763 - -0.2749286409788823 -0.7369205695678908 -0.1188292257217835 - 0.2549566965223938 0.2120087894499723 0.4875937267111851 - 0.01263024634950976 -0.1496465158019567 -0.5863211366757152 - 0.6092984024971327 0.3363041511085897 0.2956918277854952 - 0.3077528660372704 0.5702771675995133 -0.2667627149719398 - 0.5706572867358498 -0.4028291070114693 0.472261566923234 - -0.08732410746681919 -0.4695925942855174 -0.3312453981989941 - -0.3194955737060983 0.388255706300542 0.3606322363101925 - -0.3882238756537889 0.6148729513757498 -0.4588421906704931 - -0.3721076445655269 -0.3664319169266803 0.3063240634272202 - -0.6578182898786117 -0.3587293855625903 -0.7454097305649954 - 0.2676857645955618 0.4058854962776672 0.7737880094680426 - 0.07786322505044226 0.1290359974109117 -0.9514045020997184 - -0.171803174335231 -0.3514768864368197 0.9180878015565798 - -0.1216269833072627 -0.663968496194337 -0.437608991253138 - 1.012027349643134 0.04280907557983676 0.2504232797717886 - 0.6772643299868553 -0.05966251142429058 -0.5493110674680531 - -0.7879285661487034 0.04593973450695941 0.4364578161879538 - -0.8810944194566616 -0.0586058830290971 0.02493812429096716 - 0.5525404551554352 0.8899610424197217 0.1927159540384068 - 0.1973548327951684 -0.8948327022491742 -0.06779905589808827 - -0.2428330945547142 0.9520180594383421 0.1505703767119264 - -0.4300348963260354 -1.145077902046179 -0.0398244407094291 - 1.493438328940796 0.2234522049017941 0.1586963181828461 - -1.420009391972234 0.04880012290290694 -0.01272030194773821 - 0.370336777038307 1.393696713926728 0.3563309933622616 - 0.03596820161388265 -1.620511020943682 -0.04600475745536303 - -0.246857987452724 -0.254489864657869 1.447543723337624 - 0.1515831369116101 0.2103434357956588 -1.425970826722582 - 0.5884837125283602 0.4569762186942013 1.197638705723065 - 0.7261001342742653 0.8048720160671126 -0.645947568921209 - 0.780454043312149 -0.8455753384329407 0.6924299536886032 - 0.8454815993828603 -0.6930452376567066 -0.6702792306271542 - -0.7367507994895405 0.7132600395780444 0.8222503783520255 - -0.7061861646621481 0.8709347860404515 -0.6603936233806971 - -0.8405660361591353 -0.891974044265645 0.5812665168699227 - -0.5406958934351653 -0.7741565343905341 -0.879371590600466 - -0.04548167809185187 1.328634312426442 1.444513633533263 - 0.1267532093088906 1.536874286263144 -0.8919445946021033 - -0.08177892219767004 -1.208436585686179 1.363775012098787 - 0.1437908993059976 -1.162347310971533 -1.291252673238762 - 1.43168773682342 -0.3485929236252875 1.240293116262541 - 1.434079597048868 0.1767576291709002 -1.137212145662909 - -0.8906442592741174 0.06769573466985666 1.616646445018519 - -1.138118774959164 -0.03600675055748099 -1.185744552241386 - 1.306639353413664 1.316794577063328 0.224362958316805 - 1.520294807606466 -1.151999919916459 -0.1434617308954618 - -1.135535335000177 1.429764541411139 0.149348319835903 - -1.379588940939161 -1.287164087706267 -0.3638664692790708 - 1.135901397318623 0.1164378869420764 1.799986052433409 - -0.06092809947094797 0.5389792920119644 -2.052407126379629 - 0.8659069822457162 -0.5287669302210813 2.414973249952283 - 0.3238969383288228 -1.044403158358488 -2.027041699385781 - -0.7037365637682088 0.8007355576793537 2.401823446659314 - -0.7616261348246457 0.6822675550175186 -2.179171422197027 - -0.1613395649287358 -0.9544031371217349 2.332941541520295 - -0.9849325312503632 -0.4611837408212853 -1.698183184336927 - 0.8834930082403905 2.30834534846518 0.5072986264034914 - 0.7063601403425823 -1.8308093618429 0.791920808794972 - 0.02660907542483082 2.84206894177436 -0.3816015304498044 - 0.4146911264218839 -2.325133341064756 0.02467211535352986 - -0.823973467966634 2.122340559500701 1.235262821894633 - -0.9941744716000603 -2.305186376110722 0.5349649701821696 - -0.1469993861343339 2.393974399194733 -0.5076019482686613 - -1.75385290980192 -1.693186218488545 -1.177983394672746 - 1.777130165290716 1.243627909267864 0.4352899633443738 - -2.20543349423593 0.1720157402311745 1.646799368363265 - 1.890217127261714 0.8626024039832499 -1.451653838111088 - -1.806305643277792 0.8447557607714012 -0.8733043427285732 - 2.461476664832692 -0.977192553258759 0.5771483890078972 - -1.755389316642568 -0.298415913288883 0.9493476710191535 - 2.511342716444165 -0.7826761918361477 -0.443419672763977 - -2.613500382250666 0.4571764429841054 0.3654228625968752 - 3.842093941989271 -0.5596712038126999 -0.0830152301203563 - -3.303808201144906 1.186546058824115 0.1729525823189399 - 0.1019292209756146 3.870289021315343 -0.4844977826791424 - 0.9993214038771049 -3.210427913736408 0.1050620773165616 - -0.2710547188512861 0.2947295399751631 3.504255324959454 - -0.3212853050950602 0.4715566184738518 -3.124664646376012 - 2.240578993085218 1.539951611266878 1.712946236910111 - 1.954624736966228 1.532501952028746 -2.33502122460108 - 1.162348391446048 -2.189889361989135 2.287333621015383 - 0.9791446568748993 -1.35083126368944 -2.776056099800358 - -1.032916704381661 2.018895928939019 2.748827790004297 - -1.886613895569877 1.141411050846112 -2.3239627239242 - -2.276817534392566 -2.256243245291318 1.519695792432714 - -2.296605293421468 -2.279528689561137 -2.407061522713857 - -0.5378515610262312 2.995190087826248 3.727450480799551 - 0.2788971834667044 3.062743170796157 -3.300175415509675 - 1.044201127141902 -3.245015083631762 3.07482403498685 - 0.8221329095371132 -2.533798671359024 -3.830096168310633 - 2.85074581995006 0.9766206224297082 3.363494378292772 - 2.679732587825186 1.31493423638742 -3.419274916029694 - -2.714504415966226 -1.069699222760358 3.465556406006018 - -3.019087366940264 0.9393774611356079 -3.154465162712406 - 3.242058878301219 2.758076700812236 1.674383894974962 - 3.120878533637019 -3.117430400439883 -0.09370439952600086 - -4.024724316009742 2.201322471341542 0.4236906588617514 - -3.26725678044431 -3.223955401278664 1.908196283114998 - 5.24849087715614 -0.7868672527375579 -0.06904248353174197 - -5.067328822546462 1.461410994380679 0.009568493557033262 - 0.1462143140361931 5.193500216986119 -0.8478591823519535 - 0.923645755665048 -4.869913641848457 0.6379341843324277 - -0.4358916800240319 0.6259140461626954 4.852631981153478 - 0.6322734786742126 -0.447993089774717 -4.889202076375438 - 3.073392322443376 3.449251893752574 4.264280316578882 - 3.367702599071051 3.549969446242695 -4.017012277611613 - 3.978591646756478 -3.745470275474244 3.854364927815283 - 3.5027874861621 -2.382325362877358 -5.15555162474973 - -3.107356934525352 3.285834949451149 5.178688546831546 - -4.418757220935039 2.870176264845758 -4.004471425971643 - -3.159785277198654 -4.027783912332535 3.91687587720759 - -2.973196995468781 -3.6629085247764 -3.677276218708017 - 7.023557063449501 -1.268441622108083 0.7327315371929585 - -7.276487313381022 1.505075264128465 0.1725678662932084 - 0.03872733113535301 6.604561443953888 -0.8430874770179861 - 1.165180385948926 -6.725095131329835 0.32860753596807 - -0.9198921590452458 0.6273748722982888 6.746196815020086 - 0.5074704985894842 -0.1886430394326983 -7.11743012671049 - -)" - - - - diff --git a/tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL b/tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL deleted file mode 100644 index a6fcdbb64b..0000000000 --- a/tests/QS/regtest-rtbse-linearized/BASIS_MINIMAL +++ /dev/null @@ -1,31 +0,0 @@ -# Hydrogen def2-SVP (4s,1p) -> [2s,1p] -H def2-SVP-custom - 4 -1 0 0 1 1 - 1.9622572 0.13796524 -1 0 0 1 1 - 0.44453796 0.47831935 -1 0 0 1 1 - 0.3 1.0000000 -1 1 1 1 1 - 0.8000000 1.0000000 -H def2-SVP-RIFIT-custom - 9 -1 0 0 1 1 - 9.33521609 .64609379 -1 0 0 1 1 - 1.86110704 1.37005241 -1 0 0 1 1 - .59512466 1.0000000 -1 0 0 1 1 - .26448099 1.0000000 -1 1 1 1 1 - 2.45249821 .13284956 -1 1 1 1 1 - 1.35403830 1.45276215 -1 1 1 1 1 - .59522394 1.0000000 -1 2 2 1 1 - 1.58163766 1.49367397 -1 2 2 1 1 - .62743960 -.01070690 diff --git a/tests/QS/regtest-rtbse-linearized/TEST_FILES.toml b/tests/QS/regtest-rtbse-linearized/TEST_FILES.toml deleted file mode 100644 index b80dc416ac..0000000000 --- a/tests/QS/regtest-rtbse-linearized/TEST_FILES.toml +++ /dev/null @@ -1,28 +0,0 @@ -"h2_linrtbse_tda.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0141}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2581}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=8.7459921259E-001}] -"h2_linrtbse_abba.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4346}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0489}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2290}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5643331047E-001}] -"h2_linrtbse_tda_kernels_off.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=25.4441}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=38.2217}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=51.6650}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.1831301628E+000}] -"h2_linrtbse_abba_kernels_off.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=25.4441}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=38.2217}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=51.6650}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.1831301629E+000}] -"h2_linrtbse_abba_cutoff.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=17.4514}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.0919}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.2515}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=6.5525719890E-001}] -"h2_linrtbse_tda_static_pol_enforce_dt.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.2304185308E+000}] -"h2_linrtbse_tda_static_pol_shift_enforce_dt.inp" = [{matcher="LinRTBSE_1st_excit_ener", tol=1e-04, ref=18.0137}, - {matcher="LinRTBSE_2nd_excit_ener", tol=1e-04, ref=30.2577}, - {matcher="LinRTBSE_3rd_excit_ener", tol=1e-04, ref=42.5562}, - {matcher="LinRTBSE_static_pol_xx", tol=1e-03, ref=1.2305942151E+000}] diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp deleted file mode 100644 index 57595ce016..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba.inp +++ /dev/null @@ -1,100 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ABBA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp deleted file mode 100644 index 400f81c1be..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_cutoff.inp +++ /dev/null @@ -1,102 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_CUTOFF - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ABBA under ENERGY_CUTOFF truncation: Liouvillian peaks + propagated alpha(0). -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - ENERGY_CUTOFF_EMPTY 40 - ENERGY_CUTOFF_OCC 20 - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp deleted file mode 100644 index 14456d377e..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_abba_kernels_off.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_ABBA_KERNELS_OFF - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! ABBA, all kernels disabled: B=0 reduces ABBA to TDA-bare-diag; peaks + -! alpha(0) must match the TDA kernels-off counterpart. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DEBUG_DISABLE_HARTREE T - DEBUG_DISABLE_SEX T - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA F - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp deleted file mode 100644 index e68102e6b8..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda.inp +++ /dev/null @@ -1,100 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA linRTBSE: Liouvillian-diagnostic peaks + propagated alpha(0) in one job. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp deleted file mode 100644 index 24e2c0bd9c..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_kernels_off.inp +++ /dev/null @@ -1,103 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_KERNELS_OFF - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA, all kernels disabled: Liouvillian collapses to diag(eps_ai); peaks + -! alpha(0) must match the ABBA kernels-off counterpart (B=0 -> ABBA = TDA-bare). -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DEBUG_DISABLE_HARTREE T - DEBUG_DISABLE_SEX T - DIAGNOSE_LIOUVILLIAN_EIG T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp deleted file mode 100644 index 5200cc2732..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_enforce_dt.inp +++ /dev/null @@ -1,105 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_ENFORCE_DT - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA without rotating-frame shift + ENFORCE_MAX_DT. Counterpart to the -! _shift_enforce_dt test: covers the lab-frame branch of the ENFORCE_MAX_DT -! auto-rescale (omega_max set from lab-frame Liouvillian spectral extent, -! not the shifted-frame width). Locks alpha(0) for this code path; does -! not cross-check against the baseline. -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - ENFORCE_MAX_DT T - LRRTBSE T - TDA T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp b/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp deleted file mode 100644 index 112e198cdc..0000000000 --- a/tests/QS/regtest-rtbse-linearized/h2_linrtbse_tda_static_pol_shift_enforce_dt.inp +++ /dev/null @@ -1,108 +0,0 @@ -&GLOBAL - PROJECT_NAME H2_LINRTBSE_TDA_STATIC_POL_SHIFT_ENFORCE_DT - RUN_TYPE RT_PROPAGATION -&END GLOBAL - -! TDA + TDA_SHIFT_TO_FIRST_PEAK + ENFORCE_MAX_DT static-pol regression gate. -! Covers the auto-rescale code path: ENFORCE_MAX_DT recomputes dt under the -! rotating frame (here: 1 as -> 16.67 as, STEPS 100 -> 6, same total time). -! Resulting alpha(0) drifts from the unshifted baseline by ~2.7% due to RK4 -! phase error at the larger dt; the value is locked as a "this hasn't -! drifted" gate, NOT as a round-trip identity check (see the companion -! h2_linrtbse_tda_static_pol_shift.inp for the identity check at fixed dt). -&MOTION - &MD - ENSEMBLE NVE - STEPS 20 - TEMPERATURE [K] 0.0 - TIMESTEP [fs] 1e-3 - &END MD -&END MOTION - -&FORCE_EVAL - METHOD QS - &DFT - BASIS_SET_FILE_NAME BASIS_MINIMAL - POTENTIAL_FILE_NAME ALL_POTENTIALS - &MGRID - CUTOFF 150 - REL_CUTOFF 40 - &END MGRID - &POISSON - PERIODIC NONE - POISSON_SOLVER WAVELET - &END POISSON - &QS - EPS_DEFAULT 1.0E-10 - METHOD GAPW - &END QS - &REAL_TIME_PROPAGATION - APPLY_DELTA_PULSE - DELTA_PULSE_DIRECTION 1 0 0 - DELTA_PULSE_SCALE 1.0E-5 - INITIAL_WFN SCF_WFN - &FT - DAMPING 5.0 - &END FT - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &RTBSE - DIAGNOSE_LIOUVILLIAN_EIG T - ENFORCE_MAX_DT T - LRRTBSE T - TDA T - TDA_SHIFT_TO_FIRST_PEAK T - &END RTBSE - &END REAL_TIME_PROPAGATION - &SCF - ADDED_MOS -1 - EPS_SCF 1.0E-6 - MAX_SCF 200 - SCF_GUESS ATOMIC - &DIAGONALIZATION ON - ALGORITHM STANDARD - &END DIAGONALIZATION - &MIXING - ALPHA 0.4 - METHOD BROYDEN_MIXING - NBROYDEN 4 - &END MIXING - &END SCF - &XC - &XC_FUNCTIONAL PBE0 - &END XC_FUNCTIONAL - &END XC - &END DFT - &PROPERTIES - &BANDSTRUCTURE - &GW - NUM_TIME_FREQ_POINTS 20 - &PRINT - &RESTART OFF - &END RESTART - &END PRINT - &END GW - &END BANDSTRUCTURE - &END PROPERTIES - &SUBSYS - &CELL - ABC 10.0 10.0 10.0 - PERIODIC NONE - &END CELL - &COORD - H 0.0 0.0 0.0 - H 0.74 0.0 0.0 - &END COORD - &KIND H - BASIS_SET ORB def2-SVP-custom - BASIS_SET RI_AUX def2-SVP-RIFIT-custom - POTENTIAL ALL - &END KIND - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-rtbse/h2_delta_cont.inp b/tests/QS/regtest-rtbse/h2_delta_cont.inp index 511db23599..c4d4841740 100644 --- a/tests/QS/regtest-rtbse/h2_delta_cont.inp +++ b/tests/QS/regtest-rtbse/h2_delta_cont.inp @@ -49,10 +49,6 @@ &PRINT &MOMENTS &END MOMENTS - &MOMENTS_FT OFF - &END MOMENTS_FT - &POLARIZABILITY OFF - &END POLARIZABILITY &END PRINT &RTBSE &END RTBSE diff --git a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml index e821736011..15a43ace67 100644 --- a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml +++ b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml @@ -12,10 +12,10 @@ {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53343196E+00}] "test04.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102641E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53056622E+00}] -"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101772E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53053109E+00}] -"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102040E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.51211743E+00}] +"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101974E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53306556E+00}] +"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102171E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.52845348E+00}] "test07.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101792E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.55939759E+00}] "test08.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.103120E+01}, diff --git a/tests/QS/regtest-tddfpt-4/test05.inp b/tests/QS/regtest-tddfpt-4/test05.inp index a52cb822b3..ca5adb36c1 100644 --- a/tests/QS/regtest-tddfpt-4/test05.inp +++ b/tests/QS/regtest-tddfpt-4/test05.inp @@ -11,8 +11,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 120 - REL_CUTOFF 50 + CUTOFF 200 + REL_CUTOFF 60 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/QS/regtest-tddfpt-4/test06.inp b/tests/QS/regtest-tddfpt-4/test06.inp index 7e9dbaa5e7..8ac7bef886 100644 --- a/tests/QS/regtest-tddfpt-4/test06.inp +++ b/tests/QS/regtest-tddfpt-4/test06.inp @@ -19,8 +19,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 120 - REL_CUTOFF 30 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/SE/regtest-2-1/TEST_FILES.toml b/tests/SE/regtest-2-1/TEST_FILES.toml index ba19a11cbe..c8541848d7 100644 --- a/tests/SE/regtest-2-1/TEST_FILES.toml +++ b/tests/SE/regtest-2-1/TEST_FILES.toml @@ -10,7 +10,7 @@ "ch4-restart.inp" = [{matcher="M003", tol=1.0E-14, ref=-180.05471494670982}] "h2o.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315272006}] "h2o_lsd.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315083575}] -"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974541340}] +"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974557710}] "hcn.inp" = [{matcher="M003", tol=1.0E-14, ref=-346.49686119222844}] "hf.inp" = [{matcher="M003", tol=1.0E-14, ref=-499.98506659307861}] "nh4.inp" = [{matcher="M003", tol=1.0E-14, ref=-256.98965446201572}] diff --git a/tests/SE/regtest-2-2/TEST_FILES.toml b/tests/SE/regtest-2-2/TEST_FILES.toml index 1a53a9fbfc..e0c012c482 100644 --- a/tests/SE/regtest-2-2/TEST_FILES.toml +++ b/tests/SE/regtest-2-2/TEST_FILES.toml @@ -14,7 +14,7 @@ "FeC.inp" = [{matcher="M003", tol=1.0E-14, ref=-545.05816363206452}] "FeH_1cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-427.83088810217504}] "FeH_7cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-144.32569270051397}] -"FeH_8cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-46.77363824961697}] +"FeH_8cat.inp" = [{matcher="M003", tol=1.0E-14, ref=-46.77363824958222}] "FeH_9cat.inp" = [{matcher="M029", tol=1.0E-14, ref=11798.83943644446481}] "Pt-cis-2xpet3Cl2-si.inp" = [{matcher="M003", tol=3e-14, ref=-3116.3314196834754}] "Pt-cis-2xpet3Cl2-si-noc.inp" = [{matcher="M003", tol=8e-14, ref=-3116.62376488246764}] diff --git a/tests/SE/regtest/TEST_FILES.toml b/tests/SE/regtest/TEST_FILES.toml index af15e3f9bc..ca5a64504c 100644 --- a/tests/SE/regtest/TEST_FILES.toml +++ b/tests/SE/regtest/TEST_FILES.toml @@ -10,7 +10,7 @@ "ch4-restart.inp" = [{matcher="M003", tol=1.0E-14, ref=-180.05471494670982}] "h2o.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315272017}] "h2o_lsd.inp" = [{matcher="M003", tol=1.0E-14, ref=-348.56201315083575}] -"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974541340}] +"h2op.inp" = [{matcher="M003", tol=1.0E-14, ref=-325.35457974557710}] "hcn.inp" = [{matcher="M003", tol=1.0E-14, ref=-346.49686119222844}] "hf.inp" = [{matcher="M003", tol=1.0E-14, ref=-499.98506659307856}] "nh4.inp" = [{matcher="M003", tol=1.0E-14, ref=-256.98965446201606}] @@ -21,10 +21,10 @@ # tests for high-spin ROKS "O-ROKS.inp" = [{matcher="M003", tol=1.0E-14, ref=-316.09951999999998}] "O2-ROKS.inp" = [{matcher="M003", tol=1.0E-14, ref=-641.56947944509795}] -"NO2-ROKS.inp" = [{matcher="M003", tol=2.0e-14, ref=-746.41195754911630}] +"NO2-ROKS.inp" = [{matcher="M003", tol=2.0e-14, ref=-746.41195754911917}] #RM1 Model "c2h4_rm1.inp" = [{matcher="M003", tol=1.0E-14, ref=-306.76506723638988}] -"h2op_2.inp" = [{matcher="M003", tol=2.0e-10, ref=-329.25843400085944}] +"h2op_2.inp" = [{matcher="M003", tol=2.0e-10, ref=-329.25843415861925}] "h2po4.inp" = [{matcher="M003", tol=1.0e-11, ref=-2630.34613336826851}] "geom.inp" = [{matcher="M003", tol=3.0e-14, ref=-5484.9811538371541}] "b2h6_pm6.inp" = [{matcher="M003", tol=2.0e-14, ref=-191.26932146375466}] diff --git a/tests/SLOW_TESTS_SUPPRESSIONS b/tests/SLOW_TESTS_SUPPRESSIONS index 41f70b7b64..f14fa41996 100644 --- a/tests/SLOW_TESTS_SUPPRESSIONS +++ b/tests/SLOW_TESTS_SUPPRESSIONS @@ -99,11 +99,4 @@ QS/regtest-gauxc-gpw-mech/H2P_NATIVE_SKALA_GPW_UKS_PBC_FORCE_DEBUG.inp QS/regtest-gauxc-gapw-gth/H2_NATIVE_SKALA_GAPW_GTH_STRESS_DEBUG.inp QS/regtest-gauxc-gapw-ecp/H2_NATIVE_SKALA_GAPW_ECP_STRESS_DEBUG.inp -# Open-shell BSE on O2: an all-electron G0W0 step followed by the full BSE -# diagonalisation for both spin channels. O2 is the only open-shell reference -# system in the suite that is not H2, so the cost cannot be reduced further -# without losing that coverage. -QS/regtest-bse/TDA_O2_PBE_UKS_G0W0.inp -QS/regtest-bse/ABBA_O2_PBE_UKS_G0W0.inp - #EOF diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index a989dfad6b..268a1b191e 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -3,7 +3,6 @@ # Directories have been reordered according the execution time needed for a gfortran pdbg run using 2 MPI tasks # in case a new directory is added just add it at the top of the list.. # the order will be regularly checked and modified... -Fist/regtest-mace libtorch QS/regtest-floquet QS/regtest-dft-d4-auto-ref libdftd4 libint !ifx QS/regtest-dft-d2-auto-ref libint !ifx @@ -71,7 +70,6 @@ QS/regtest-ot QS/regtest-openpmd openpmd QS/regtest-ec-force libint !ifx QS/regtest-embed libint !ifx -xTB/regtest-spinpol xTB/regtest-5 xTB/regtest-gfn1-d spglib QS/regtest-gpw-2-3 @@ -220,7 +218,7 @@ Fist/regtest-1-3 QS/regtest-md-extrap Fist/regtest-15 xTB/regtest-3 -xTB/regtest-3-spglib spglib tblite +xTB/regtest-3-spglib spglib QS/regtest-debug-3 libint libxc !ifx QS/regtest-lrigpw-2 QS/regtest-hybrid-4 libint libxc !ifx @@ -301,10 +299,6 @@ QS/regtest-as-3 libint mpiranks%2==0 QS/regtest-gpw-7 mpiranks<4 QS/regtest-bse libint !ifx QS/regtest-rtbse libint !ifx -QS/regtest-rtbse-linearized libint !ifx -QS/regtest-rtbse-linearized-rirs libint !ifx -QS/regtest-rtbse-linearized-open-shell libint !ifx -QS/regtest-rtbse-linearized-restart libint !ifx QS/regtest-smeagol-1 QS/regtest-smeagol-2 libsmeagol QS/regtest-mp2-admm-stress libint !ifx diff --git a/tests/do_regtest.py b/tests/do_regtest.py index a065373ea0..045ce266f7 100755 --- a/tests/do_regtest.py +++ b/tests/do_regtest.py @@ -209,7 +209,7 @@ async def main() -> None: print("\n".join(r.error for r in all_results if r.error)) print("\n------------------------------- Timings --------------------------------") - timings = sorted(r.duration for r in all_results if r.duration) + timings = sorted(r.duration for r in all_results) print('Plot: name="timings", title="Timing Distribution", ylabel="time [s]"') for p in (100, 99, 98, 95, 90, 80): y = percentile(timings, p / 100.0) @@ -219,9 +219,7 @@ async def main() -> None: if cfg.flag_slow: print("\n" + "-" * 15 + "--------------- Slow Tests ---------------" + "-" * 15) threshold = 2 * percentile(timings, 0.95) - outliers = [ - r for r in all_results if r.duration and r.duration > 0.95 * threshold - ] + outliers = [r for r in all_results if r.duration > 0.95 * threshold] maybe_slow = [r for r in outliers if r.fullname not in cfg.slow_suppressions] num_suppressed = len(outliers) - len(maybe_slow) rerun_tasks: List[Task[BatchResult]] = [] @@ -230,14 +228,8 @@ async def main() -> None: rerun_tasks.append(asyncio.get_event_loop().create_task(run_batch(b, cfg))) rerun_times: Dict[str, float] = {} for t in await asyncio.gather(*rerun_tasks): - rerun_times.update( - {r.fullname: r.duration for r in t.results if r.duration} - ) - stats = { - r.fullname: [r.duration, rerun_times[r.fullname]] - for r in maybe_slow - if r.duration - } + rerun_times.update({r.fullname: r.duration for r in t.results}) + stats = {r.fullname: [r.duration, rerun_times[r.fullname]] for r in maybe_slow} slow_tests = {k: v for k, v in stats.items() if mean(v) - stdev(v) > threshold} print(f"Duration threshold (2x 95th %ile): {threshold:.2f} sec") print(f"Found {len(slow_tests)} slow tests ({num_suppressed} suppressed):") @@ -432,7 +424,7 @@ class TestResult: batch: Batch, test: Union[Regtest, Unittest], spec: Optional[Dict[str, Any]], - duration: Optional[float], + duration: float, status: TestStatus, error: Optional[str] = None, value: Optional[float] = None, @@ -451,8 +443,7 @@ class TestResult: if self.spec and len(self.test.matcher_specs) > 1: display_name += f":{self.spec.get('matcher', '???')}" value = f"{self.value:.10g}" if self.value else "-" - timing = f" ( {self.duration:6.2f} sec)" if self.duration else "" - return f" {display_name :<80s} {value :>17} {self.status :>12s}{timing}" + return f" {display_name :<80s} {value :>17} {self.status :>12s} ( {self.duration:6.2f} sec)" # ====================================================================================== @@ -460,7 +451,7 @@ class BatchResult: def __init__(self, batch: Batch, results: List[TestResult]): self.batch = batch self.results = results - self.duration = sum(r.duration for r in results if r.duration) + self.duration = sum(float(r.duration) for r in results) # ====================================================================================== @@ -676,10 +667,9 @@ def eval_regtest( if not test.matcher_specs: return [TestResult(batch, test, None, duration, "OK")] - # Only the first matcher carries the duration of the single test execution. + # run the matchers results = [] - for i, spec in enumerate(test.matcher_specs): - matcher_duration = duration if i == 0 else None + for spec in test.matcher_specs: spec = dict(spec) # shallow copy so we can pop without mutating the original alt_file = spec.pop("file", None) if alt_file: @@ -687,7 +677,7 @@ def eval_regtest( if not alt_path.exists(): err = f"{error}Spec: {spec}\nExpected output file not found: {alt_path}" results += [ - TestResult(batch, test, spec, matcher_duration, "WRONG RESULT", err) + TestResult(batch, test, spec, duration, "WRONG RESULT", err) ] continue match_output = alt_path.read_bytes().decode("utf8", errors="replace") @@ -696,9 +686,7 @@ def eval_regtest( m = run_matcher(match_output, **spec) if m.error: m.error = f"{error}Spec: {spec}\n{m.error}" - results += [ - TestResult(batch, test, spec, matcher_duration, m.status, m.error, m.value) - ] + results += [TestResult(batch, test, spec, duration, m.status, m.error, m.value)] return results diff --git a/tests/i-PI/ipi_client.inp b/tests/i-PI/ipi_client.inp index 06bd0455fe..acce5d04fe 100644 --- a/tests/i-PI/ipi_client.inp +++ b/tests/i-PI/ipi_client.inp @@ -8,7 +8,6 @@ &DRIVER HOST myHost PORT 8421 - PREFIX ipi UNIX &END DRIVER &END MOTION diff --git a/tests/i-PI/ipi_server.inp b/tests/i-PI/ipi_server.inp index db556e3fd5..1188cfb18e 100644 --- a/tests/i-PI/ipi_server.inp +++ b/tests/i-PI/ipi_server.inp @@ -6,9 +6,8 @@ &MOTION &DRIVER - HOST myHost + HOST "/tmp/qiskit_myHost" PORT 8421 - PREFIX ipi SLEEP_TIME 0.1 UNIX &END DRIVER diff --git a/tests/matchers.py b/tests/matchers.py index f38024004b..f91c1f3f69 100644 --- a/tests/matchers.py +++ b/tests/matchers.py @@ -256,27 +256,6 @@ registry["E_evGW_gap"] = GenericMatcher( registry["M113"] = GenericMatcher(r"BSE| 1 -TDA-", col=7) registry["M114"] = GenericMatcher(r"BSE| 1 -ABBA-", col=7) - -# Open-shell (UKS) BSE matchers: joint-spectrum energies and oscillator strength -registry["BSE_1st_excit_ener_UKS"] = GenericMatcher( - r"BSE| 1 UKS -TDA-", col=5 -) -registry["BSE_2nd_excit_ener_UKS"] = GenericMatcher( - r"BSE| 2 UKS -TDA-", col=5 -) -registry["BSE_osc_str_n2_UKS"] = GenericMatcher(r"BSE| 2 -TDA-", col=7) -registry["BSE_1st_excit_ener_UKS_ABBA"] = GenericMatcher( - r"BSE| 1 UKS -ABBA-", col=5 -) -registry["BSE_2nd_excit_ener_UKS_ABBA"] = GenericMatcher( - r"BSE| 2 UKS -ABBA-", col=5 -) -registry["BSE_osc_str_n2_UKS_ABBA"] = GenericMatcher( - r"BSE| 2 -ABBA-", col=7 -) -registry["BSE_ampl_n2_UKS_ABBA"] = GenericMatcher( - r"BSE| 2 α 1 => 2 -ABBA-", col=8 -) registry["M115"] = GenericMatcher(r"MOMENTS_TRACE_RE| 0.10000000E+000", col=3) registry["M116"] = GenericMatcher(r"MOMENTS_TRACE_IM| 0.10000000E+000", col=3) registry["M117"] = GenericMatcher(r"MOMENTS_TRACE_RE| 0.20000000E+000", col=3) @@ -301,31 +280,6 @@ registry["RTBSE_GXAC_H2_pol"] = GenericMatcher( r"POLARIZABILITY_PADE| 0.30450000E+002", col=4 ) -# Lowest excitation energy from the linRTBSE Liouvillian diagnostic. -# Tied to the F12.4 eV column of the n=1 row. -registry["LinRTBSE_1st_excit_ener"] = GenericMatcher( - r" RTBSE\|\s+1\s+\d+\.\d+\s*$", col=3, regex=True -) - -# 2nd and 3rd excitation energy on the same table; the "\s+N\s+" boundary -# uniquely selects each row (e.g. "12" / "20" / "22" never matches "\s+2\s+"). -registry["LinRTBSE_2nd_excit_ener"] = GenericMatcher( - r" RTBSE\|\s+2\s+\d+\.\d+\s*$", col=3, regex=True -) -registry["LinRTBSE_3rd_excit_ener"] = GenericMatcher( - r" RTBSE\|\s+3\s+\d+\.\d+\s*$", col=3, regex=True -) - -# Static polarizability alpha(0), Re part, spin=1, xx element. -registry["LinRTBSE_static_pol_xx"] = GenericMatcher( - r" STATIC_POL\|\s+1\s+1,\s*1\s+", col=5, regex=True -) - -# Spin-summed total static polarizability alpha(0), Re part, xx element (open shell). -registry["LinRTBSE_static_pol_xx_total"] = GenericMatcher( - r" STATIC_POL\|\s+TOT\s+1,\s*1\s+", col=5, regex=True -) - registry["M126"] = GenericMatcher(r" # Total charge ", col=5) registry["M127"] = GenericMatcher(r"Checksum (Acoustic Sum Rule):", col=5) diff --git a/tests/xTB/regtest-1/TEST_FILES.toml b/tests/xTB/regtest-1/TEST_FILES.toml index 3f4b4af04c..f595a8da31 100644 --- a/tests/xTB/regtest-1/TEST_FILES.toml +++ b/tests/xTB/regtest-1/TEST_FILES.toml @@ -9,13 +9,13 @@ "ch2o_smear.inp" = [{matcher="E_total", tol=1.0E-12, ref=-7.19753850357134}] "tmol.inp" = [{matcher="E_total", tol=1.0E-12, ref=-41.90845660778482}] "h2.inp" = [{matcher="E_total", tol=1.0E-12, ref=-1.03458223634251}] -"h2_kab.inp" = [{matcher="E_total", tol=1.0E-12, ref=-0.9981670905879}] +"h2_kab.inp" = [{matcher="E_total", tol=1.0E-12, ref=-0.99816707611986}] "h2o-md.inp" = [{matcher="E_total", tol=1.0E-12, ref=-185.14383606866977}] "h2o_str.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76524673249110}] "h2o_strsym.inp" = [] "h2o-atprop.inp" = [{matcher="E_total", tol=1.0E-10, ref=-185.16260010725958}] "h2o-atprop0.inp" = [{matcher="E_total", tol=1.0E-12, ref=-187.45499307126425}] -"si_geo.inp" = [{matcher="E_total", tol=1.0E-11, ref=-14.51194893694458}] +"si_geo.inp" = [{matcher="E_total", tol=1.0E-11, ref=-14.51194886943525}] "si_kp.inp" = [{matcher="E_total", tol=1.0E-12, ref=-14.73191475148811}] "h2o_dimer.inp" = [{matcher="E_total", tol=1.0E-12, ref=-11.54506384435821}] "ghost.inp" = [{matcher="E_total", tol=1.0E-12, ref=-1.03458221876736}] diff --git a/tests/xTB/regtest-3-spglib/TEST_FILES.toml b/tests/xTB/regtest-3-spglib/TEST_FILES.toml index 40cc925cc5..93d13db325 100644 --- a/tests/xTB/regtest-3-spglib/TEST_FILES.toml +++ b/tests/xTB/regtest-3-spglib/TEST_FILES.toml @@ -5,14 +5,14 @@ {matcher="N_special_kpoints", tol=0.0, ref=4}] "si_kp_tblite_mixer_spglib.inp" = [{matcher="E_total", tol=6.0E-7, ref=-14.73197235360055}, {matcher="N_special_kpoints", tol=0.0, ref=1}] -"bn_gfn1_kp_spglib_phase.inp" = [{matcher="E_total", tol=1.0E-10, ref=-18.82000122976238}, +"bn_gfn1_kp_spglib_phase.inp" = [{matcher="E_total", tol=1.0E-10, ref=-18.86184474675449}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"urea_gfn1_kp_spglib_boundary.inp" = [{matcher="E_total", tol=1.0E-10, ref=-30.89448648357339}, +"urea_gfn1_kp_spglib_boundary.inp" = [{matcher="E_total", tol=1.0E-10, ref=-30.88452203095506}, {matcher="N_special_kpoints", tol=0.0, ref=6}] -"urea_gfn1_kp_spglib_cellopt.inp" = [{matcher="M011", tol=1.0E-8, ref=-30.89506414487332}, +"urea_gfn1_kp_spglib_cellopt.inp" = [{matcher="M011", tol=1.0E-8, ref=-30.88891308320623}, {matcher="N_special_kpoints", tol=0.0, ref=6}] -"ice_viii_gfn2_kp_spglib_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-40.71301330821884}, +"ice_viii_gfn2_kp_spglib_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-40.76699240612732}, {matcher="N_special_kpoints", tol=0.0, ref=6}] -"ice_ix_gfn2_kp_k290_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-61.10270533472814}, +"ice_ix_gfn2_kp_k290_nonsymmorphic.inp" = [{matcher="E_total", tol=1.0E-10, ref=-61.12461062282138}, {matcher="N_special_kpoints", tol=0.0, ref=14}] #EOF diff --git a/tests/xTB/regtest-debug/TEST_FILES.toml b/tests/xTB/regtest-debug/TEST_FILES.toml index 2f4e44dd6a..4e257f0714 100644 --- a/tests/xTB/regtest-debug/TEST_FILES.toml +++ b/tests/xTB/regtest-debug/TEST_FILES.toml @@ -12,7 +12,6 @@ "ch2o_t07.inp" = [{matcher="M086", tol=1.0E-12, ref=0.954101834865E+00}] "ch2o_t08.inp" = [{matcher="M086", tol=1.0E-12, ref=0.963121521347E+00}] "ch2o_t10.inp" = [] -"ch2o_t11.inp" = [] "ch3br_nonbond_2.inp" = [{matcher="E_total", tol=1.0E-12, ref=-11.78062819229165}] "ch3br_nonbond.inp" = [{matcher="E_total", tol=1.0E-12, ref=-11.78062802267188}] "ch3br_atprop_nonbond.inp" = [{matcher="E_total", tol=1.0E-10, ref=-11.78112904495693}] diff --git a/tests/xTB/regtest-debug/ch2o_t11.inp b/tests/xTB/regtest-debug/ch2o_t11.inp deleted file mode 100644 index 7e0de0ebb2..0000000000 --- a/tests/xTB/regtest-debug/ch2o_t11.inp +++ /dev/null @@ -1,65 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - DE 0.0002 - DEBUG_DIPOLE F - DEBUG_FORCES F - DEBUG_POLARIZABILITY T - DEBUG_STRESS_TENSOR F - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 3 - &EFIELD - &END EFIELD - &PRINT - &MOMENTS ON - PERIODIC T - REFERENCE COM - &END MOMENTS - &END PRINT - &QS - METHOD xTB - &XTB - DO_EWALD T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-8 - MAX_SCF 100 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.2 - METHOD DIRECT_P_MIXING - &END MIXING - &END SCF - &END DFT - &PROPERTIES - &LINRES - EPS 1.e-10 - PRECONDITIONER FULL_ALL - &POLAR - DO_RAMAN T - PERIODIC_DIPOLE_OPERATOR T - &END POLAR - &END LINRES - &END PROPERTIES - &SUBSYS - &CELL - ABC 8.0 8.0 8.0 - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_1.inp b/tests/xTB/regtest-spinpol/Fecp2_1.inp deleted file mode 100644 index 7e4ac3cdee..0000000000 --- a/tests/xTB/regtest-spinpol/Fecp2_1.inp +++ /dev/null @@ -1,72 +0,0 @@ -#High-throughput screening of spin states for transition metal -#complexes with spin-polarized extended tight-binding methods -#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme -#J Comput Chem. 44:2120-2129 (2023) -# -# Singlet energy for Fecp2 at B97-3c geometry -# -# Mult. Total energy diff paper -#gfn1-xTB(CP2K) 1 -29.479086484463970 -#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 -#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 -# -&GLOBAL - PRINT_LEVEL LOW - PROJECT fcp - RUN_TYPE ENERGY -&END GLOBAL - -&FORCE_EVAL - &DFT - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - GFN_TYPE 1 - &END XTB - &END QS - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.e-7 - MAX_SCF 500 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.1 - &END MIXING - &SMEAR ON - ELECTRONIC_TEMPERATURE 300 - FIXED_MAGNETIC_MOMENT -1 - METHOD Fermi_Dirac - &END SMEAR - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 50.0 50.0 50.0 - PERIODIC NONE - &END CELL - &COORD - Fe 0.0004943970693 0.00050226806065 0.00020494479873 - C -0.3748945476706 1.15078378775299 1.63064436887779 - C -1.21024684838874 0.00009720947321 1.62988389793261 - C -0.37398399900121 -1.14992851709978 1.63077532916028 - C 0.97812547612693 -0.70999404521766 1.63184519545447 - C 0.97756566955233 0.71191836616162 1.63175937739436 - H -0.70818900861141 2.17469544072034 1.59690178626611 - H -2.28702109419269 -0.00032606472668 1.59586956045273 - H -0.70648737841786 -2.17410164905906 1.59717234659556 - H 1.84971377940345 -1.34235639717661 1.59936176302322 - H 1.84863500728739 1.34499015079161 1.59918899520882 - C -0.97658096112243 0.7118425331789 -1.63138632255292 - C 0.37587390637791 1.15071653679839 -1.63028814098592 - C -0.97713437408181 -0.7100698747375 -1.63139739298304 - H -1.84767296055729 1.34488555954776 -1.59884933194674 - C 1.21123472478417 0.0000343387919 -1.62947531021637 - H 0.70918449672145 2.17462452492938 -1.59660160539228 - C 0.37498047250513 -1.1499957282639 -1.63031293852782 - H -1.84869994419919 -1.34246107275978 -1.59887902317148 - H 2.28800899615906 -0.00039346637333 -1.59546189880925 - H 0.70746789025611 -2.17417250079252 -1.59665480057888 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_5.inp b/tests/xTB/regtest-spinpol/Fecp2_5.inp deleted file mode 100644 index 3baca7ed9d..0000000000 --- a/tests/xTB/regtest-spinpol/Fecp2_5.inp +++ /dev/null @@ -1,75 +0,0 @@ -#High-throughput screening of spin states for transition metal -#complexes with spin-polarized extended tight-binding methods -#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme -#J Comput Chem. 44:2120-2129 (2023) -# -# Quintet energy for Fecp2 at B97-3c geometry -# Parameter set from supplemental material (sign change!) -# -# Mult. Total energy diff paper -#gfn1-xTB(CP2K) 1 -29.479086484463970 -#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 -#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 -# -&GLOBAL - PRINT_LEVEL LOW - PROJECT fcp - RUN_TYPE ENERGY -&END GLOBAL - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 5 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - GFN_TYPE 1 - &END XTB - &END QS - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.e-7 - MAX_SCF 500 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.10 - &END MIXING - &SMEAR ON - ELECTRONIC_TEMPERATURE 300 - FIXED_MAGNETIC_MOMENT -1 - METHOD Fermi_Dirac - &END SMEAR - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 50.0 50.0 50.0 - PERIODIC NONE - &END CELL - &COORD - Fe 0.00046667507209 0.00007145221698 0.00020650908794 - C -0.29638297378219 1.13792952402792 1.91281475677087 - C -1.1353711727193 -0.01307211356389 1.85694327787714 - C -0.29624869915853 -1.15966026966281 1.94842805058997 - C 1.04087385079726 -0.71562387526317 2.07580896633105 - C 1.04244423611723 0.6947942723046 2.05171179195287 - H -0.62650212350503 2.16327072796029 1.88603396689195 - H -2.2117227394285 -0.01415674206402 1.80863041734873 - H -0.62579911475609 -2.18554059534209 1.93720363428829 - H 1.91216002120559 -1.34806313942887 2.1283304806085 - H 1.91409262335761 1.32757762270685 2.09081210664184 - C -1.03941112021214 0.71741195345069 -2.07528737626978 - C 0.29799620713813 1.16052094578281 -1.94784180534153 - C -1.0419290803645 -0.69301008093721 -2.05138407383301 - H -1.91027753858542 1.35044071196014 -2.12766496611585 - C 1.13635987921557 0.01338364594266 -1.85654165280359 - H 0.62822033535291 2.18618156712011 -1.93633378033781 - C 0.29662013454123 -1.13707637009906 -1.9126008359967 - H -1.91399740141563 -1.32520603287501 -2.09062682589173 - H 2.21271190076452 0.01375882553937 -1.80822349672861 - H 0.62606980036518 -2.16264062977632 -1.88611834507055 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_5_sp.inp b/tests/xTB/regtest-spinpol/Fecp2_5_sp.inp deleted file mode 100644 index 19cac3dab8..0000000000 --- a/tests/xTB/regtest-spinpol/Fecp2_5_sp.inp +++ /dev/null @@ -1,82 +0,0 @@ -#High-throughput screening of spin states for transition metal -#complexes with spin-polarized extended tight-binding methods -#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme -#J Comput Chem. 44:2120-2129 (2023) -# -# Quintet energy for Fecp2 at B97-3c geometry -# Parameter set from supplemental material (sign change!) -# -# Mult. Total energy diff paper -#gfn1-xTB(CP2K) 1 -29.479086484463970 -#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 -#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 -# -&GLOBAL - PRINT_LEVEL LOW - PROJECT fcp - RUN_TYPE ENERGY -&END GLOBAL - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 5 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - GFN_TYPE 1 - SPIN_POLARISATION T - &PARAMETER - ## SPIN_POL_PARAM atomtype Wss Wsp Wpp Wsd Wpd Wdd - SPIN_POL_PARAM Fe -0.015400 -0.011925 -0.017850 -0.003300 -0.001162 -0.017125 - SPIN_POL_PARAM C -0.030200 -0.025025 -0.022725 -0.000000 -0.000000 -0.000000 - SPIN_POL_PARAM H -0.071550 -0.000000 -0.000000 -0.000000 -0.000000 -0.000000 - &END PARAMETER - &END XTB - &END QS - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.e-7 - MAX_SCF 500 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.10 - &END MIXING - &SMEAR ON - ELECTRONIC_TEMPERATURE 300 - FIXED_MAGNETIC_MOMENT -1 - METHOD Fermi_Dirac - &END SMEAR - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 50.0 50.0 50.0 - PERIODIC NONE - &END CELL - &COORD - Fe 0.00046667507209 0.00007145221698 0.00020650908794 - C -0.29638297378219 1.13792952402792 1.91281475677087 - C -1.1353711727193 -0.01307211356389 1.85694327787714 - C -0.29624869915853 -1.15966026966281 1.94842805058997 - C 1.04087385079726 -0.71562387526317 2.07580896633105 - C 1.04244423611723 0.6947942723046 2.05171179195287 - H -0.62650212350503 2.16327072796029 1.88603396689195 - H -2.2117227394285 -0.01415674206402 1.80863041734873 - H -0.62579911475609 -2.18554059534209 1.93720363428829 - H 1.91216002120559 -1.34806313942887 2.1283304806085 - H 1.91409262335761 1.32757762270685 2.09081210664184 - C -1.03941112021214 0.71741195345069 -2.07528737626978 - C 0.29799620713813 1.16052094578281 -1.94784180534153 - C -1.0419290803645 -0.69301008093721 -2.05138407383301 - H -1.91027753858542 1.35044071196014 -2.12766496611585 - C 1.13635987921557 0.01338364594266 -1.85654165280359 - H 0.62822033535291 2.18618156712011 -1.93633378033781 - C 0.29662013454123 -1.13707637009906 -1.9126008359967 - H -1.91399740141563 -1.32520603287501 -2.09062682589173 - H 2.21271190076452 0.01375882553937 -1.80822349672861 - H 0.62606980036518 -2.16264062977632 -1.88611834507055 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Fecp2_5_spext.inp b/tests/xTB/regtest-spinpol/Fecp2_5_spext.inp deleted file mode 100644 index a3231c1980..0000000000 --- a/tests/xTB/regtest-spinpol/Fecp2_5_spext.inp +++ /dev/null @@ -1,79 +0,0 @@ -#High-throughput screening of spin states for transition metal -#complexes with spin-polarized extended tight-binding methods -#Hagen Neugebauer, Benedikt Baedorf, Sebastian Ehlert, Andreas Hansen, Stefan Grimme -#J Comput Chem. 44:2120-2129 (2023) -# -# Quintet energy for Fecp2 at B97-3c geometry -# Parameter set from supplemental material (sign change!) -# -# Mult. Total energy diff paper -#gfn1-xTB(CP2K) 1 -29.479086484463970 -#gfn1-xTB(CP2K) 5 -29.375432443451395 0.10365404101 0.1041 -#SPgfn1-xTB(CP2K) 5 -29.458057420324380 0.02102906413 0.0215 -# -&GLOBAL - PRINT_LEVEL LOW - PROJECT fcp - RUN_TYPE ENERGY -&END GLOBAL - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 5 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - GFN_TYPE 1 - SPIN_POLARISATION T - &PARAMETER - SPINPOL_PARAM_FILE_NAME xTB_sp_param_030 - &END PARAMETER - &END XTB - &END QS - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.e-7 - MAX_SCF 500 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.10 - &END MIXING - &SMEAR ON - ELECTRONIC_TEMPERATURE 300 - FIXED_MAGNETIC_MOMENT -1 - METHOD Fermi_Dirac - &END SMEAR - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 50.0 50.0 50.0 - PERIODIC NONE - &END CELL - &COORD - Fe 0.00046667507209 0.00007145221698 0.00020650908794 - C -0.29638297378219 1.13792952402792 1.91281475677087 - C -1.1353711727193 -0.01307211356389 1.85694327787714 - C -0.29624869915853 -1.15966026966281 1.94842805058997 - C 1.04087385079726 -0.71562387526317 2.07580896633105 - C 1.04244423611723 0.6947942723046 2.05171179195287 - H -0.62650212350503 2.16327072796029 1.88603396689195 - H -2.2117227394285 -0.01415674206402 1.80863041734873 - H -0.62579911475609 -2.18554059534209 1.93720363428829 - H 1.91216002120559 -1.34806313942887 2.1283304806085 - H 1.91409262335761 1.32757762270685 2.09081210664184 - C -1.03941112021214 0.71741195345069 -2.07528737626978 - C 0.29799620713813 1.16052094578281 -1.94784180534153 - C -1.0419290803645 -0.69301008093721 -2.05138407383301 - H -1.91027753858542 1.35044071196014 -2.12766496611585 - C 1.13635987921557 0.01338364594266 -1.85654165280359 - H 0.62822033535291 2.18618156712011 -1.93633378033781 - C 0.29662013454123 -1.13707637009906 -1.9126008359967 - H -1.91399740141563 -1.32520603287501 -2.09062682589173 - H 2.21271190076452 0.01375882553937 -1.80822349672861 - H 0.62606980036518 -2.16264062977632 -1.88611834507055 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/Ferrocene.inp b/tests/xTB/regtest-spinpol/Ferrocene.inp deleted file mode 100644 index 8761cc2156..0000000000 --- a/tests/xTB/regtest-spinpol/Ferrocene.inp +++ /dev/null @@ -1,64 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT fcp - RUN_TYPE ENERGY -&END GLOBAL - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 5 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - GFN_TYPE 1 - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - ADDED_MOS -1 -1 - EPS_SCF 1.e-7 - MAX_SCF 500 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.04 - #METHOD DIRECT_P_MIXING - &END MIXING - &SMEAR ON - ELECTRONIC_TEMPERATURE 300 - FIXED_MAGNETIC_MOMENT -1 - METHOD Fermi_Dirac - &END SMEAR - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 50.0 50.0 50.0 - PERIODIC NONE - &END CELL - &COORD - Fe 0.00049406476719 0.00053168004165 0.00020491843636 - C -0.37271343833523 1.14624540866561 1.67922290481448 - C -1.20491760216065 0.00011606553248 1.67867752557376 - C -0.37195847519282 -1.14545516103349 1.67923381734091 - C 0.97468028030604 -0.70729459020657 1.67902691822851 - C 0.97422867195674 0.7089288330528 1.67897677410672 - H -0.70638981845675 2.17223173166618 1.76533130266172 - H -2.28379902754658 -0.00021140895756 1.76462815066646 - H -0.70497268601096 -2.17165352881699 1.7653501482553 - H 1.84766822202289 -1.34114936541527 1.76542334732916 - H 1.84679969810106 1.34335706981963 1.76538111079929 - C -0.97323936548635 0.70899355225443 -1.6786095674155 - C 0.37367886169607 1.14629178120918 -1.67881030467712 - C -0.97369370100792 -0.70722987462659 -1.67857444641498 - H -1.84582276828766 1.34340645872887 -1.76499406584606 - C 1.20590557946464 0.00018966220257 -1.67826815962836 - H 0.7073473789547 2.17227911799041 -1.76490781463678 - C 0.37296900620916 -1.14540880634454 -1.67882727297382 - H -1.84666917780632 -1.34110011176957 -1.76499032806053 - H 2.28478694620084 -0.00017101174833 -1.76421928202354 - H 0.70599105061188 -2.17160610224494 -1.764954876536 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/TEST_FILES.toml b/tests/xTB/regtest-spinpol/TEST_FILES.toml deleted file mode 100644 index c5179f4583..0000000000 --- a/tests/xTB/regtest-spinpol/TEST_FILES.toml +++ /dev/null @@ -1,21 +0,0 @@ -# runs are executed in the same order as in this file -# the second field tells which test should be run in order to compare with the last available output -# e.g. 0 means do not compare anything, running is enough -# 1 compares the last total energy in the file -# for details see cp2k/tools/do_regtest -"ch2o.inp" = [{matcher="E_total", tol=1.0E-12, ref=-7.70606717289255}] -"Ferrocene.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.41637966342602}] -"ch2o_force.inp" = [] -"ch2o_stress.inp" = [] -# -"ch2o_kp_force.inp" = [] -"ch2o_kp_stress.inp" = [] -# -"ch2o_polar.inp" = [] -"h2o_sTDA_spin.inp" = [] -# -"Fecp2_1.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.47908648446399}] -"Fecp2_5.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.3754324434514}] -"Fecp2_5_sp.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.45805742032436}] -"Fecp2_5_spext.inp" = [{matcher="E_total", tol=1.0E-12, ref=-29.45805742032436}] -#EOF diff --git a/tests/xTB/regtest-spinpol/ch2o.inp b/tests/xTB/regtest-spinpol/ch2o.inp deleted file mode 100644 index 1a74e021bd..0000000000 --- a/tests/xTB/regtest-spinpol/ch2o.inp +++ /dev/null @@ -1,43 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - STRESS_TENSOR ANALYTICAL - &DFT - CHARGE 0 - LSD - MULTIPLICITY 3 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-7 - MAX_SCF 100 - SCF_GUESS MOPAC - &END SCF - &END DFT - &PRINT - &FORCES - &END FORCES - &STRESS_TENSOR - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - ABC 20.0 20.0 20.0 - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_force.inp b/tests/xTB/regtest-spinpol/ch2o_force.inp deleted file mode 100644 index b84d5fe973..0000000000 --- a/tests/xTB/regtest-spinpol/ch2o_force.inp +++ /dev/null @@ -1,49 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 XY - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0001 - EPS_NO_ERROR_CHECK 0.000001 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - &DFT - CHARGE 0 - LSD - MULTIPLICITY 3 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-6 - MAX_SCF 100 - SCF_GUESS MOPAC - &END SCF - &END DFT - &PRINT - &FORCES - &END FORCES - &END PRINT - &SUBSYS - &CELL - ABC 5.0 5.0 5.0 - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_kp_force.inp b/tests/xTB/regtest-spinpol/ch2o_kp_force.inp deleted file mode 100644 index 7fafc8fb94..0000000000 --- a/tests/xTB/regtest-spinpol/ch2o_kp_force.inp +++ /dev/null @@ -1,54 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O_kp - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 X - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0001 - EPS_NO_ERROR_CHECK 0.000001 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - &DFT - CHARGE 0 - LSD - MULTIPLICITY 3 - &KPOINTS - FULL_GRID ON - PARALLEL_GROUP_SIZE 0 - SCHEME MONKHORST-PACK 2 2 2 - SYMMETRY ON - &END KPOINTS - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-6 - MAX_SCF 100 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.1 - &END MIXING - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 4.0 4.0 4.0 - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_kp_stress.inp b/tests/xTB/regtest-spinpol/ch2o_kp_stress.inp deleted file mode 100644 index 22a0d05074..0000000000 --- a/tests/xTB/regtest-spinpol/ch2o_kp_stress.inp +++ /dev/null @@ -1,54 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O_kp - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - DEBUG_FORCES F - DEBUG_STRESS_TENSOR T - DX 0.0001 - EPS_NO_ERROR_CHECK 0.000001 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - STRESS_TENSOR ANALYTICAL - &DFT - CHARGE 0 - LSD - MULTIPLICITY 3 - &KPOINTS - FULL_GRID ON - PARALLEL_GROUP_SIZE 0 - SCHEME MONKHORST-PACK 2 2 2 - SYMMETRY ON - &END KPOINTS - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-6 - MAX_SCF 100 - SCF_GUESS MOPAC - &MIXING - ALPHA 0.40 - &END MIXING - &END SCF - &END DFT - &SUBSYS - &CELL - ABC 4.0 4.0 4.0 - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_polar.inp b/tests/xTB/regtest-spinpol/ch2o_polar.inp deleted file mode 100644 index 01247c697d..0000000000 --- a/tests/xTB/regtest-spinpol/ch2o_polar.inp +++ /dev/null @@ -1,63 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - DE 0.0002 - DEBUG_DIPOLE F - DEBUG_FORCES F - DEBUG_POLARIZABILITY T - DEBUG_STRESS_TENSOR F - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - &DFT - LSD - MULTIPLICITY 3 - &EFIELD - &END EFIELD - &PRINT - &MOMENTS ON - PERIODIC F - REFERENCE COM - &END MOMENTS - &END PRINT - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-7 - MAX_SCF 100 - SCF_GUESS MOPAC - &END SCF - &END DFT - &PROPERTIES - &LINRES - EPS 1.e-10 - PRECONDITIONER FULL_ALL - &POLAR - DO_RAMAN T - PERIODIC_DIPOLE_OPERATOR F - &END POLAR - &END LINRES - &END PROPERTIES - &SUBSYS - &CELL - ABC 20.0 20.0 20.0 - PERIODIC NONE - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/ch2o_stress.inp b/tests/xTB/regtest-spinpol/ch2o_stress.inp deleted file mode 100644 index 2c4b342e67..0000000000 --- a/tests/xTB/regtest-spinpol/ch2o_stress.inp +++ /dev/null @@ -1,51 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT CH2O - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - DEBUG_FORCES F - DEBUG_STRESS_TENSOR T - DX 0.001 - EPS_NO_ERROR_CHECK 0.000001 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - STRESS_TENSOR ANALYTICAL - &DFT - CHARGE 0 - LSD - MULTIPLICITY 3 - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.e-7 - MAX_SCF 100 - SCF_GUESS MOPAC - &END SCF - &END DFT - &PRINT - &FORCES - &END FORCES - &STRESS_TENSOR - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - ABC 5.0 5.0 5.0 - &END CELL - &COORD - O 0.051368 0.000000 0.000000 - C 1.278612 0.000000 0.000000 - H 1.870460 0.939607 0.000000 - H 1.870460 -0.939607 0.000000 - &END COORD - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp b/tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp deleted file mode 100644 index 7df33baca4..0000000000 --- a/tests/xTB/regtest-spinpol/h2o_sTDA_spin.inp +++ /dev/null @@ -1,67 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT H2O - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 Z - DE 0.0002 - DEBUG_DIPOLE .FALSE. - DEBUG_FORCES .TRUE. - DEBUG_POLARIZABILITY .FALSE. - DEBUG_STRESS_TENSOR .FALSE. - STOP_ON_MISMATCH F -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - LSD - MULTIPLICITY 3 - &EXCITED_STATES T - STATE 1 - &END EXCITED_STATES - &QS - METHOD xTB - &XTB - CHECK_ATOMIC_CHARGES F - SPIN_POLARISATION T - &END XTB - &END QS - &SCF - EPS_SCF 1.0E-8 - MAX_SCF 50 - SCF_GUESS MOPAC - &END SCF - &END DFT - &PRINT - &FORCES - &END FORCES - &END PRINT - &PROPERTIES - &TDDFPT - CONVERGENCE [eV] 1.0e-7 - KERNEL sTDA - MAX_ITER 50 - NSTATES 5 - &STDA - FRACTION 0.50 - &END STDA - &END TDDFPT - &END PROPERTIES - &SUBSYS - &CELL - ABC [angstrom] 6.0 6.0 6.0 - &END CELL - &COORD - O 0.000000 0.000000 0.000000 - H 0.000000 -0.757136 0.580545 - H 0.000000 0.757136 0.580545 - &END COORD - &TOPOLOGY - &CENTER_COORDINATES - &END CENTER_COORDINATES - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/xTB/regtest-stda-force/TEST_FILES.toml b/tests/xTB/regtest-stda-force/TEST_FILES.toml index 4b6f5e42ce..0d12f0d51c 100644 --- a/tests/xTB/regtest-stda-force/TEST_FILES.toml +++ b/tests/xTB/regtest-stda-force/TEST_FILES.toml @@ -7,9 +7,9 @@ "h2o_f12.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.85052842359978}] "h2o_f13.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76860088550339}] "h2o_f14.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76860088550339}] -"h2o_f15.inp" = [] -"h2o_f16.inp" = [] -"h2o_f17.inp" = [] +#h2o_f15.inp 1 1.0E-12 0.000000E+00 +#h2o_f16.inp 1 1.0E-12 0.000000E+00 +#h2o_f17.inp 1 1.0E-12 0.000000E+00 "h2o_f18.inp" = [{matcher="E_total", tol=1.0E-12, ref=-5.76904757361574}] -"h2o_f19.inp" = [] +#h2o_f19.inp 1 1.0E-12 0.000000E+00 #EOF diff --git a/tests/xTB/regtest-stda-force/h2o_f12.inp b/tests/xTB/regtest-stda-force/h2o_f12.inp index e98e98e15b..2be85f896e 100644 --- a/tests/xTB/regtest-stda-force/h2o_f12.inp +++ b/tests/xTB/regtest-stda-force/h2o_f12.inp @@ -2,6 +2,7 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f13.inp b/tests/xTB/regtest-stda-force/h2o_f13.inp index a640fa6bb8..e01f2491ed 100644 --- a/tests/xTB/regtest-stda-force/h2o_f13.inp +++ b/tests/xTB/regtest-stda-force/h2o_f13.inp @@ -2,6 +2,7 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f14.inp b/tests/xTB/regtest-stda-force/h2o_f14.inp index 7500a208d0..08b179a313 100644 --- a/tests/xTB/regtest-stda-force/h2o_f14.inp +++ b/tests/xTB/regtest-stda-force/h2o_f14.inp @@ -2,6 +2,7 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f15.inp b/tests/xTB/regtest-stda-force/h2o_f15.inp index 2592ffb9a6..3a2456ec73 100644 --- a/tests/xTB/regtest-stda-force/h2o_f15.inp +++ b/tests/xTB/regtest-stda-force/h2o_f15.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG - CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-stda-force/h2o_f16.inp b/tests/xTB/regtest-stda-force/h2o_f16.inp index 1777b1bdc4..26e6aabd46 100644 --- a/tests/xTB/regtest-stda-force/h2o_f16.inp +++ b/tests/xTB/regtest-stda-force/h2o_f16.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG - CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-stda-force/h2o_f17.inp b/tests/xTB/regtest-stda-force/h2o_f17.inp index 15c0d8c3da..70c6e8cd96 100644 --- a/tests/xTB/regtest-stda-force/h2o_f17.inp +++ b/tests/xTB/regtest-stda-force/h2o_f17.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG - CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-stda-force/h2o_f18.inp b/tests/xTB/regtest-stda-force/h2o_f18.inp index 4db31f65bd..806cd27e75 100644 --- a/tests/xTB/regtest-stda-force/h2o_f18.inp +++ b/tests/xTB/regtest-stda-force/h2o_f18.inp @@ -2,6 +2,7 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG diff --git a/tests/xTB/regtest-stda-force/h2o_f19.inp b/tests/xTB/regtest-stda-force/h2o_f19.inp index 6b10b2a23b..ac704de479 100644 --- a/tests/xTB/regtest-stda-force/h2o_f19.inp +++ b/tests/xTB/regtest-stda-force/h2o_f19.inp @@ -2,10 +2,10 @@ PRINT_LEVEL LOW PROJECT ftest RUN_TYPE DEBUG + ## RUN_TYPE ENERGY_FORCE &END GLOBAL &DEBUG - CHECK_ATOM_FORCE 1 Z DE 0.0002 DEBUG_DIPOLE .FALSE. DEBUG_FORCES .TRUE. diff --git a/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml b/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml index c2523866db..b4bfd88fb4 100644 --- a/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-gfn1-periodic/TEST_FILES.toml @@ -3,12 +3,12 @@ # e.g. 0 means do not compare anything, running is enough # 1 compares the last total energy in the file # for details see cp2k/tools/do_regtest -"COBe_gfn1_fd.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.42848707385935}] -"CH2O_gfn1.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.8504891036979}] -"Si_gfn1_fd.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.44320245934278}] -"Si_gfn1_kp.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.70433442694045}] -"Si_gfn1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.72017602003837}, +"COBe_gfn1_fd.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.4283186205}] +"CH2O_gfn1.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.8503584297}] +"Si_gfn1_fd.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.45211749988608}] +"Si_gfn1_kp.inp" = [{matcher="E_total", tol=3.0E-8, ref=-14.707430385147}] +"Si_gfn1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.722697896033}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Si_gfn1_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.72017602003837}, +"Si_gfn1_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-14.722697896033}, {matcher="N_special_kpoints", tol=0.0, ref=4}] #EOF diff --git a/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml b/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml index f574587cde..6041b7d58f 100644 --- a/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-gfn2/TEST_FILES.toml @@ -19,8 +19,8 @@ "N2_gfn2_uks_cp2k_mixer_force.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "O2_gfn2_uks_force.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "O2_gfn2_uks_ot.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.9319651546}] -"O2_gfn2_uks_xyz_ls_cp2k_mixer.inp" = [{matcher="M011", tol=1.0E-8, ref=-7.931965128812277}] -"O2plus_gfn2_uks_cp2k_mixer.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.27211104712107}] +"O2_gfn2_uks_xyz_ls_cp2k_mixer.inp" = [{matcher="M011", tol=1.0E-8, ref=-7.93196513956454}] +"O2plus_gfn2_uks_cp2k_mixer.inp" = [{matcher="E_total", tol=1.0E-8, ref=-7.26596846265160}] "O2plus_gfn2_uks_cp2k_mixer_force.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "CH2O_gfn2_force_cp2k_mixer.inp" = [{matcher="M082", tol=5.0E-6, ref=0.0000000}] "CH2O_gfn2_stress.inp" = [{matcher="M042", tol=1.0E-7, ref=0.0000000}] @@ -41,13 +41,13 @@ {matcher="N_special_kpoints", tol=0.0, ref=4}] "O2_gfn2_uks_kp_debug.inp" = [{matcher="DEBUG_stress_sum", tol=5.0E-6, ref=0.0000000}, {matcher="DEBUG_force_sum", tol=5.0E-6, ref=0.0000000}] -"Si_gfn2_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65663936611194}, +"Si_gfn2_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65677573470654}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Si_gfn2_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65663936611194}, +"Si_gfn2_kp_spglib_backend.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65677573470654}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Si_gfn2_kp_spglib_shifted.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65663936611193}, +"Si_gfn2_kp_spglib_shifted.inp" = [{matcher="E_total", tol=1.0E-8, ref=-13.65677573470655}, {matcher="N_special_kpoints", tol=0.0, ref=4}] -"Zn_fcc_gfn2_kp_k290.inp" = [{matcher="E_total", tol=1.0E-8, ref=-0.52857489142004}, +"Zn_fcc_gfn2_kp_k290.inp" = [{matcher="E_total", tol=1.0E-8, ref=-0.528740963544749}, {matcher="N_special_kpoints", tol=0.0, ref=4}] "Ar_fcc_gfn2_ls.inp" = [{matcher="M011", tol=5.0E-8, ref=-17.12154132132343}] "Ar_fcc_gfn2_force.inp" = [{matcher="M082", tol=1.0E-5, ref=0.0000000}] diff --git a/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml b/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml index cfd0b34a94..e9b77d1cba 100644 --- a/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml +++ b/tests/xTB/regtest-tblite-ipea1/TEST_FILES.toml @@ -9,7 +9,7 @@ "CH2O_ipea1_force.inp" = [{matcher="M082", tol=1.0E-6, ref=0.0000000}] "COBe_ipea1_force.inp" = [{matcher="M082", tol=1.0E-6, ref=0.0000000}] "O2_ipea1_uks_force.inp" = [{matcher="M082", tol=1.0E-6, ref=0.0000000}] -"Si_ipea1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-15.18478726953854}, +"Si_ipea1_kp_kpsym.inp" = [{matcher="E_total", tol=1.0E-8, ref=-15.179073369509}, {matcher="N_special_kpoints", tol=0.0, ref=4}] "Ar_fcc_ipea1_kp_debug.inp" = [{matcher="DEBUG_stress_sum", tol=1.0E-5, ref=0.0000000}, {matcher="DEBUG_force_sum", tol=1.0E-5, ref=0.0000000}, diff --git a/tools/conventions/conventions.supp b/tools/conventions/conventions.supp index 758c77d9a2..cc7033ad48 100644 --- a/tools/conventions/conventions.supp +++ b/tools/conventions/conventions.supp @@ -95,6 +95,7 @@ kpsym.F: Found GOTO statement in procedure "primlatt" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "remove" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "sppt2" https://cp2k.org/conv#c201 libcp2k.F: Found type eri2array without initializer https://cp2k.org/conv#c016 +libgrpp_integrals.F: Module "libgrpp" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 libint_wrapper.F: Found type cp_libint_t without initializer https://cp2k.org/conv#c016 libint_wrapper.F: Module "libint_f" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 library_tests.F: Found CALL RANDOM_NUMBER in procedure "copy_test" https://cp2k.org/conv#c104 @@ -152,6 +153,7 @@ message_passing.F: Module "pmpi_f08" USEd without ONLY clause or not PRIVATE htt message_passing.F: USE statement at (1) has no ONLY qualifier [-Wuse-without-only] message_passing.fypp: Type mismatch between actual argument at (1) and actual argument at (2) (COMPLEX(8)/COMPLEX(4)). mltfftsg_tools.F: Found WRITE statement with hardcoded unit in "ctrig" https://cp2k.org/conv#c012 +mode_selective.F: Found READ with unchecked STAT in "bfgs_guess" https://cp2k.org/conv#c001 mp_perf_test.F: Module "mpi_f08" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 negf_methods.F: Found CALL with NULL() as argument in procedure "converge_density" https://cp2k.org/conv#c007 negf_methods.F: Found CALL with NULL() as argument in procedure "guess_fermi_level" https://cp2k.org/conv#c007 @@ -169,6 +171,7 @@ ps_wavelet_kernel.F: Found WRITE statement with hardcoded unit in "indices" http ps_wavelet_scaling_function.F: Found WRITE statement with hardcoded unit in "ftest" https://cp2k.org/conv#c012 pwdft_environment_types.F: Module "sirius" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 pw_grids.F: Found WRITE statement with hardcoded unit in "pw_grid_sort" https://cp2k.org/conv#c012 +qcschema.F: Module "hdf5_wrapper" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 qs_active_space_methods.F: Found type eri_fcidump_checksum without initializer https://cp2k.org/conv#c016 qs_active_space_methods.F: Found type eri_fcidump_print without initializer https://cp2k.org/conv#c016 qs_charge_mixing.F: Module "mctc_env" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 diff --git a/tools/docker/scripts/test_i-pi.sh b/tools/docker/scripts/test_i-pi.sh index 246160ef1b..b5bb95951b 100755 --- a/tools/docker/scripts/test_i-pi.sh +++ b/tools/docker/scripts/test_i-pi.sh @@ -40,7 +40,7 @@ ulimit -t ${TIMEOUT_SEC} # Limit cpu time. cd run_1 echo 42 > cp2k_exit_code sleep 10 # give i-pi some time to startup - OMP_NUM_THREADS=2 timeout ${TIMEOUT_SEC} /opt/cp2k/build/bin/cp2k.ssmp ../in.cp2k + OMP_NUM_THREADS=2 /opt/cp2k/build/bin/cp2k.ssmp ../in.cp2k echo $? > cp2k_exit_code ) & @@ -80,14 +80,14 @@ export OMP_NUM_THREADS=2 cd run_client echo 42 > cp2k_client_exit_code sleep 10 # give server some time to startup - timeout ${TIMEOUT_SEC} /opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_client.inp + /opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_client.inp echo $? > cp2k_client_exit_code ) & # launch cp2k in server mode mkdir -p run_server cd run_server -timeout ${TIMEOUT_SEC} /opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_server.inp +/opt/cp2k/build/bin/cp2k.ssmp /opt/cp2k/tests/i-PI/ipi_server.inp SERVER_EXIT_CODE=$? wait # for cp2k client to shutdown diff --git a/tools/docker/scripts/test_misc.sh b/tools/docker/scripts/test_misc.sh index d3fc3dc645..fe39415cc9 100755 --- a/tools/docker/scripts/test_misc.sh +++ b/tools/docker/scripts/test_misc.sh @@ -44,7 +44,6 @@ run_test ./tools/pao-ml/pao-validate.py --threshold=1e-5 --model="tests/QS/regte run_test ./tools/vibronic_spec/main.py ./tools/vibronic_spec/example/example_config.toml run_test mypy --strict ./tools/pao-ml/ -run_test mypy --strict ./tools/mace/create_cp2k_model.py run_test mypy --strict ./tools/minimax_tools/minimax_to_fortran_source.py run_test mypy --strict ./tools/dashboard/generate_dashboard.py run_test mypy --strict ./tools/regtesting/optimize_test_dirs.py diff --git a/tools/fedora/cp2k.spec b/tools/fedora/cp2k.spec index a748292ab1..322ed2629a 100644 --- a/tools/fedora/cp2k.spec +++ b/tools/fedora/cp2k.spec @@ -154,7 +154,6 @@ for mpi in '' mpich openmpi; do module load mpi/${mpi}-%{_arch} cmake_mpi_args=( "-DCMAKE_INSTALL_PREFIX:PATH=${MPI_HOME}" - "-DCMAKE_INSTALL_LIBDIR:PATH=lib" "-DCMAKE_PREFIX_PATH:PATH=${MPI_HOME};%{_prefix}" "-DCMAKE_INSTALL_Fortran_MODULES:PATH=${MPI_FORTRAN_MOD_DIR}/cp2k" "-DCP2K_DATA_DIR:PATH=%{_datadir}/cp2k/data" @@ -164,6 +163,7 @@ for mpi in '' mpich openmpi; do else cmake_mpi_args=( "-DCMAKE_INSTALL_Fortran_MODULES:PATH=%{_fmoddir}/cp2k" + "-DCMAKE_INSTALL_LIBDIR:PATH=lib64" "-DCP2K_USE_MPI:BOOL=OFF" ) fi diff --git a/tools/mace/create_cp2k_model.py b/tools/mace/create_cp2k_model.py deleted file mode 100644 index 16b097b0ce..0000000000 --- a/tools/mace/create_cp2k_model.py +++ /dev/null @@ -1,190 +0,0 @@ -# pylint: disable=wrong-import-position -""" -Export a trained MACE model to a TorchScript file that can be loaded by CP2K. - -The export script must be executed in an environment where MACE is installed. - -Required packages: - * torch: required for loading and converting the model. - * e3nn: required by MACE for JIT compilation. - * mace-torch: required because the trained MACE model is loaded using - torch and its original model classes must be available. - -The MACE version used for export should be compatible with the version -used for training the model. - -After exporting, the CP2K-compatible `.pth` file can be loaded by CP2K -through the LibTorch interface. No MACE, e3nn, or Python installation is -required during CP2K simulations. - -Usage: - python create_cp2k_model.py my_mace.model --dtype float64 --head default - -> writes my_mace.model-cp2k.pth -""" - -import argparse -import os -from typing import Any, Dict, Optional - -os.environ["TORCH_FORCE_NO_WEIGHTS_ONLY_LOAD"] = "1" - -import torch -from e3nn.util import jit # type: ignore -from e3nn.util.jit import compile_mode # type: ignore - -# Z -> chemical symbol table (index == atomic number). Covers the dummy X plus -# all 118 known elements, matching CP2K's src/common/periodic_table.F. -chemical_symbols = ["X"] + """ - H He Li Be B C N O F Ne Na Mg Al Si P S Cl Ar K Ca Sc Ti V Cr Mn Fe Co - Ni Cu Zn Ga Ge As Se Br Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb - Te I Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu Hf Ta W Re Os - Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm - Md No Lr Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og -""".split() - - -@compile_mode("script") -class CP2K_MACE(torch.nn.Module): - """MACE model wrapped for CP2K's single-dictionary libtorch interface.""" - - head: torch.Tensor - - def __init__(self, model: Any, head: Optional[str] = None) -> None: - super().__init__() - self.model = model - self.register_buffer("atomic_numbers", model.atomic_numbers) - self.register_buffer("r_max", model.r_max) - self.register_buffer("num_interactions", model.num_interactions) - self.num_types: int = int(model.atomic_numbers.shape[0]) - - if not hasattr(model, "heads"): - model.heads = [None] - if head is not None and head in model.heads: - head_idx = model.heads.index(head) - else: - head_idx = len(model.heads) - 1 - self.register_buffer( - "head", torch.tensor(head_idx, dtype=torch.long).unsqueeze(0) - ) - - for param in self.model.parameters(): - param.requires_grad = False - - def forward( - self, data: Dict[str, torch.Tensor] - ) -> Dict[str, Optional[torch.Tensor]]: - pos = data["pos"] - edge_index = data["edge_index"] - unit_shifts = data["edge_cell_shift"] - cell = data["cell"].view(3, 3) - atom_types = data["atom_types"].to(torch.long) - n_atoms = pos.shape[0] - - # one-hot node attributes expected by MACE - node_attrs = torch.nn.functional.one_hot( - atom_types, num_classes=self.num_types - ).to(pos.dtype) - - # real-space edge shift vectors: unit_shifts @ cell (Angstrom) - shifts = torch.matmul(unit_shifts, cell) - - batch = torch.zeros(n_atoms, dtype=torch.long, device=pos.device) - ptr = torch.tensor([0, n_atoms], dtype=torch.long, device=pos.device) - - mace_in: Dict[str, torch.Tensor] = { - "positions": pos, - "node_attrs": node_attrs, - "edge_index": edge_index, - "shifts": shifts, - "unit_shifts": unit_shifts, - "cell": cell, - "batch": batch, - "ptr": ptr, - "head": self.head, - } - - out = self.model( - mace_in, - training=False, - compute_force=True, - compute_virials=True, - compute_stress=False, - compute_displacement=True, - ) - - node_energy = out["node_energy"] - forces = out["forces"] - virials = out["virials"] - - atomic_energy: Optional[torch.Tensor] = None - if node_energy is not None: - atomic_energy = node_energy.unsqueeze(-1) - - virial: Optional[torch.Tensor] = None - if virials is not None: - virial = virials.view(3, 3) - - return { - "atomic_energy": atomic_energy, - "forces": forces, - "virial": virial, - } - - -def build_metadata(model: Any, dtype: str) -> Dict[str, str]: - z = model.atomic_numbers.to(torch.long).tolist() - type_names = " ".join(chemical_symbols[int(zi)] for zi in z) - return { - "num_types": str(len(z)), - "r_max": repr(float(model.r_max)), - "type_names": type_names, - "model_dtype": dtype, - "allow_tf32": "0", - # MACE uses a single global cutoff; leave per-edge-type cutoffs empty so - # CP2K's reader falls back to filling the cutoff matrix with r_max**2. - "per_edge_type_cutoff": "", - } - - -def parse_args() -> argparse.Namespace: - p = argparse.ArgumentParser(description=__doc__) - p.add_argument("model_path", help="Path to the trained MACE .model file") - p.add_argument( - "--head", default=None, help="Model head to export (multi-head models)" - ) - p.add_argument("--dtype", choices=["float64", "float32"], default="float64") - p.add_argument( - "--output", default=None, help="Output path (default: -cp2k.pth)" - ) - return p.parse_args() - - -def main() -> None: - args = parse_args() - model = torch.load(args.model_path, map_location="cpu") - if args.dtype == "float64": - model = model.double() - else: - print("Converting model to float32, this may cause loss of precision.") - model = model.float() - model = model.to("cpu") - - wrapper = CP2K_MACE(model, head=args.head) - wrapper.eval() - - scripted = jit.compile(wrapper) - - metadata = build_metadata(model, args.dtype) - extra_files = {k: v.encode("utf-8") for k, v in metadata.items()} - - out_path = args.output or (args.model_path + "-cp2k.pth") - scripted.save(out_path, _extra_files=extra_files) - - print(f"Wrote CP2K MACE model to: {out_path}") - print("Metadata:") - for k, v in metadata.items(): - print(f" {k}: {v}") - - -if __name__ == "__main__": - main() diff --git a/tools/pao-ml/requirements.txt b/tools/pao-ml/requirements.txt index 179df2da5d..fedca401bb 100644 --- a/tools/pao-ml/requirements.txt +++ b/tools/pao-ml/requirements.txt @@ -1,6 +1,6 @@ e3nn==0.6.0 nequip==0.17.1 -torch==2.13.0 +torch==2.11.0 #EOF diff --git a/tools/precommit/fortitude.toml b/tools/precommit/fortitude.toml index f613397e65..71813b713f 100644 --- a/tools/precommit/fortitude.toml +++ b/tools/precommit/fortitude.toml @@ -7,51 +7,39 @@ ignore = [ "non-standard-file-extension", "implicit-external-procedures", # requires Fortran 2018 "missing-intent", - "bad-quote-string", - "literal-kind", "assumed-size", "assumed-size-character-intent", - "interface-implicit-typing", - "missing-default-case", "external-procedure", - "trailing-backslash", + "literal-kind", + "interface-implicit-typing", + "implicit-typing", + "missing-accessibility-statement", ] # ============================================================================== # The following files can not be parsed by Fortitude. # Usually because Fortran statements are inter-leafed with pre-processor macros. exclude = [ - "local_gemm_api.F", - "smeagol_control_types.F", - "ai_contraction_sphi.F", - "qs_loc_states.F", - "dbt_array_list_methods.F", - "cp_cfm_basic_linalg.F", - "cp_cfm_diag.F", - "cp_fm_basic_linalg.F", - "cp_fm_cholesky.F", - "cp_fm_diag.F", - "message_passing.F", - "dbt_split.F", - "cp_cfm_cholesky.F", "pw_methods.F", - "xc_libxc_wrap.F", + "local_gemm_api.F", + "cp_fm_diag.F", + "cp_fm_cholesky.F", + "cp_fm_basic_linalg.F", + "cp_cfm_diag.F", + "cp_cfm_cholesky.F", + "cp_cfm_basic_linalg.F", + "dbt_split.F", "dbt_tas_util.F", + "dbt_array_list_methods.F", + "xc_libxc_wrap.F", + "ai_contraction_sphi.F", + "smeagol_control_types.F", ] # ============================================================================== [check.per-file-ignores] -"environment.F" = ["line-too-long"] -"libgint_wrapper.F" = ["trailing-backslash"] -"qs_block_davidson_types.F" = ["trailing-backslash"] -"qs_linres_current.F" = ["trailing-backslash"] -"qs_local_properties.F" = ["unreachable-statement"] -"qs_tddfpt2_subgroups.F" = ["trailing-backslash"] -"semi_empirical_int_ana.F" = ["misleading-inline-if-semicolon"] -"pilaenv_hack.F" = ["procedure-not-in-module"] "semi_empirical_int_debug.F" = ["procedure-not-in-module"] -"eri_mme_lattice_summation.F" = ["trailing-whitespace"] "gopt_f77_methods.F" = ["procedure-not-in-module"] -"fftw3_lib.F" = ["misleading-inline-if-semicolon"] +"pilaenv_hack.F" = ["procedure-not-in-module"] #EOF diff --git a/tools/precommit/requirements.txt b/tools/precommit/requirements.txt index ff1aa191ec..efef9f6b05 100644 --- a/tools/precommit/requirements.txt +++ b/tools/precommit/requirements.txt @@ -4,7 +4,7 @@ click==8.3.1 cmake-format==0.6.13 cmakelang==0.6.13 Flask==3.1.3 -fortitude-lint==0.9.0 +fortitude-lint==0.7.5 gunicorn==25.1.0 itsdangerous==2.2.0 Jinja2==3.1.6 diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index bf453fe460..81c2bb12fa 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -70,6 +70,10 @@ spack: require: - "+fortran" + libxsmm: + require: + - "+fortran" + openblas: require: - "threads=openmp" @@ -180,7 +184,7 @@ spack: repos: builtin: - commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 + commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 specs: # Build tools @@ -211,7 +215,7 @@ spack: - "libsmeagol@1.2" - "libvdwxc@0.5.0" - "libvori@220621" - - "libxc@7.1.2" + - "libxc@7.0.0" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" @@ -227,8 +231,8 @@ spack: - "spfft@1.1.1" - "spglib@2.7.0" - "spla@1.6.1" - - "tblite@0.7.0" - - "trexio@2.6.1" + - "tblite@0.6.0" + - "trexio@2.5.0" view: default: diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index b6c58ab0ba..0fcbfba865 100644 --- a/tools/spack/cp2k_deps_s-static.yaml +++ b/tools/spack/cp2k_deps_s-static.yaml @@ -49,6 +49,10 @@ spack: - "+fortran" - "~shared" + libxsmm: + require: + - "+fortran" + openblas: require: - "+fortran" @@ -92,7 +96,7 @@ spack: repos: builtin: - commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 + commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 specs: # Build tools @@ -109,13 +113,13 @@ spack: - "libfci@0.1.0" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.1.2" + - "libxc@7.0.0" - "libxs@1.0.0" - "libxsmm@2.0.0" - "openblas@0.3.33" - "pace@2025.12.4.1" - "spglib@2.7.0" - - "tblite@0.7.0" + - "tblite@0.6.0" view: default: diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index af215c0c37..8cbf31adc4 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -56,6 +56,10 @@ spack: require: - "+fortran" + libxsmm: + require: + - "+fortran" + openblas: require: - "+fortran" @@ -113,7 +117,7 @@ spack: repos: builtin: - commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 + commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 specs: # Build tools @@ -134,7 +138,7 @@ spack: # - "libgint@release_v1" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.1.2" + - "libxc@7.0.0" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" @@ -142,8 +146,8 @@ spack: - "pace@2025.12.4.1" - "py-torch@2.12.1" - "spglib@2.7.0" - - "tblite@0.7.0" - - "trexio@2.6.1" + - "tblite@0.6.0" + - "trexio@2.5.0" view: default: diff --git a/tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py b/tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py new file mode 100644 index 0000000000..308023e3b1 --- /dev/null +++ b/tools/spack/spack_repo/cp2k_dev/packages/libxsmm/package.py @@ -0,0 +1,60 @@ +# Copyright Spack Project Developers. See COPYRIGHT file for details. +# +# SPDX-License-Identifier: (Apache-2.0 OR MIT) + +from spack_repo.builtin.build_systems.cmake import CMakePackage + +from spack.package import * + + +class Libxsmm(CMakePackage): + """LIBXSMM is high performance library for small dense and sparse linear + algebra opertions incl. GEMM and elementwise primities often seen in deep + learning applications. It also serves as reference implementation of Tensor + Processing Primitives (TPP), a programming abstraction for efficient and + portable deep learning and HPC workloads. With version 2.0, LIBXSMM focuses + on providing a complete and architecture-portable set of TPPs (small dense + and sparse matrix operations as well as element-wise, GEMM, and BRGEMM + primitives) from which higher-level operators such as convolutions, + fully-connected layers, normalization, and pooling are composed. LIBXSMM + targets Intel Architecture with Intel SSE, Intel AVX, Intel AVX2, Intel + AVX‑512 (with VNNI and Bfloat16), and Intel AMX (Advanced Matrix + Extensions), AArch64 (NEON, SVE, and SME), and RISC‑V (RVV). Code generation + is mainly based on Just‑In‑Time (JIT) code specialization for + compiler-independent performance (matrix multiplications, matrix + transpose/copy, sparse functionality, and tensor primitives). LIBXSMM is + suitable for "build once and deploy everywhere", i.e., no special target + flags are needed to exploit the available performance. Supported GEMM + datatypes are: FP64, FP32, FP16, bfloat16, BF8, HF8, MXBF8, MXHF8, int16, + int8, MXBF6, MXHF6, MXFP4, int4, int2 and int1. Additionally, various + non-standard low precision combinations are supported.""" + + homepage = "https://github.com/libxsmm/libxsmm" + url = "https://github.com/libxsmm/libxsmm/archive/2.0.0.tar.gz" + git = "https://github.com/libxsmm/libxsmm.git" + + maintainers("hfp", "mkrack") + + license("BSD-3-Clause") + + version("main", branch="main") + version("2.0.0", sha256="7e532dc5520f864ce6d7f44f3fd50365e3edb23da97dbdc54fd53845d86a290b") + + variant("shared", default=False, description="With shared libraries.") + variant("fortran", default=True, description="With Fortran support.") + + depends_on("c", type="build") + depends_on("cxx", type="build") + depends_on("fortran", type="build", when="+fortran") + + depends_on("python", type="build") + depends_on("cmake@3.13:", type="build") + + requires("target=x86_64:", "target=aarch64:") + + def cmake_args(self): + spec = self.spec + return [ + self.define("BUILD_SHARED_LIBS", spec.satisfies("+shared")), + self.define("LIBXSMM_FORTRAN", spec.satisfies("+fortran")), + ] diff --git a/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py b/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py index 88290e14a8..6d4f7c8177 100644 --- a/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py +++ b/tools/spack/spack_repo/cp2k_dev/packages/tblite/package.py @@ -2,13 +2,14 @@ # # SPDX-License-Identifier: (Apache-2.0 OR MIT) -from spack_repo.builtin.build_systems import cmake +from spack_repo.builtin.build_systems import cmake, meson from spack_repo.builtin.build_systems.cmake import CMakePackage +from spack_repo.builtin.build_systems.meson import MesonPackage from spack.package import * -class Tblite(CMakePackage): +class Tblite(CMakePackage, MesonPackage): """Light-weight tight-binding framework""" homepage = "https://tblite.readthedocs.io" @@ -20,31 +21,59 @@ class Tblite(CMakePackage): license("LGPL-3.0-or-later") version("main", branch="main") - version("0.7.0", sha256="3a7cb4602101e828caf41c38ca5e30f82de82d0d26d5db40168acdcad3462b92") version("0.6.0", sha256="372281aedb89234168d00eb691addb303197a9462a9c55d145c835f2cf5e8b42") version("0.5.0", sha256="e8a70b72ed0a0db0621c7958c63667a9cd008c97c868a4a417ff1bc262052ea8") version("0.4.0", sha256="5c2249b568bfd3b987d3b28f2cbfddd5c37f675b646e17c1e750428380af464b") version("0.3.0", sha256="46d77c120501ac55ed6a64dea8778d6593b26fb0653c591f8e8c985e35884f0a") + build_system("cmake", "meson", default="meson") + variant("openmp", default=True, description="Use OpenMP parallelisation") - variant("trexio", default=False, description="Enable TREXIO support", when="@0.7.0:") - variant("hdf5", default=False, description="Enable HDF5 support", when="@0.7.0:") + variant("python", default=False, description="Build Python extension module") depends_on("c", type="build") # generated depends_on("fortran", type="build") # generated depends_on("blas") depends_on("lapack") - depends_on("trexio", when="+trexio") - depends_on("hdf5", when="+hdf5") + + # for build_system in ["cmake", "meson"]: + # depends_on( + # f"mctc-lib@0.3: build_system={build_system}", when=f"build_system={build_system}" + # ) + # depends_on( + # f"simple-dftd3@0.3: build_system={build_system}", when=f"build_system={build_system}" + # ) + # depends_on(f"dftd4@3: build_system={build_system}", when=f"build_system={build_system}") + # depends_on(f"toml-f build_system={build_system}", when=f"build_system={build_system}") + + depends_on("dftd4@:3.7", when="@:0.5") + depends_on("meson@0.57.2:", type="build", when="build_system=meson") # mesonbuild/meson#8377 + depends_on("pkgconfig", type="build") + depends_on("py-cffi", when="+python") + depends_on("py-numpy", when="+python") + depends_on("python@3.6:", when="+python") + + extends("python", when="+python") + + +class MesonBuilder(meson.MesonBuilder): + def meson_args(self): + lapack = self.spec["lapack"].libs.names[0] + if lapack == "lapack": + lapack = "netlib" + elif lapack.startswith("mkl"): + lapack = "mkl" + elif lapack != "openblas": + lapack = "auto" + + return [ + "-Dlapack={0}".format(lapack), + "-Dopenmp={0}".format(str("+openmp" in self.spec).lower()), + "-Dpython={0}".format(str("+python" in self.spec).lower()), + ] class CMakeBuilder(cmake.CMakeBuilder): def cmake_args(self): - args = [self.define_from_variant("WITH_OpenMP", "openmp")] - if self.spec.satisfies("@0.7.0:"): - args += [ - self.define_from_variant("TBLITE_WITH_TREXIO", "trexio"), - self.define_from_variant("TBLITE_WITH_HDF5", "hdf5"), - ] - return args + return [self.define_from_variant("WITH_OpenMP", "openmp")] diff --git a/tools/toolchain/build_cp2k.sh b/tools/toolchain/build_cp2k.sh index b8a671c904..981a109e8b 100755 --- a/tools/toolchain/build_cp2k.sh +++ b/tools/toolchain/build_cp2k.sh @@ -178,8 +178,7 @@ source "${TOOLCHAIN_INSTALL_DIR}/setup" source "${TOOLCHAIN_INSTALL_DIR}/toolchain.conf" # Generate cmake options for compiling cp2k -CMAKE_OPTIONS="-DCMAKE_INSTALL_PREFIX=${CMAKE_INSTALL_PREFIX} -DCMAKE_INSTALL_LIBDIR=lib" -CMAKE_OPTIONS+=" -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS}" +CMAKE_OPTIONS="-DCMAKE_INSTALL_PREFIX=${CMAKE_INSTALL_PREFIX} -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS}" if [[ ${CMAKE_INSTALL_PREFIX} == ${CP2K_ROOT}/* ]]; then CMAKE_OPTIONS+=" -DCP2K_DATA_DIR=${CP2K_ROOT}/data" fi diff --git a/tools/toolchain/scripts/stage3/install_libxc.sh b/tools/toolchain/scripts/stage3/install_libxc.sh index 712612cce9..c08347ebb0 100755 --- a/tools/toolchain/scripts/stage3/install_libxc.sh +++ b/tools/toolchain/scripts/stage3/install_libxc.sh @@ -6,8 +6,8 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -libxc_ver="7.1.2" -libxc_sha256="3915fac94416e4c415534223ea492ad2663f928acf27e98662c861b094a6c306" +libxc_ver="7.0.0" +libxc_sha256="e9ae69f8966d8de6b7585abd9fab588794ada1fab8f689337959a35abbf9527d" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh source "${SCRIPT_DIR}"/signal_trap.sh @@ -34,23 +34,34 @@ case "$with_libxc" in cd libxc-${libxc_ver} mkdir build cd build - if [ "${with_gcc}" != "__DONTUSE__" ] && - [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then - # Turn off variable tracking - LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" - else - LIBXC_CFLAGS="" + + # Lower the optimization level of KXC functionals for GCC to reduce time cost + # LXC functionals are not used so ignore them + if [ "${with_gcc}" != "__DONTUSE__" ]; then + if [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then + MAPLE2C_DIR="../src/maple2c" + for f in "$MAPLE2C_DIR"/gga_exc/*.c "$MAPLE2C_DIR"/mgga_exc/*.c "$MAPLE2C_DIR"/lda_exc/*.c; do + [ -f "$f" ] || continue + if grep -q "^func_kxc_" "$f" && ! grep -q "__attribute__((optimize" "$f"; then + sed -i 's/^func_kxc_/__attribute__((optimize("O1"))) func_kxc_/' "$f" + fi + done + LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" + else + LIBXC_CFLAGS="${CFLAGS}" + fi fi - # CP2K make use of third derivatives in libxc + + # CP2K does not make use of fourth derivatives, so skip their compilation with -DDISABLE_KXC=OFF + # Add "-DCMAKE_POLICY_VERSION_MINIMUM=3.5" to keep legacy compatibility for CMake version 4.x CFLAGS="${LIBXC_CFLAGS}" cmake \ - -DCMAKE_BUILD_TYPE="RelWithDebInfo" \ -DCMAKE_INSTALL_PREFIX="${pkg_install_dir}" \ - -DCMAKE_INSTALL_LIBDIR="lib" \ + -DCMAKE_INSTALL_LIBDIR=lib \ -DCMAKE_VERBOSE_MAKEFILE=ON \ - -DBUILD_SHARED_LIBS=OFF \ -DBUILD_TESTING=OFF \ -DENABLE_FORTRAN=ON \ - -DMAXORDER=3 \ + -DDISABLE_KXC=OFF \ + -DCMAKE_POLICY_VERSION_MINIMUM=3.5 \ .. > configure.log 2>&1 || tail_excerpt configure.log make -j $(get_nprocs) > make.log 2>&1 || tail_excerpt make.log make install > install.log 2>&1 || tail_excerpt install.log diff --git a/tools/toolchain/scripts/stage4/install_cusolvermp.sh b/tools/toolchain/scripts/stage4/install_cusolvermp.sh index be73615f2a..2c08b8687f 100755 --- a/tools/toolchain/scripts/stage4/install_cusolvermp.sh +++ b/tools/toolchain/scripts/stage4/install_cusolvermp.sh @@ -41,10 +41,6 @@ case "${with_cusolvermp}" in esac if [ "${with_cusolvermp}" != "__DONTUSE__" ]; then - # These values can be inherited from a previous toolchain run. Only export - # roots for the communication backend selected by the detected version. - unset NCCL_ROOT CAL_ROOT UCC_ROOT UCX_ROOT - if [ "${cusolvermp_header}" = "__FALSE__" ] || ! [ -f "${cusolvermp_header}" ]; then report_error ${LINENO} "Could not find cusolverMp.h." exit 1 @@ -61,7 +57,6 @@ if [ "${with_cusolvermp}" != "__DONTUSE__" ]; then cusolvermp_minor="${cusolvermp_minor:-0}" if [ "${cusolvermp_major}" -gt 0 ] || [ "${cusolvermp_minor}" -ge 7 ]; then - cusolvermp_comm_backend="nccl" nccl_lib="$(find_in_paths "libnccl.*" $LIB_PATHS)" if [ "${nccl_lib}" = "__FALSE__" ]; then report_error ${LINENO} "Could not find NCCL required by cuSOLVERMp ${cusolvermp_major}.${cusolvermp_minor}." @@ -69,42 +64,43 @@ if [ "${with_cusolvermp}" != "__DONTUSE__" ]; then fi NCCL_ROOT="$(dirname "$(dirname "${nccl_lib}")")" else - cusolvermp_comm_backend="cal" cal_lib="$(find_in_paths "libcal.*" $LIB_PATHS)" if [ "${cal_lib}" = "__FALSE__" ]; then report_error ${LINENO} "Could not find CAL required by cuSOLVERMp ${cusolvermp_major}.${cusolvermp_minor}." exit 1 fi CAL_ROOT="$(dirname "$(dirname "${cal_lib}")")" - ucc_lib="$(find_in_paths "libucc.*" $LIB_PATHS)" - ucx_lib="$(find_in_paths "libucs.*" $LIB_PATHS)" - if [ "${ucc_lib}" = "__FALSE__" ] || [ "${ucx_lib}" = "__FALSE__" ]; then - report_error ${LINENO} "Could not find UCC/UCX required by cuSOLVERMp ${cusolvermp_major}.${cusolvermp_minor}." - exit 1 - fi - UCC_ROOT="$(dirname "$(dirname "${ucc_lib}")")" - UCX_ROOT="$(dirname "$(dirname "${ucx_lib}")")" fi + ucc_lib="$(find_in_paths "libucc.*" $LIB_PATHS)" + ucx_lib="$(find_in_paths "libucs.*" $LIB_PATHS)" + if [ "${ucc_lib}" = "__FALSE__" ] || [ "${ucx_lib}" = "__FALSE__" ]; then + report_error ${LINENO} "Could not find UCC/UCX required by cuSOLVERMp." + exit 1 + fi + UCC_ROOT="$(dirname "$(dirname "${ucc_lib}")")" + UCX_ROOT="$(dirname "$(dirname "${ucx_lib}")")" + cat << EOF > "${BUILDDIR}/setup_cusolvermp" export CUSOLVERMP_VER="${cusolvermp_major}.${cusolvermp_minor}" export CUSOLVERMP_LIBS="${CUSOLVERMP_LIBS}" export CUSOLVER_MP_ROOT="${pkg_install_dir}" +export UCC_ROOT="${UCC_ROOT}" +export UCX_ROOT="${UCX_ROOT}" prepend_path CMAKE_PREFIX_PATH "${pkg_install_dir}" +prepend_path CMAKE_PREFIX_PATH "${UCC_ROOT}" +prepend_path CMAKE_PREFIX_PATH "${UCX_ROOT}" EOF - if [ "${cusolvermp_comm_backend}" = "nccl" ]; then + if [ -n "${NCCL_ROOT}" ]; then cat << EOF >> "${BUILDDIR}/setup_cusolvermp" export NCCL_ROOT="${NCCL_ROOT}" prepend_path CMAKE_PREFIX_PATH "${NCCL_ROOT}" EOF - else + fi + if [ -n "${CAL_ROOT}" ]; then cat << EOF >> "${BUILDDIR}/setup_cusolvermp" export CAL_ROOT="${CAL_ROOT}" prepend_path CMAKE_PREFIX_PATH "${CAL_ROOT}" -export UCC_ROOT="${UCC_ROOT}" -export UCX_ROOT="${UCX_ROOT}" -prepend_path CMAKE_PREFIX_PATH "${UCC_ROOT}" -prepend_path CMAKE_PREFIX_PATH "${UCX_ROOT}" EOF fi filter_setup "${BUILDDIR}/setup_cusolvermp" "${SETUPFILE}" diff --git a/tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch b/tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch new file mode 100644 index 0000000000..e467cf852e --- /dev/null +++ b/tools/toolchain/scripts/stage8/dftd4-4.2.0-gradient-fixes.patch @@ -0,0 +1,574 @@ +diff --git a/src/dftd4/cutoff.f90 b/src/dftd4/cutoff.f90 +index 86a856b..40f299f 100644 +--- a/src/dftd4/cutoff.f90 ++++ b/src/dftd4/cutoff.f90 +@@ -20,7 +20,7 @@ module dftd4_cutoff + implicit none + private + +- public :: realspace_cutoff, get_lattice_points, smooth_cutoff ++ public :: realspace_cutoff, get_lattice_points, smooth_cutoff, apply_smooth_width_env + + + !> Coordination number cutoff +@@ -53,7 +53,7 @@ module dftd4_cutoff + real(wp) :: disp3 = disp3_default + + !> Width of smooth two-body interaction cutoff +- real(wp) :: width2 = 0.0_wp ++ real(wp) :: width2 = 0.05_wp + + !> Width of smooth three-body interaction cutoff + real(wp) :: width3 = 0.0_wp +@@ -70,6 +70,46 @@ module dftd4_cutoff + contains + + ++subroutine apply_smooth_width_env(cutoff) ++ ++ type(realspace_cutoff), intent(inout) :: cutoff ++ ++ call get_smooth_width("DFTD4_DISP2_SMOOTH_WIDTH", "TBLITE_D4_DISP2_SMOOTH_WIDTH", & ++ & cutoff%disp2, cutoff%width2) ++ call get_smooth_width("DFTD4_DISP3_SMOOTH_WIDTH", "TBLITE_D4_DISP3_SMOOTH_WIDTH", & ++ & cutoff%disp3, cutoff%width3) ++ ++end subroutine apply_smooth_width_env ++ ++ ++subroutine get_smooth_width(env1, env2, cutoff, width) ++ ++ character(len=*), intent(in) :: env1, env2 ++ real(wp), intent(in) :: cutoff ++ real(wp), intent(inout) :: width ++ ++ character(len=64) :: env ++ integer :: stat, io ++ real(wp) :: env_width ++ ++ call get_environment_variable(env1, env, status=stat) ++ if (stat /= 0 .or. len_trim(env) == 0) then ++ call get_environment_variable(env2, env, status=stat) ++ end if ++ if (stat == 0 .and. len_trim(env) > 0) then ++ read(env, *, iostat=io) env_width ++ if (io == 0) then ++ if (env_width > 0.0_wp .and. env_width < cutoff) then ++ width = env_width ++ else ++ width = 0.0_wp ++ end if ++ end if ++ end if ++ ++end subroutine get_smooth_width ++ ++ + !> Smooth polynomial switch for realspace cutoffs + pure subroutine smooth_cutoff(r, cutoff, width, sw, dswdr) + +diff --git a/src/dftd4/damping/atm.f90 b/src/dftd4/damping/atm.f90 +index c6162c9..3f4f46a 100644 +--- a/src/dftd4/damping/atm.f90 ++++ b/src/dftd4/damping/atm.f90 +@@ -145,23 +145,16 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, a1, a2, alp, + real(wp) :: r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang + real(wp) :: cutoff2, c9, dE, alp3, swij, swjk, swik, dswdr, sw + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + alp3 = alp / 3.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(dynamic) default(none) reduction(+:energy) & + !$omp shared(mol, trans, c6, s9, a1, a2, alp3, r4r2, cutoff2, cutoff, width) & + !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & + !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & + !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & +- !$omp& swij, swjk, swik, dswdr, sw) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(dynamic) ++ !$omp& swij, swjk, swik, dswdr, sw) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -212,20 +205,15 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, a1, a2, alp, + rr = ang*fdmp + + dE = rr * c9 * triple * third * sw +- energy_local(iat) = energy_local(iat) - dE +- energy_local(jat) = energy_local(jat) - dE +- energy_local(kat) = energy_local(kat) - dE ++ energy(iat) = energy(iat) - dE ++ energy(jat) = energy(jat) - dE ++ energy(kat) = energy(kat) - dE + end do + end do + end do + end do + end do +- !$omp end do +- !$omp critical (get_atm_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_atm_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_atm_dispersion_energy + +@@ -293,34 +281,19 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, a1, a2, alp, + real(wp) :: dGij(3), dGjk(3), dGik(3), dS(3, 3) + real(wp) :: swij, swjk, swik, dswijdr, dswjkdr, dswikdr, sw + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: dEdq_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + alp3 = alp / 3.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(dynamic) default(none) & ++ !$omp reduction(+:energy, gradient, sigma, dEdcn, dEdq) & + !$omp shared(mol, trans, c6, s9, a1, a2, alp, alp3, r4r2, cutoff2, & + !$omp& cutoff, width, dc6dcn, dc6dq) & + !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & + !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & + !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, dfdmp, ang, dang, & + !$omp& c9, dE, dE0, dE_third, dGij, dGjk, dGik, dS, swij, swjk, swik, & +- !$omp& dswijdr, dswjkdr, dswikdr, sw) & +- !$omp shared(energy, gradient, sigma, dEdcn, dEdq) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local, & +- !$omp& dEdq_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(dEdq_local(size(dEdq, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(dynamic) ++ !$omp& dswijdr, dswjkdr, dswikdr, sw) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -399,55 +372,42 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, a1, a2, alp, + + dE = dE0 * triple * sw + dE_third = dE * third +- energy_local(iat) = energy_local(iat) - dE_third +- energy_local(jat) = energy_local(jat) - dE_third +- energy_local(kat) = energy_local(kat) - dE_third ++ energy(iat) = energy(iat) - dE_third ++ energy(jat) = energy(jat) - dE_third ++ energy(kat) = energy(kat) - dE_third + +- gradient_local(:, iat) = gradient_local(:, iat) & ++ gradient(:, iat) = gradient(:, iat) & + & - (dGij + dGik) * triple +- gradient_local(:, jat) = gradient_local(:, jat) & ++ gradient(:, jat) = gradient(:, jat) & + & + (dGij - dGjk) * triple +- gradient_local(:, kat) = gradient_local(:, kat) & ++ gradient(:, kat) = gradient(:, kat) & + & + (dGik + dGjk) * triple + + dS(:, :) = spread(dGij, 1, 3) * spread(vij, 2, 3)& + & + spread(dGik, 1, 3) * spread(vik, 2, 3)& + & + spread(dGjk, 1, 3) * spread(vjk, 2, 3) + +- sigma_local(:, :) = sigma_local + dS * triple ++ sigma(:, :) = sigma(:, :) + dS * triple + +- dEdcn_local(iat) = dEdcn_local(iat) - dE * 0.5_wp & ++ dEdcn(iat) = dEdcn(iat) - dE * 0.5_wp & + & * (dc6dcn(iat, jat) / c6ij + dc6dcn(iat, kat) / c6ik) +- dEdcn_local(jat) = dEdcn_local(jat) - dE * 0.5_wp & ++ dEdcn(jat) = dEdcn(jat) - dE * 0.5_wp & + & * (dc6dcn(jat, iat) / c6ij + dc6dcn(jat, kat) / c6jk) +- dEdcn_local(kat) = dEdcn_local(kat) - dE * 0.5_wp & ++ dEdcn(kat) = dEdcn(kat) - dE * 0.5_wp & + & * (dc6dcn(kat, iat) / c6ik + dc6dcn(kat, jat) / c6jk) + +- dEdq_local(iat) = dEdq_local(iat) - dE * 0.5_wp & ++ dEdq(iat) = dEdq(iat) - dE * 0.5_wp & + & * (dc6dq(iat, jat) / c6ij + dc6dq(iat, kat) / c6ik) +- dEdq_local(jat) = dEdq_local(jat) - dE * 0.5_wp & ++ dEdq(jat) = dEdq(jat) - dE * 0.5_wp & + & * (dc6dq(jat, iat) / c6ij + dc6dq(jat, kat) / c6jk) +- dEdq_local(kat) = dEdq_local(kat) - dE * 0.5_wp & ++ dEdq(kat) = dEdq(kat) - dE * 0.5_wp & + & * (dc6dq(kat, iat) / c6ik + dc6dq(kat, jat) / c6jk) + end do + end do + end do + end do + end do +- !$omp end do +- !$omp critical (get_atm_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- dEdq(:) = dEdq(:) + dEdq_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_atm_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(dEdq_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_atm_dispersion_derivs + +diff --git a/src/dftd4/damping/rational.f90 b/src/dftd4/damping/rational.f90 +index 9d359c9..87e8f6b 100644 +--- a/src/dftd4/damping/rational.f90 ++++ b/src/dftd4/damping/rational.f90 +@@ -152,20 +152,13 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, r4r2, c6, ener + real(wp) :: vec(3), r2, r, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE + real(wp) :: sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r0ij, rrij, c6ij, & +- !$omp& t6, t8, edisp, dE, r, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& t6, t8, edisp, dE, r, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -188,19 +181,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, r4r2, c6, ener + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE ++ energy(iat) = energy(iat) + dE + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE ++ energy(jat) = energy(jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_energy + +@@ -256,29 +244,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, r4r2, c6, dc6d + real(wp) :: edisp0, gdisp0, edisp, gdisp, sw, dswdr + real(wp) :: dE, dG(3), dS(3, 3) + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: dEdq_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) & ++ !$omp reduction(+:energy, gradient, sigma, dEdcn, dEdq) & + !$omp shared(mol, self, c6, dc6dcn, dc6dq, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r0ij, rrij, c6ij, t6, t8, & +- !$omp& d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, r, sw, dswdr) & +- !$omp shared(energy, gradient, sigma, dEdcn, dEdq) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local, & +- !$omp& dEdq_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(dEdq_local(size(dEdq, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, r, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -310,35 +283,22 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, r4r2, c6, dc6d + dG(:) = -c6ij*gdisp*vec + dS(:, :) = spread(dG, 1, 3) * spread(vec, 2, 3) * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE +- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp +- dEdq_local(iat) = dEdq_local(iat) - dc6dq(iat, jat) * edisp +- sigma_local(:, :) = sigma_local + dS ++ energy(iat) = energy(iat) + dE ++ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp ++ dEdq(iat) = dEdq(iat) - dc6dq(iat, jat) * edisp ++ sigma(:, :) = sigma(:, :) + dS + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE +- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp +- dEdq_local(jat) = dEdq_local(jat) - dc6dq(jat, iat) * edisp +- gradient_local(:, iat) = gradient_local(:, iat) + dG +- gradient_local(:, jat) = gradient_local(:, jat) - dG +- sigma_local(:, :) = sigma_local + dS ++ energy(jat) = energy(jat) + dE ++ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp ++ dEdq(jat) = dEdq(jat) - dc6dq(jat, iat) * edisp ++ gradient(:, iat) = gradient(:, iat) + dG ++ gradient(:, jat) = gradient(:, jat) - dG ++ sigma(:, :) = sigma(:, :) + dS + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- dEdq(:) = dEdq(:) + dEdq_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(dEdq_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_derivs + +@@ -429,21 +389,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, r4r2, c6, e + real(wp) :: vec(3), r2, r, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE + real(wp) :: sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + if (abs(self%s6) < epsilon(1.0_wp) .and. abs(self%s8) < epsilon(1.0_wp)) return + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r0ij, rrij, c6ij, & +- !$omp& t6, t8, edisp, dE, r, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& t6, t8, edisp, dE, r, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -466,19 +419,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, r4r2, c6, e + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(jat, iat) = energy_local(jat, iat) + dE ++ energy(jat, iat) = energy(jat, iat) + dE + if (iat /= jat) then +- energy_local(iat, jat) = energy_local(iat, jat) + dE ++ energy(iat, jat) = energy(iat, jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion2_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion2_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion2 + +@@ -517,24 +465,17 @@ subroutine get_pairwise_dispersion3(self, mol, trans, cutoff, width, r4r2, c6, e + real(wp) :: r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang + real(wp) :: cutoff2, c9, dE, alp3, swij, swjk, swik, dswdr, sw + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + if (abs(self%s9) < epsilon(1.0_wp)) return + cutoff2 = cutoff*cutoff + alp3 = self%alp / 3.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, trans, c6, r4r2, cutoff2, cutoff, width, alp3, self) & + !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & + !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & + !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & +- !$omp& swij, swjk, swik, dswdr, sw) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& swij, swjk, swik, dswdr, sw) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -585,23 +526,18 @@ subroutine get_pairwise_dispersion3(self, mol, trans, cutoff, width, r4r2, c6, e + rr = ang*fdmp + + dE = rr * c9 * triple * sixth * sw +- energy_local(jat, iat) = energy_local(jat, iat) - dE +- energy_local(kat, iat) = energy_local(kat, iat) - dE +- energy_local(iat, jat) = energy_local(iat, jat) - dE +- energy_local(kat, jat) = energy_local(kat, jat) - dE +- energy_local(iat, kat) = energy_local(iat, kat) - dE +- energy_local(jat, kat) = energy_local(jat, kat) - dE ++ energy(jat, iat) = energy(jat, iat) - dE ++ energy(kat, iat) = energy(kat, iat) - dE ++ energy(iat, jat) = energy(iat, jat) - dE ++ energy(kat, jat) = energy(kat, jat) - dE ++ energy(iat, kat) = energy(iat, kat) - dE ++ energy(jat, kat) = energy(jat, kat) - dE + end do + end do + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion3_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion3_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion3 + +diff --git a/src/dftd4/disp.f90 b/src/dftd4/disp.f90 +index 73253ce..8524cef 100644 +--- a/src/dftd4/disp.f90 ++++ b/src/dftd4/disp.f90 +@@ -18,7 +18,7 @@ + module dftd4_disp + use, intrinsic :: iso_fortran_env, only : error_unit + use dftd4_blas, only : d4_gemv +- use dftd4_cutoff, only : realspace_cutoff, get_lattice_points ++ use dftd4_cutoff, only : realspace_cutoff, get_lattice_points, apply_smooth_width_env + use dftd4_damping, only : damping_param + use dftd4_data, only : get_covalent_rad + use dftd4_model, only : dispersion_model +@@ -70,9 +70,12 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) + real(wp), allocatable :: dEdcn(:), dEdq(:), energies(:) + real(wp), allocatable :: lattr(:, :) + type(error_type), allocatable :: error ++ type(realspace_cutoff) :: cutoff_eff + + mref = maxval(disp%ref) + grad = present(gradient).or.present(sigma) ++ cutoff_eff = cutoff ++ call apply_smooth_width_env(cutoff_eff) + + if (.not. allocated(disp%mchrg)) then + write(error_unit, '("[Error]:", 1x, a)') "Not supported for non-self-consistent D4 version" +@@ -80,8 +83,8 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) + end if + + allocate(cn(mol%nat)) +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) +- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, disp%en, cn) ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) ++ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, disp%en, cn) + + allocate(q(mol%nat)) + if (grad) allocate(dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat)) +@@ -109,8 +112,8 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) + sigma(:, :) = 0.0_wp + end if + +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) +- call param%get_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, disp%r4r2, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) ++ call param%get_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, disp%r4r2, & + & c6, dc6dcn, dc6dq, energies, dEdcn, dEdq, gradient, sigma) + if (grad) then + call d4_gemv(dqdr, dEdq, gradient, beta=1.0_wp) +@@ -121,11 +124,11 @@ subroutine get_dispersion(mol, disp, param, cutoff, energy, gradient, sigma) + call disp%weight_references(mol, cn, q, gwvec, gwdcn, gwdq) + call disp%get_atomic_c6(mol, gwvec, gwdcn, gwdq, c6, dc6dcn, dc6dq) + +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) +- call param%get_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, disp%r4r2, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) ++ call param%get_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, disp%r4r2, & + & c6, dc6dcn, dc6dq, energies, dEdcn, dEdq, gradient, sigma) + if (grad) then +- call add_coordination_number_derivs(mol, lattr, cutoff%cn, & ++ call add_coordination_number_derivs(mol, lattr, cutoff_eff%cn, & + & disp%rcov, disp%en, dEdcn, gradient, sigma) + end if + +@@ -213,6 +216,7 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) + integer :: mref + real(wp), allocatable :: cn(:), q(:), gwvec(:, :, :), c6(:, :), lattr(:, :) + type(error_type), allocatable :: error ++ type(realspace_cutoff) :: cutoff_eff + + if (.not. allocated(disp%mchrg)) then + write(error_unit, '("[Error]:", 1x, a)') "Not supported for non-self-consistent D4 version" +@@ -220,10 +224,12 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) + end if + + mref = maxval(disp%ref) ++ cutoff_eff = cutoff ++ call apply_smooth_width_env(cutoff_eff) + + allocate(cn(mol%nat)) +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) +- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, disp%en, cn) ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) ++ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, disp%en, cn) + + allocate(q(mol%nat)) + call get_charges(disp%mchrg, mol, error, q) +@@ -240,16 +246,16 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) + + energy2(:, :) = 0.0_wp + energy3(:, :) = 0.0_wp +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) +- call param%get_pairwise_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) ++ call param%get_pairwise_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, & + & disp%r4r2, c6, energy2) + + q(:) = 0.0_wp + call disp%weight_references(mol, cn, q, gwvec) + call disp%get_atomic_c6(mol, gwvec, c6=c6) + +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) +- call param%get_pairwise_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) ++ call param%get_pairwise_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, & + & disp%r4r2, c6, energy3) + + end subroutine get_pairwise_dispersion diff --git a/tools/toolchain/scripts/stage8/install_tblite.sh b/tools/toolchain/scripts/stage8/install_tblite.sh index 5932f6034c..9c9654af8f 100755 --- a/tools/toolchain/scripts/stage8/install_tblite.sh +++ b/tools/toolchain/scripts/stage8/install_tblite.sh @@ -6,8 +6,10 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -tblite_ver="0.7.0" -tblite_sha256="3a7cb4602101e828caf41c38ca5e30f82de82d0d26d5db40168acdcad3462b92" +tblite_ver="0.6.0" +tblite_sha256="372281aedb89234168d00eb691addb303197a9462a9c55d145c835f2cf5e8b42" +tblite_sdftd3_ver="1.4.0" +tblite_dftd4_ver="4.2.0" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh @@ -34,6 +36,12 @@ case "$with_tblite" in [ -d tblite-${tblite_ver} ] && rm -rf tblite-${tblite_ver} tar -xJf tblite-${tblite_ver}.tar.xz cd tblite-${tblite_ver} + + patch -l -d subprojects/s-dftd3 -p1 < "${SCRIPT_DIR}/stage8/simple-dftd3-${tblite_sdftd3_ver}-gradient-fixes.patch" \ + > simple_dftd3_gradient_fixes.patch.log 2>&1 || tail_excerpt simple_dftd3_gradient_fixes.patch.log + patch -l -d subprojects/dftd4 -p1 < "${SCRIPT_DIR}/stage8/dftd4-${tblite_dftd4_ver}-gradient-fixes.patch" \ + > dftd4_gradient_fixes.patch.log 2>&1 || tail_excerpt dftd4_gradient_fixes.patch.log + mkdir -p build && cd build cmake \ -DCMAKE_INSTALL_PREFIX="${pkg_install_dir}" \ @@ -44,7 +52,9 @@ case "$with_tblite" in .. \ > cmake.log 2>&1 || tail_excerpt cmake.log make install -j $(get_nprocs) > make.log 2>&1 || tail_excerpt make.log - write_checksums "${install_lock_file}" "${SCRIPT_DIR}/stage8/$(basename ${SCRIPT_NAME})" + write_checksums "${install_lock_file}" "${SCRIPT_DIR}/stage8/$(basename ${SCRIPT_NAME})" \ + "${SCRIPT_DIR}/stage8/simple-dftd3-${tblite_sdftd3_ver}-gradient-fixes.patch" \ + "${SCRIPT_DIR}/stage8/dftd4-${tblite_dftd4_ver}-gradient-fixes.patch" cd .. fi ;; diff --git a/tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch b/tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch new file mode 100644 index 0000000000..05fa3542f9 --- /dev/null +++ b/tools/toolchain/scripts/stage8/simple-dftd3-1.4.0-gradient-fixes.patch @@ -0,0 +1,1210 @@ +diff --git a/src/dftd3/cutoff.f90 b/src/dftd3/cutoff.f90 +index 743774e..da2a0df 100644 +--- a/src/dftd3/cutoff.f90 ++++ b/src/dftd3/cutoff.f90 +@@ -18,7 +18,7 @@ module dftd3_cutoff + use mctc_env, only : wp + implicit none + +- public :: realspace_cutoff, get_lattice_points, smooth_cutoff ++ public :: realspace_cutoff, get_lattice_points, smooth_cutoff, apply_smooth_width_env + + + !> Coordination number cutoff +@@ -51,7 +51,7 @@ module dftd3_cutoff + real(wp) :: disp3 = disp3_default + + !> Width of smooth two-body interaction cutoff +- real(wp) :: width2 = 0.0_wp ++ real(wp) :: width2 = 0.05_wp + + !> Width of smooth three-body interaction cutoff + real(wp) :: width3 = 0.0_wp +@@ -68,6 +68,47 @@ module dftd3_cutoff + contains + + ++subroutine apply_smooth_width_env(cutoff) ++ type(realspace_cutoff), intent(inout) :: cutoff ++ ++ call get_smooth_width("SDFTD3_DISP2_SMOOTH_WIDTH", "DFTD3_DISP2_SMOOTH_WIDTH", & ++ & "TBLITE_D3_DISP2_SMOOTH_WIDTH", cutoff%disp2, cutoff%width2) ++ call get_smooth_width("SDFTD3_DISP3_SMOOTH_WIDTH", "DFTD3_DISP3_SMOOTH_WIDTH", & ++ & "TBLITE_D3_DISP3_SMOOTH_WIDTH", cutoff%disp3, cutoff%width3) ++ ++end subroutine apply_smooth_width_env ++ ++ ++subroutine get_smooth_width(env1, env2, env3, cutoff, width) ++ character(len=*), intent(in) :: env1, env2, env3 ++ real(wp), intent(in) :: cutoff ++ real(wp), intent(inout) :: width ++ ++ character(len=64) :: env ++ integer :: stat, io ++ real(wp) :: env_width ++ ++ call get_environment_variable(env1, env, status=stat) ++ if (stat /= 0 .or. len_trim(env) == 0) then ++ call get_environment_variable(env2, env, status=stat) ++ end if ++ if (stat /= 0 .or. len_trim(env) == 0) then ++ call get_environment_variable(env3, env, status=stat) ++ end if ++ if (stat == 0 .and. len_trim(env) > 0) then ++ read(env, *, iostat=io) env_width ++ if (io == 0) then ++ if (env_width > 0.0_wp .and. env_width < cutoff) then ++ width = env_width ++ else ++ width = 0.0_wp ++ end if ++ end if ++ end if ++ ++end subroutine get_smooth_width ++ ++ + !> Smooth polynomial switch for realspace cutoffs + pure subroutine smooth_cutoff(r, cutoff, width, sw, dswdr) + real(wp), intent(in) :: r +diff --git a/src/dftd3/damping/atm.f90 b/src/dftd3/damping/atm.f90 +index 419561a..9ce6521 100644 +--- a/src/dftd3/damping/atm.f90 ++++ b/src/dftd3/damping/atm.f90 +@@ -128,23 +128,16 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, rs9, alp, rv + real(wp) :: cutoff2, c9, dE, alp3 + real(wp) :: swij, swjk, swik, dswdr, sw + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + alp3 = alp / 3.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, trans, c6, s9, rs9, alp3, rvdw, cutoff2, cutoff, width) & + !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & + !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & + !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & +- !$omp& swij, swjk, swik, dswdr, sw) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& swij, swjk, swik, dswdr, sw) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -190,20 +183,15 @@ subroutine get_atm_dispersion_energy(mol, trans, cutoff, width, s9, rs9, alp, rv + rr = ang*fdmp + + dE = rr * c9 * triple * sw / 3.0_wp +- energy_local(iat) = energy_local(iat) - dE +- energy_local(jat) = energy_local(jat) - dE +- energy_local(kat) = energy_local(kat) - dE ++ energy(iat) = energy(iat) - dE ++ energy(jat) = energy(jat) - dE ++ energy(kat) = energy(kat) - dE + end do + end do + end do + end do + end do +- !$omp end do +- !$omp critical (get_atm_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_atm_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_atm_dispersion_energy + +@@ -262,30 +250,17 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, rs9, alp, rv + real(wp) :: alp3, r0r1alp3 + real(wp) :: swij, swjk, swik, dswijdr, dswjkdr, dswikdr, sw + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + alp3 = alp / 3.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & + !$omp shared(mol, trans, c6, s9, rs9, alp, alp3, rvdw, cutoff2, cutoff, width, dc6dcn) & + !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, ic, jc, vij, vjk, vik, & + !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & + !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, dfdmp, ang, & + !$omp& dang, c9, dE, dE0, dGij, dGjk, dGik, dS, r0r1alp3, swij, & +- !$omp& swjk, swik, dswijdr, dswjkdr, dswikdr, sw) & +- !$omp shared(energy, gradient, sigma, dEdcn) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& swjk, swik, dswijdr, dswjkdr, dswikdr, sw) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -359,13 +334,13 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, rs9, alp, rv + & - dE0 * dswjkdr / rjk * swij * swik * vjk + + dE = dE0 * triple * sw +- energy_local(iat) = energy_local(iat) - dE/3.0_wp +- energy_local(jat) = energy_local(jat) - dE/3.0_wp +- energy_local(kat) = energy_local(kat) - dE/3.0_wp ++ energy(iat) = energy(iat) - dE/3.0_wp ++ energy(jat) = energy(jat) - dE/3.0_wp ++ energy(kat) = energy(kat) - dE/3.0_wp + +- gradient_local(:, iat) = gradient_local(:, iat) - (dGij + dGik) * triple +- gradient_local(:, jat) = gradient_local(:, jat) + (dGij - dGjk) * triple +- gradient_local(:, kat) = gradient_local(:, kat) + (dGik + dGjk) * triple ++ gradient(:, iat) = gradient(:, iat) - (dGij + dGik) * triple ++ gradient(:, jat) = gradient(:, jat) + (dGij - dGjk) * triple ++ gradient(:, kat) = gradient(:, kat) + (dGik + dGjk) * triple + + do ic = 1, 3 + do jc = 1, 3 +@@ -374,31 +349,20 @@ subroutine get_atm_dispersion_derivs(mol, trans, cutoff, width, s9, rs9, alp, rv + end do + end do + +- sigma_local(:, :) = sigma_local + dS * triple ++ sigma(:, :) = sigma(:, :) + dS * triple + +- dEdcn_local(iat) = dEdcn_local(iat) - dE * 0.5_wp & ++ dEdcn(iat) = dEdcn(iat) - dE * 0.5_wp & + & * (dc6dcn(iat, jat) / c6ij + dc6dcn(iat, kat) / c6ik) +- dEdcn_local(jat) = dEdcn_local(jat) - dE * 0.5_wp & ++ dEdcn(jat) = dEdcn(jat) - dE * 0.5_wp & + & * (dc6dcn(jat, iat) / c6ij + dc6dcn(jat, kat) / c6jk) +- dEdcn_local(kat) = dEdcn_local(kat) - dE * 0.5_wp & ++ dEdcn(kat) = dEdcn(kat) - dE * 0.5_wp & + & * (dc6dcn(kat, iat) / c6ik + dc6dcn(kat, jat) / c6jk) + end do + end do + end do + end do + end do +- !$omp end do +- !$omp critical (get_atm_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_atm_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_atm_dispersion_derivs + +@@ -444,24 +408,17 @@ subroutine get_atm_pairwise_dispersion(mol, trans, cutoff, width, s9, rs9, alp, + real(wp) :: cutoff2, c9, dE, alp3 + real(wp) :: swij, swjk, swik, dswdr, sw + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + if (abs(s9) < epsilon(1.0_wp)) return + cutoff2 = cutoff*cutoff + alp3 = alp / 3.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, trans, c6, cutoff2, cutoff, width, s9, rs9, alp3, rvdw) & + !$omp private(iat, jat, kat, izp, jzp, kzp, jtr, ktr, vij, vjk, vik, & + !$omp& r2ij, r2jk, r2ik, rij, rjk, rik, c6ij, c6jk, c6ik, triple, & + !$omp& r0ij, r0jk, r0ik, r0, r1, r2, r3, r5, rr, fdmp, ang, c9, dE, & +- !$omp& swij, swjk, swik, dswdr, sw) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& swij, swjk, swik, dswdr, sw) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -507,23 +464,18 @@ subroutine get_atm_pairwise_dispersion(mol, trans, cutoff, width, s9, rs9, alp, + rr = ang*fdmp + + dE = rr * c9 * triple * sw / 6.0_wp +- energy_local(jat, iat) = energy_local(jat, iat) - dE +- energy_local(kat, iat) = energy_local(kat, iat) - dE +- energy_local(iat, jat) = energy_local(iat, jat) - dE +- energy_local(kat, jat) = energy_local(kat, jat) - dE +- energy_local(iat, kat) = energy_local(iat, kat) - dE +- energy_local(jat, kat) = energy_local(jat, kat) - dE ++ energy(jat, iat) = energy(jat, iat) - dE ++ energy(kat, iat) = energy(kat, iat) - dE ++ energy(iat, jat) = energy(iat, jat) - dE ++ energy(kat, jat) = energy(kat, jat) - dE ++ energy(iat, kat) = energy(iat, kat) - dE ++ energy(jat, kat) = energy(jat, kat) - dE + end do + end do + end do + end do + end do +- !$omp end do +- !$omp critical (get_atm_pairwise_dispersion_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_atm_pairwise_dispersion_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_atm_pairwise_dispersion + +diff --git a/src/dftd3/damping/cso.f90 b/src/dftd3/damping/cso.f90 +index 4253577..8fc4032 100644 +--- a/src/dftd3/damping/cso.f90 ++++ b/src/dftd3/damping/cso.f90 +@@ -172,20 +172,13 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: c6ij, edisp, dE, sw, dswdr + real(wp) :: d6_6, a2r0ij, r4 + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, rrij, r0ij, rij, d6, ef, & +- !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -213,19 +206,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE ++ energy(iat) = energy(iat) + dE + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE ++ energy(jat) = energy(jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_energy_cso_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_dispersion_energy_cso_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_energy + +@@ -279,27 +267,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: dE, dG(3), dS(3, 3) + real(wp) :: d6_6, a2r0ij, r4 + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & + !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, rrij, r0ij, rij, d6, ef, & + !$omp& sf, sig, t6, c6ij, dsig, dt6, edisp0, gdisp0, edisp, gdisp, dE, & +- !$omp& dG, dS, d6_6, a2r0ij, r4, sw, dswdr) & +- !$omp shared(energy, gradient, sigma, dEdcn) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& dG, dS, d6_6, a2r0ij, r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -339,31 +314,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + end do + end do + +- energy_local(iat) = energy_local(iat) + dE +- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp +- sigma_local(:, :) = sigma_local(:, :) + dS ++ energy(iat) = energy(iat) + dE ++ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp ++ sigma(:, :) = sigma(:, :) + dS + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE +- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp +- gradient_local(:, iat) = gradient_local(:, iat) + dG +- gradient_local(:, jat) = gradient_local(:, jat) - dG +- sigma_local(:, :) = sigma_local(:, :) + dS ++ energy(jat) = energy(jat) + dE ++ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp ++ gradient(:, iat) = gradient(:, iat) + dG ++ gradient(:, jat) = gradient(:, jat) - dG ++ sigma(:, :) = sigma(:, :) + dS + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_derivs_cso_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_dispersion_derivs_cso_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_derivs + +@@ -452,20 +416,13 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + real(wp) :: c6ij, edisp, dE, sw, dswdr + real(wp) :: d6_6, a2r0ij, r4 + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, rrij, r0ij, rij, d6, ef, & +- !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& sf, sig, t6, c6ij, edisp, dE, d6_6, a2r0ij, r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -493,19 +450,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(jat, iat) = energy_local(jat, iat) + dE ++ energy(jat, iat) = energy(jat, iat) + dE + if (iat /= jat) then +- energy_local(iat, jat) = energy_local(iat, jat) + dE ++ energy(iat, jat) = energy(iat, jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion2_cso_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion2_cso_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion2 + +diff --git a/src/dftd3/damping/mzero.f90 b/src/dftd3/damping/mzero.f90 +index 301aaf1..230c965 100644 +--- a/src/dftd3/damping/mzero.f90 ++++ b/src/dftd3/damping/mzero.f90 +@@ -172,22 +172,15 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE + real(wp) :: irs6r0, irs8r0, betr0, sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + alp6 = self%alp + alp8 = self%alp + 2.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & +- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, irs6r0, irs8r0, betr0, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, irs6r0, irs8r0, betr0, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -218,19 +211,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE ++ energy(iat) = energy(iat) + dE + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE ++ energy(jat) = energy(jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_energy + +@@ -283,29 +271,16 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: edisp0, gdisp0, edisp, gdisp, cutoff2, r0ij, rrij, c6ij, dE, dG(3), dS(3, 3) + real(wp) :: irs6r0, irs8r0, betr0, betr02rs6, betr02rs8, sw, dswdr + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + alp6 = self%alp + alp8 = self%alp + 2.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & + !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r6, r8, t6, t8, d6, & + !$omp& d8, f6, f8, edisp0, gdisp0, edisp, gdisp, r0ij, rrij, c6ij, & +- !$omp& dE, dG, dS, irs6r0, irs8r0, betr0, betr02rs6, betr02rs8, sw, dswdr) & +- !$omp shared(energy, gradient, sigma, dEdcn) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& dE, dG, dS, irs6r0, irs8r0, betr0, betr02rs6, betr02rs8, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -352,31 +327,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + end do + end do + +- energy_local(iat) = energy_local(iat) + dE +- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp +- sigma_local(:, :) = sigma_local + dS ++ energy(iat) = energy(iat) + dE ++ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp ++ sigma(:, :) = sigma(:, :) + dS + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE +- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp +- gradient_local(:, iat) = gradient_local(:, iat) + dG +- gradient_local(:, jat) = gradient_local(:, jat) - dG +- sigma_local(:, :) = sigma_local + dS ++ energy(jat) = energy(jat) + dE ++ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp ++ gradient(:, iat) = gradient(:, iat) + dG ++ gradient(:, jat) = gradient(:, jat) - dG ++ sigma(:, :) = sigma(:, :) + dS + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_derivs + +@@ -464,22 +428,15 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + real(wp) :: vec(3), r2, r1, r6, r8, t6, t8, f6, f8, alp6, alp8 + real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE, sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + cutoff2 = cutoff*cutoff + alp6 = self%alp + alp8 = self%alp + 2.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & +- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -507,19 +464,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(jat, iat) = energy_local(jat, iat) + dE ++ energy(jat, iat) = energy(jat, iat) + dE + if (iat /= jat) then +- energy_local(iat, jat) = energy_local(iat, jat) + dE ++ energy(iat, jat) = energy(iat, jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion2_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion2_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion2 + +diff --git a/src/dftd3/damping/optimizedpower.f90 b/src/dftd3/damping/optimizedpower.f90 +index 9f365ac..0def41c 100644 +--- a/src/dftd3/damping/optimizedpower.f90 ++++ b/src/dftd3/damping/optimizedpower.f90 +@@ -172,21 +172,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4 + real(wp) :: sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & + !$omp& t8, edisp, dE, rb, ab, r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, & +- !$omp& r4, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -216,19 +209,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE ++ energy(iat) = energy(iat) + dE + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE ++ energy(jat) = energy(jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_energy + +@@ -282,27 +270,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: dE, dG(3), dS(3, 3), rb, ab + real(wp) :: r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4 + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & + !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r0ij, rrij, c6ij, & + !$omp& t6, t8, d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, rb, ab, & +- !$omp& r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4, sw, dswdr) & +- !$omp shared(energy, gradient, sigma, dEdcn) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& r0ij2, r0ij6, r0ij8, abr0ij6, abr0ij8, r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -344,31 +319,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + end do + end do + +- energy_local(iat) = energy_local(iat) + dE +- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp +- sigma_local(:, :) = sigma_local + dS ++ energy(iat) = energy(iat) + dE ++ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp ++ sigma(:, :) = sigma(:, :) + dS + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE +- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp +- gradient_local(:, iat) = gradient_local(:, iat) + dG +- gradient_local(:, jat) = gradient_local(:, jat) - dG +- sigma_local(:, :) = sigma_local + dS ++ energy(jat) = energy(jat) + dE ++ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp ++ gradient(:, iat) = gradient(:, iat) + dG ++ gradient(:, jat) = gradient(:, jat) - dG ++ sigma(:, :) = sigma(:, :) + dS + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_derivs + +@@ -456,20 +420,13 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + real(wp) :: vec(3), r2, r1, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE, rb, ab + real(wp) :: sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & +- !$omp& t8, edisp, dE, rb, ab, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& t8, edisp, dE, rb, ab, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -493,19 +450,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(jat, iat) = energy_local(jat, iat) + dE ++ energy(jat, iat) = energy(jat, iat) + dE + if (iat /= jat) then +- energy_local(iat, jat) = energy_local(iat, jat) + dE ++ energy(iat, jat) = energy(iat, jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion2_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion2_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion2 + +diff --git a/src/dftd3/damping/rational.f90 b/src/dftd3/damping/rational.f90 +index a8edb7c..32aac1e 100644 +--- a/src/dftd3/damping/rational.f90 ++++ b/src/dftd3/damping/rational.f90 +@@ -170,20 +170,13 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: sw, dswdr + real(wp) :: r0ij2, r0ij6, r0ij8, r4 + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & +- !$omp& t8, edisp, dE, r0ij2, r0ij6, r0ij8, r4, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& t8, edisp, dE, r0ij2, r0ij6, r0ij8, r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -209,19 +202,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE ++ energy(iat) = energy(iat) + dE + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE ++ energy(jat) = energy(jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_energy + +@@ -275,27 +263,14 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: dE, dG(3), dS(3, 3) + real(wp) :: r0ij2, r0ij6, r0ij8, r4 + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & + !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r0ij, rrij, c6ij, & + !$omp& t6, t8, d6, d8, edisp0, gdisp0, edisp, gdisp, dE, dG, dS, & +- !$omp& r0ij2, r0ij6, r0ij8, r4, sw, dswdr) & +- !$omp shared(energy, gradient, sigma, dEdcn) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& r0ij2, r0ij6, r0ij8, r4, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -333,31 +308,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + end do + end do + +- energy_local(iat) = energy_local(iat) + dE +- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp +- sigma_local(:, :) = sigma_local + dS ++ energy(iat) = energy(iat) + dE ++ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp ++ sigma(:, :) = sigma(:, :) + dS + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE +- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp +- gradient_local(:, iat) = gradient_local(:, iat) + dG +- gradient_local(:, jat) = gradient_local(:, jat) - dG +- sigma_local(:, :) = sigma_local + dS ++ energy(jat) = energy(jat) + dE ++ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp ++ gradient(:, iat) = gradient(:, iat) + dG ++ gradient(:, jat) = gradient(:, jat) - dG ++ sigma(:, :) = sigma(:, :) + dS + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_derivs + +@@ -445,20 +409,13 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + real(wp) :: vec(3), r2, r1, cutoff2, r0ij, rrij, c6ij, t6, t8, edisp, dE + real(wp) :: sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + cutoff2 = cutoff*cutoff + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r0ij, rrij, c6ij, t6, & +- !$omp& t8, edisp, dE, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& t8, edisp, dE, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -480,19 +437,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(jat, iat) = energy_local(jat, iat) + dE ++ energy(jat, iat) = energy(jat, iat) + dE + if (iat /= jat) then +- energy_local(iat, jat) = energy_local(iat, jat) + dE ++ energy(iat, jat) = energy(iat, jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion2_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion2_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion2 + +diff --git a/src/dftd3/damping/zero.f90 b/src/dftd3/damping/zero.f90 +index 2e3ed6e..e5b78ad 100644 +--- a/src/dftd3/damping/zero.f90 ++++ b/src/dftd3/damping/zero.f90 +@@ -170,22 +170,15 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE + real(wp) :: rs6r0, rs8r0, sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) + + cutoff2 = cutoff*cutoff + alp6 = self%alp + alp8 = self%alp + 2.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & +- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -215,19 +208,14 @@ subroutine get_dispersion_energy(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(iat) = energy_local(iat) + dE ++ energy(iat) = energy(iat) + dE + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE ++ energy(jat) = energy(jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_energy_) +- energy(:) = energy(:) + energy_local(:) +- !$omp end critical (get_dispersion_energy_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_energy + +@@ -280,29 +268,16 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + real(wp) :: edisp0, gdisp0, edisp, gdisp, cutoff2, r0ij, rrij, c6ij, dE, dG(3), dS(3, 3) + real(wp) :: rs6r0, rs8r0, sw, dswdr + +- ! Thread-private arrays for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:) +- real(wp), allocatable :: dEdcn_local(:) +- real(wp), allocatable :: gradient_local(:, :) +- real(wp), allocatable :: sigma_local(:, :) + + cutoff2 = cutoff*cutoff + alp6 = self%alp + alp8 = self%alp + 2.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy, gradient, sigma, dEdcn) & + !$omp shared(mol, self, c6, dc6dcn, trans, cutoff2, cutoff, width, alp6, alp8, r4r2, rvdw) & + !$omp private(iat, jat, izp, jzp, jtr, ic, jc, vec, r2, r1, r6, r8, t6, t8, d6, & + !$omp& d8, f6, f8, edisp0, gdisp0, edisp, gdisp, r0ij, rrij, c6ij, dE, & +- !$omp& dG, dS, rs6r0, rs8r0, sw, dswdr) & +- !$omp shared(energy, gradient, sigma, dEdcn) & +- !$omp private(energy_local, gradient_local, sigma_local, dEdcn_local) +- allocate(energy_local(size(energy, 1)), source=0.0_wp) +- allocate(dEdcn_local(size(dEdcn, 1)), source=0.0_wp) +- allocate(gradient_local(size(gradient, 1), size(gradient, 2)), source=0.0_wp) +- allocate(sigma_local(size(sigma, 1), size(sigma, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& dG, dS, rs6r0, rs8r0, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -346,31 +321,20 @@ subroutine get_dispersion_derivs(self, mol, trans, cutoff, width, rvdw, r4r2, c6 + end do + end do + +- energy_local(iat) = energy_local(iat) + dE +- dEdcn_local(iat) = dEdcn_local(iat) - dc6dcn(iat, jat) * edisp +- sigma_local(:, :) = sigma_local + dS ++ energy(iat) = energy(iat) + dE ++ dEdcn(iat) = dEdcn(iat) - dc6dcn(iat, jat) * edisp ++ sigma(:, :) = sigma(:, :) + dS + if (iat /= jat) then +- energy_local(jat) = energy_local(jat) + dE +- dEdcn_local(jat) = dEdcn_local(jat) - dc6dcn(jat, iat) * edisp +- gradient_local(:, iat) = gradient_local(:, iat) + dG +- gradient_local(:, jat) = gradient_local(:, jat) - dG +- sigma_local(:, :) = sigma_local + dS ++ energy(jat) = energy(jat) + dE ++ dEdcn(jat) = dEdcn(jat) - dc6dcn(jat, iat) * edisp ++ gradient(:, iat) = gradient(:, iat) + dG ++ gradient(:, jat) = gradient(:, jat) - dG ++ sigma(:, :) = sigma(:, :) + dS + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_dispersion_derivs_) +- energy(:) = energy(:) + energy_local(:) +- dEdcn(:) = dEdcn(:) + dEdcn_local(:) +- gradient(:, :) = gradient(:, :) + gradient_local(:, :) +- sigma(:, :) = sigma(:, :) + sigma_local(:, :) +- !$omp end critical (get_dispersion_derivs_) +- deallocate(energy_local) +- deallocate(dEdcn_local) +- deallocate(gradient_local) +- deallocate(sigma_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_dispersion_derivs + +@@ -459,22 +423,15 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + real(wp) :: edisp, cutoff2, r0ij, rrij, c6ij, dE + real(wp) :: rs6r0, rs8r0, sw, dswdr + +- ! Thread-private array for reduction +- ! Set to 0 explicitly as the shared variants are potentially non-zero (inout) +- real(wp), allocatable :: energy_local(:, :) + + cutoff2 = cutoff*cutoff + alp6 = self%alp + alp8 = self%alp + 2.0_wp + +- !$omp parallel default(none) & ++ !$omp parallel do schedule(runtime) default(none) reduction(+:energy) & + !$omp shared(mol, self, c6, trans, cutoff2, cutoff, width, alp6, alp8, rvdw, r4r2) & + !$omp private(iat, jat, izp, jzp, jtr, vec, r2, r1, r6, r8, t6, t8, f6, & +- !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) & +- !$omp shared(energy) & +- !$omp private(energy_local) +- allocate(energy_local(size(energy, 1), size(energy, 2)), source=0.0_wp) +- !$omp do schedule(runtime) ++ !$omp& f8, edisp, r0ij, rrij, c6ij, dE, rs6r0, rs8r0, sw, dswdr) + do iat = 1, mol%nat + izp = mol%id(iat) + do jat = 1, iat +@@ -504,19 +461,14 @@ subroutine get_pairwise_dispersion2(self, mol, trans, cutoff, width, rvdw, r4r2, + + dE = -c6ij*edisp * 0.5_wp + +- energy_local(jat, iat) = energy_local(jat, iat) + dE ++ energy(jat, iat) = energy(jat, iat) + dE + if (iat /= jat) then +- energy_local(iat, jat) = energy_local(iat, jat) + dE ++ energy(iat, jat) = energy(iat, jat) + dE + end if + end do + end do + end do +- !$omp end do +- !$omp critical (get_pairwise_dispersion2_) +- energy(:, :) = energy(:, :) + energy_local(:, :) +- !$omp end critical (get_pairwise_dispersion2_) +- deallocate(energy_local) +- !$omp end parallel ++ !$omp end parallel do + + end subroutine get_pairwise_dispersion2 + +diff --git a/src/dftd3/disp.f90 b/src/dftd3/disp.f90 +index 413683f..c75fec8 100644 +--- a/src/dftd3/disp.f90 ++++ b/src/dftd3/disp.f90 +@@ -15,7 +15,7 @@ + ! along with s-dftd3. If not, see . + + module dftd3_disp +- use dftd3_cutoff, only : realspace_cutoff, get_lattice_points ++ use dftd3_cutoff, only : realspace_cutoff, get_lattice_points, apply_smooth_width_env + use dftd3_damping, only : damping_param + use dftd3_model, only : d3_model + use dftd3_ncoord, only : get_coordination_number, add_coordination_number_derivs +@@ -69,13 +69,16 @@ subroutine get_dispersion_atomic(mol, disp, param, cutoff, energies, gradient, s + real(wp), allocatable :: c6(:, :), dc6dcn(:, :) + real(wp), allocatable :: dEdcn(:) + real(wp), allocatable :: lattr(:, :) ++ type(realspace_cutoff) :: cutoff_eff + + mref = maxval(disp%ref) + grad = present(gradient).and.present(sigma) ++ cutoff_eff = cutoff ++ call apply_smooth_width_env(cutoff_eff) + + allocate(cn(mol%nat)) +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) +- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, cn) ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) ++ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, cn) + + allocate(gwvec(mref, mol%nat)) + if (grad) allocate(gwdcn(mref, mol%nat)) +@@ -92,15 +95,15 @@ subroutine get_dispersion_atomic(mol, disp, param, cutoff, energies, gradient, s + gradient(:, :) = 0.0_wp + sigma(:, :) = 0.0_wp + end if +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) +- call param%get_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, disp%rvdw, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) ++ call param%get_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, disp%rvdw, & + & disp%r4r2, c6, dc6dcn, energies, dEdcn, gradient, sigma) +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) +- call param%get_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, disp%rvdw, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) ++ call param%get_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, disp%rvdw, & + & disp%r4r2, c6, dc6dcn, energies, dEdcn, gradient, sigma) + if (grad) then +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) +- call add_coordination_number_derivs(mol, lattr, cutoff%cn, disp%rcov, dEdcn, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) ++ call add_coordination_number_derivs(mol, lattr, cutoff_eff%cn, disp%rcov, dEdcn, & + & gradient, sigma) + end if + +@@ -165,12 +168,15 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) + + integer :: mref + real(wp), allocatable :: cn(:), gwvec(:, :), c6(:, :), lattr(:, :) ++ type(realspace_cutoff) :: cutoff_eff + + mref = maxval(disp%ref) ++ cutoff_eff = cutoff ++ call apply_smooth_width_env(cutoff_eff) + + allocate(cn(mol%nat)) +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%cn, lattr) +- call get_coordination_number(mol, lattr, cutoff%cn, disp%rcov, cn) ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%cn, lattr) ++ call get_coordination_number(mol, lattr, cutoff_eff%cn, disp%rcov, cn) + + allocate(gwvec(mref, mol%nat)) + call disp%weight_references(mol, cn, gwvec) +@@ -180,12 +186,12 @@ subroutine get_pairwise_dispersion(mol, disp, param, cutoff, energy2, energy3) + + energy2(:, :) = 0.0_wp + energy3(:, :) = 0.0_wp +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp2, lattr) +- call param%get_pairwise_dispersion2(mol, lattr, cutoff%disp2, cutoff%width2, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp2, lattr) ++ call param%get_pairwise_dispersion2(mol, lattr, cutoff_eff%disp2, cutoff_eff%width2, & + & disp%rvdw, disp%r4r2, c6, energy2) + +- call get_lattice_points(mol%periodic, mol%lattice, cutoff%disp3, lattr) +- call param%get_pairwise_dispersion3(mol, lattr, cutoff%disp3, cutoff%width3, & ++ call get_lattice_points(mol%periodic, mol%lattice, cutoff_eff%disp3, lattr) ++ call param%get_pairwise_dispersion3(mol, lattr, cutoff_eff%disp3, cutoff_eff%width3, & + & disp%rvdw, disp%r4r2, c6, energy3) + + end subroutine get_pairwise_dispersion diff --git a/tools/toolchain/scripts/tool_kit.sh b/tools/toolchain/scripts/tool_kit.sh index f307b6d2f0..359faad536 100644 --- a/tools/toolchain/scripts/tool_kit.sh +++ b/tools/toolchain/scripts/tool_kit.sh @@ -157,7 +157,7 @@ get_nprocs() { if [ -n "${NPROCS_OVERWRITE}" ]; then echo ${NPROCS_OVERWRITE} | sed 's/^0*//' elif $(command -v nproc > /dev/null 2>&1); then - echo $(nproc) + echo $(nproc --all) elif $(command -v sysctl > /dev/null 2>&1); then echo $(sysctl -n hw.ncpu) else